From Coq Require Import Arith Lia List.
Import ListNotations.
Definition dec X := sum X (X -> False).
Definition iffT (X Y: Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).
Notation "'Sigma' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

Inductive exp: Type :=
| Sym (x: nat)
| Nul
| One
| Add (s t: exp)
| Mul (s t: exp)
| Star (s: exp).

Implicit Types s t : exp.
Implicit Types A B : list nat.

Reserved Notation "A |- s" (at level 70).
Inductive sat : list nat -> exp -> Type :=
| SSym x : [x] |- Sym x
| SOne : [] |- One
| SAddL A s t : A |- s -> A |- Add s t
| SAddR A s t : A |- t -> A |- Add s t
| SMul A B s t : A |- s -> B |- t -> A ++ B |- Mul s t
| SStar1 s : [] |- Star s
| SStar2 A B s : A |- s -> B |- Star s -> A ++ B |- Star s
where "A |- s" := (sat A s).

Definition sat_inv
  : forall {A s}, A |- s ->
    match s return Type with
    | Sym x => A = [x]
    | Nul => False
    | One => A = []
    | Add s t => sum (A |- s) (A |- t)
    | Mul s t => Sigma A1 A2, prod (A = A1++A2) (prod (A1 |- s ) (A2 |- t))
    | Star s => sum (A = [])
                   (Sigma A1 A2, prod (A = A1++A2)
                                    (prod (A1 |- s) (A2 |- Star s)))
    end.
Proof.
  intros A s a.
  destruct a as [x| |A s t H |A s t H |A B s t Hs Ht|s|A B s Hs Ht].
  - reflexivity.
  - reflexivity.
  - left. exact H.
  - right. exact H.
  - exists A, B. easy.
  - left. reflexivity.
  - right. exists A, B. easy.
Defined.

(*** Facts about Star *)

Fact star1 A s :
  A |- s -> A |- Star s.
Proof.
  intros H. rewrite <-(app_nil_r A).
  constructor. exact H. constructor.
Qed.

Fact star2 A B s :
  A |- Star s -> B |- Star s -> A ++ B |- Star s.
Proof.
  revert A s.
  enough (forall A u, A |- u ->
                     match u return Type with
                     | Star s => B |- u -> A ++ B |- u
                     | _ => True
                     end) as H.
  { intros A s H1. apply (H A (Star s) H1). }
  induction 1 as [| | | | | |A1 A2 s Hs _ _ IHt];
    try exact I.
  - easy.
  - intros H.
    rewrite <- app_assoc. constructor; auto.
Qed.

Fact equiv1 A s t :
    A |- Mul (Star s) (Star s) <=> A |- Star s.
Proof.
  split.
  - intros (A1&A2&->&H1&H2) % sat_inv.
    apply star2; assumption.
  - intros H. change A with ([]++A).
    constructor. constructor. exact H.
Qed.

Fact star3 A s :
  A |- Star (Star s) -> A |- Star s.
Proof.
  revert A s.
  enough (forall A u, A |- u ->
                     match u return Type with
                     | Star (Star s) => A |- Star s
                     | _ => True
                     end) as H.
  { intros A s H1. apply (H A (Star (Star s)) H1). }
  induction 1 as [ | | | | | |A1 A2 s Hs _ _ IHt];
    try exact I.
  all: destruct s as [| | | | |s]; try exact I.
  - constructor.
  - apply star2. exact Hs. exact IHt.
Qed.

Fact equiv2 A s :
    A |- Star (Star s) <=> A |- Star s.
Proof.
  split.
  - apply star3.
  - apply star1.
Qed.

(*** Derivatives *)

Definition eps_dec s :
  dec ([] |- s).
Proof.
  induction s as [x| | |s IHs t IHt|s IHs t IHt|s IH].
  - right. intros H.  discriminate (sat_inv H).
  - right. intros H.  apply (sat_inv H).
  - left. constructor.
  - destruct IHs as [IHs|IHs].
    + left. apply SAddL, IHs.
    + destruct IHt as [IHt|IHt].
      * left. apply SAddR, IHt.
      * right. intros H. destruct (sat_inv H); easy.
  - destruct IHs as [IHs|IHs].
    + destruct IHt as [IHt|IHt].
      * left. change ([] ++ [] |- Mul s t).
        constructor; assumption.
      * right. intros H.
        destruct (sat_inv H) as (A1&A2&H1&_&H2).
        destruct A1, A2; try discriminate H1. easy.
    + right. intros H.
        destruct (sat_inv H) as (A1&A2&H1&H2&_).
        destruct A1, A2; try discriminate H1. easy.
  - left. constructor.
Defined.

Fixpoint deriv x s : exp :=
  match s with
  | Sym y => if Nat.eq_dec x y then One else Nul
  | Nul => Nul
  | One => Nul
  | Add s t => Add (deriv x s) (deriv x t)
  | Mul s t => if eps_dec s
              then Add (Mul (deriv x s) t) (deriv x t)
              else Mul (deriv x s) t
  | Star s => Mul (deriv x s) (Star s)
  end.

Lemma star4 x A s :
  x::A |- Star s -> Sigma A1 A2, prod (A = A1++A2) (prod (x::A1 |- s) (A2 |- Star s)).
Proof.
  revert x A s.
  enough (forall A s, A |- s -> match A, s return Type with
                         | x::A, Star s => Sigma A1 A2, prod (A = A1++A2)
                                                        (prod (x::A1 |- s)
                                                              (A2 |- Star s))
                         | _, _ => True
                         end) as H.
  { intros x A s H1. apply (H _ _ H1). }
  induction 1 as [ | | | | | s |A B s Hs _ Ht IHt]; try exact I.
  1-2: destruct A; exact I.
  - destruct (A ++ B); exact I.
  - destruct A as [|x A]; cbn.
    + exact IHt.
    + exists A, B. easy.
Qed.

Fact deriv_correct x A s :
  x::A |- s <=> A |- deriv x s.
Proof.
  induction s as
      [y| | |s IHs t IHt|s IHs t IHt|s IH] in x, A |-*;
    cbn; split.
  - intros [= <- ->]%sat_inv.
    destruct Nat.eq_dec as [_|H1]. constructor. easy.
  - destruct Nat.eq_dec as [<-|H1]; intros H%sat_inv; revert H; cbn.
    + intros ->. constructor.
    + easy.
  - intros []%sat_inv.
  - intros []%sat_inv.
  - intros [=]%sat_inv.
  - intros []%sat_inv.
  - intros [H|H]%sat_inv.
    + apply SAddL, IHs, H.
    + apply SAddR, IHt, H.
  - intros [H|H]%sat_inv.
    + apply SAddL, IHs, H.
    + apply SAddR, IHt, H.
  - intros (A1&A2&H1&H2&H3)%sat_inv.
    revert H1. destruct A1 as [|y A1]; cbn.
    + intros <-. destruct eps_dec as [H|H].
      * apply SAddR, IHt, H3.
      * easy.
    + intros [= <- ->]. destruct eps_dec as [H|H].
      * apply SAddL. constructor. apply IHs, H2. exact H3.
      * constructor. apply IHs, H2. exact H3.
  - destruct eps_dec as [H|H].
    + intros [H1|H1]%sat_inv.
      * revert H1. intros (A1&A2&->&H2&H3)%sat_inv.
        apply (SMul (x::A1)). apply IHs, H2. exact H3.
      * apply (SMul []). exact H. apply IHt, H1.
    + intros (A1&A2&->&H2&H3)%sat_inv.
      apply (SMul (x::A1)). apply IHs, H2. exact H3.
  - intros (A1&A2&->&H2&H3)%star4.
    apply SMul. apply IH, H2. exact H3.
  - intros (A1&A2&->&H2&H3)%sat_inv.
    apply (SStar2 (x::A1)). apply IH, H2. exact H3.
Qed.

Definition sat_dec A s :
  dec (A |- s).
Proof.
  induction A as [|x A IH] in s |-*.
  - apply eps_dec.
  - specialize (IH (deriv x s)) as [H1|H1].
    + left. apply deriv_correct, H1.
    + right. contradict H1. apply deriv_correct, H1.
Defined.

(*** Certifying Solver *)

Definition solve s :
  (Sigma A, A |- s) + (forall A, A |- s -> False).
Proof.
  induction s as [x| | |s IHs t IHt|s IHs t IHt|s _].
  - left. exists [x]. constructor.
  - right. intros A H. apply (sat_inv H).
  - left. exists []. constructor.
  - destruct IHs as [[A IHs]|IHs].
    + left. exists A. apply SAddL, IHs.
    + destruct IHt as [[B IHt]|IHt].
      * left. exists B. apply SAddR, IHt.
      * right. intros A [H|H] % sat_inv.
        -- eapply IHs, H.
        -- eapply IHt, H.
  - destruct IHs as [[A IHs]|IHs].
    + destruct IHt as [[B IHt]|IHt].
      * left. exists (A ++ B). constructor; assumption.
      * right. intros C H.
        destruct (sat_inv H) as (_&B&_&_&H3).
        eapply IHt, H3.
    + right. intros C H.
      destruct (sat_inv H) as (A'&_&_&H2&_).
      eapply IHs, H2.
  - left. exists []. constructor.
Defined.


Require Import QArith Qabs Lia.

Local Open Scope Q_scope.

Add Parametric Relation : Q Qle
   reflexivity proved by Qle_refl
   transitivity proved by Qle_trans
 as Qle_order.

Add Parametric Relation : Q Qlt
   transitivity proved by Qlt_trans
 as Qlt_order.

Instance subrelation_le_eq : subrelation Qeq Qle.
intros x y H.
rewrite H.
apply Qle_refl.
Qed.

Add Morphism Qplus with signature Qlt ++> Qlt ++> Qlt as Qplus_lt_morphism.
intros a b H1 c d H2.
destruct a as [a₁ a₂]; destruct b as [b₁ b₂]; destruct c as [c₁ c₂]; destruct d as [d₁ d₂]; simpl.
unfold Qlt in *.
simpl in *.

replace (Z.pos (b₂ * d₂))%Z with (Z.pos b₂ * Z.pos d₂)%Z; [|auto with zarith].
replace (Z.pos (a₂ * c₂))%Z with (Z.pos a₂ * Z.pos c₂)%Z; [|auto with zarith].

replace ((a₁ * Z.pos c₂ + c₁ * Z.pos a₂) * (Z.pos b₂ * Z.pos d₂))%Z with
        ((a₁ * Z.pos b₂) * (Z.pos d₂ * Z.pos c₂)  + (c₁ * Z.pos d₂) * (Z.pos a₂ * Z.pos b₂))%Z; [|ring].
replace ((b₁ * Z.pos d₂ + d₁ * Z.pos b₂) * (Z.pos a₂ * Z.pos c₂))%Z with
        ((b₁ * Z.pos a₂) * (Z.pos d₂ * Z.pos c₂) + (d₁ * Z.pos c₂) * (Z.pos a₂ * Z.pos b₂))%Z;[|ring].
apply Zplus_le_lt_compat.
apply Zmult_le_compat_r; auto with zarith. now apply Z.lt_le_incl.
apply Zmult_lt_compat_r; auto with zarith. lia.
Qed.

Add Morphism Qplus with signature Qle ++> Qle ++> Qle as Qplus_le_morphism.
 intros; apply Qplus_le_compat; assumption.
Qed.

Definition Qeq_pos x y := 0 <= x /\ x == y.

Definition Qle_pos x y := 0 <= x /\ x <= y.

Instance Qle_pos_transitive : Transitive Qle_pos.
intros ? ? ? [? ?] [? ?]; split; auto.
eapply transitivity; eassumption.
Qed.

Instance subrelation_le_pos : subrelation Qle_pos Qle.
intros ? ? [? ?]; assumption.
Qed.

Instance Qeq_pos_transitive : Transitive Qeq_pos.
intros ? ? ? [? ?] [? ?]; split; auto.
eapply transitivity; eassumption.
Qed.

Instance subrelation_eq_pos : subrelation Qeq_pos Qeq.
intros ? ? [? ?]; assumption.
Qed.

Instance Qeq_pos_symmetric : Symmetric Qeq_pos.
intros ? ?  [H1 H2]; split.
rewrite<- H2; assumption.
apply symmetry; assumption.
Qed.

Add Morphism Qmult with signature  Qle ++> Qeq_pos ++> Qle as Qmult_le_morphism.
  intros x y H1 a b [H2 H3].
  rewrite H3.
  apply Qmult_le_compat_r; auto.
  rewrite<- H3.
  assumption.
Qed.

Definition Qmax (p q : Q) : Q :=
   if Qlt_le_dec p q then q else p.
Lemma Qmax_comm : forall p q, (Qmax p q == Qmax q p)%Q.
  intros p q.
  unfold Qmax; destruct (Qlt_le_dec p q); destruct (Qlt_le_dec q p);
  auto with qarith.
Qed.
Lemma le_Qmax : forall p q r:Q, (p <= q)%Q -> (p <= Qmax q r)%Q.
Proof.
intros p q r H.
unfold Qmax. destruct (Qlt_le_dec q r).
transitivity q. apply H. auto with qarith.
apply H.
Qed.

Lemma lt_Qmax : forall p q r:Q, (p < q)%Q -> (p < Qmax q r)%Q.
Proof.
intros p q r H.
unfold Qmax ; destruct (Qlt_le_dec q r).
transitivity q ; auto with qarith.
apply H.
Qed.

Lemma Qmult_pos_le_compat :
   forall a b c d:Q, 0 <= a <= b -> 0 <= c <= d -> a*c <= b*d.
  intros.
  apply transitivity with (b*c).
  apply Qmult_le_compat_r; intuition.
  setoid_rewrite Qmult_comm.
  apply Qmult_le_compat_r; intuition.
  apply transitivity with a; intuition.
Qed.

Lemma Qmult_pos_compat :
  forall x y, 0 < x -> 0 < y -> 0 < x * y.
intros.
setoid_replace 0 with (0 * y).
apply Qmult_lt_compat_r; assumption.
ring.
Qed.

Lemma Qdiv_pos :
  forall n, forall x :Q, 0 < x -> 0 < x * (1 # n).
intros; apply Qmult_pos_compat.
assumption.
auto with qarith.
Qed.

Lemma Qplus_le_lt_compat : forall a b c d : Q, a <= b -> c < d -> a + c < b + d.
Proof.
  intros.
  apply Qle_lt_trans with (b + c).
    apply Qplus_le_l; auto.
    apply Qplus_lt_r; auto.
Qed.


Require Import Paths Fibrations Contractible Equivalences.

(** Every path between spaces gives an equivalence. *)

Definition path_to_equiv {U : Type} {V : Type} : (U = V) -> (U <~> V).
Proof.
  intro p.
  induction p.
  apply idequiv.
Defined.

(** This is functorial in the appropriate sense. *)
Lemma path_to_equiv_map {A} (P : fibration A) (x y : A) (p : x = y) :
  equiv_map (path_to_equiv (map P p)) = transport (P := P) p.
Proof.
  path_induction.
Defined.

Lemma concat_to_compose {A B C} (p : A = B) (q : B = C) :
  path_to_equiv q o path_to_equiv p = equiv_map (path_to_equiv (p @ q)).
Proof.
  path_induction.
Defined.

Ltac undo_concat_to_compose_in s :=
  match s with
    | context cxt [ equiv_map _ _ (path_to_equiv ?p) o equiv_map _ _ (path_to_equiv ?q) ] =>
      let mid := context cxt [ equiv_map _ _ (path_to_equiv (q @ p)) ] in
        path_via mid;
        [ repeat first [ apply happly | apply map | apply concat_to_compose ] | ]
  end.

Ltac undo_concat_to_compose :=
  repeat progress (
    match goal with
      | |- ?s = ?t =>
        first [ undo_concat_to_compose_in s | undo_concat_to_compose_in t ]
    end
  ).

Lemma opposite_to_inverse {A B} (p : A = B) :
  (path_to_equiv p)^-1 = path_to_equiv (!p).
Proof.
  path_induction.
Defined.

Ltac undo_opposite_to_inverse_in s :=
  match s with
    | context cxt [ (path_to_equiv ?p) ^-1 ] =>
      let mid := context cxt [ equiv_map _ _ (path_to_equiv (! p)) ] in
        path_via mid;
        [ repeat apply map; apply opposite_to_inverse | ]
  end.

Ltac undo_opposite_to_inverse :=
  repeat progress (
    match goal with
      | |- ?s = ?t =>
        first [ undo_opposite_to_inverse_in s | undo_opposite_to_inverse_in t ]
    end
  ).

(** The statement of the univalence axiom. *)

Definition univalence_statement :=
  forall (U V : Type), is_equiv (@path_to_equiv U V).

Section Univalence.

  Hypothesis univalence : univalence_statement.

  Definition path_to_equiv_equiv (U V : Type) :=
    {| equiv_map := @path_to_equiv U V ;
       equiv_is_equiv := univalence U V |}.

  (** Assuming univalence, every equivalence yields a path. *)

  Definition equiv_to_path {U V : Type} : U <~> V -> U = V :=
    inverse (path_to_equiv_equiv U V).

  (** The map [equiv_to_path] is a section of [path_to_equiv]. *)

  Definition equiv_to_path_section U V :
    forall (w : U <~> V), path_to_equiv (equiv_to_path w) = w :=
    inverse_is_section (path_to_equiv_equiv U V).

  Definition equiv_to_path_retraction U V :
    forall (p : U = V), equiv_to_path (path_to_equiv p) = p :=
    inverse_is_retraction (path_to_equiv_equiv U V).

  Definition equiv_to_path_triangle U V : forall (p : U = V),
      map path_to_equiv (equiv_to_path_retraction U V p) = equiv_to_path_section U V (path_to_equiv p) :=
    inverse_triangle (path_to_equiv_equiv U V).

  (** We can do better than [equiv_to_path]: we can turn a fibration
     fibered over equivalences to one fiberered over paths. *)

  Definition pred_equiv_to_path U V : (U <~> V -> Type) -> (U = V -> Type).
  Proof.
    intros Q p.
    apply Q.
    apply path_to_equiv.
    exact p.
  Defined.

  (** The following theorem is of central importance. Just like there
     is an induction principle for paths, there is a corresponding one
     for equivalences. In the proof we use [pred_equiv_to_path] to
     transport the predicate [P] of equivalences to a predicate [P']
     on paths. Then we use path induction and transport back to [P]. *)

  Theorem equiv_induction (P : forall U V, U <~> V -> Type) :
    (forall T, P T T (idequiv T)) -> (forall U V (e : U <~> V), P U V e).
  Proof.
    intro r.
    pose (P' := (fun U V => pred_equiv_to_path U V (P U V))).
    intros U V w.
    apply (transport (equiv_to_path_section _ _ w)).
    case (equiv_to_path w).
    apply r.
  Defined.

End Univalence.


Require Import Signature.
Section A_1.
Definition IDa := hStobL "414C 49434531 32334059 41484F4F 2E434F4D".
Definition ENTLa := hStobL "0090".
Definition A2_begin_description := "Example A.2 on SM2p2 Annex A, page 10, begins. ".
Print A2_begin_description.
Definition pbL := hStobL
"8542D69E 4C044F18 E8B92435 BF6FF7DE 45728391 5C45517D 722EDB8B 08F1DFC3".
Definition p := bLtoN pbL.
Definition abL := hStobL
  "787968B4 FA32C3FD 2417842E 73BBFEFF 2F3C848B 6831D7E0 EC65228B 3937E498".
Definition a := bLtoN abL.
Definition bbL := hStobL
  "63E4C6D3 B23B0C84 9CF84241 484BFE48 F61D59A5 B16BA06E 6E12D1DA 27C5249A".
Definition b := bLtoN bbL.
Definition xGbL := hStobL
  "421DEBD6 1B62EAB6 746434EB C3CC315E 32220B3B ADD50BDC 4C4E6C14 7FEDD43D".
Definition xG := bLtoN xGbL.
Definition yGbL := hStobL
  "0680512B CBB42C07 D47349D2 153B70C4 E5D7FDFC BFA36EA1 A85841B9 E46E09A2".
Definition yG := bLtoN yGbL.
Definition nbL := hStobL
  "8542D69E 4C044F18 E8B92435 BF6FF7DD 29772063 0485628D 5AE74EE7 C32E79B7".
Definition n := bLtoN nbL.
Definition M := strtobL "message digest".
Definition dAbL := hStobL
  "128B2FA8 BD433C6C 068C8D80 3DFF7979 2A519A55 171B1B65 0C23661D 15897263".
Definition dA := bLtoN dAbL.
Definition xAbL := hStobL
  "0AE4C779 8AA0F119 471BEE11 825BE462 02BB79E2 A5844495 E97C04FF 4DF2548A".
Definition xA := bLtoN xAbL.
Definition yAbL := hStobL
  "7C0240F8 8F1CD4E1 6352A73C 17B7F16F 07353E53 A176D684 A9FE0C6B B798E857".
Definition yA := bLtoN yAbL.
Definition ZA := hStobL
  "F4A38489 E32B45B6 F876E3AC 2168CA39 2362DC8F 23459C1D 1146FC3D BFB7BC9A".
(*Example ZAtest : ComputeZ SM3_Hash ENTLa IDa abL bbL xGbL yGbL xAbL yAbL = ZA.
Proof. vm_compute. reflexivity. Qed. *)

Definition M_bar := hStobL "F4A38489 E32B45B6 F876E3AC 2168CA39 2362DC8F
  23459C1D 1146FC3D BFB7BC9A 6D657373 61676520 64696765 7374".
(*Example M_bar_test : M_bar = ZA ++ M := Logic.eq_refl. *)

Definition ebL := hStobL
  "B524F552 CD82B8B0 28476E00 5C377FB1 9A87E6FC 682D48BB 5D42E3D9 B9EFFE76".
(*Example ebLTest : ebL = SM3_Hash M_bar.
Proof. Time vm_compute. reflexivity. Qed.*)
Definition e := bLtoN ebL.

Definition k := hStoN
  "6CB28D99 385C175C 94F94E93 4817663F C176D925 DD72B727 260DBAAE 1FB2F96F".
Definition x1 := hStoN
  "110FCDA5 7615705D 5E7B9324 AC4B856D 23E6D918 8B2AE477 59514657 CE25D112".
Definition y1 := hStoN
  "1C65D68A 4A08601D F24B431E 0CAB4EBE 084772B3 817E8581 1A8510B2 DF7ECA1A".

Definition field := pf_builder p Logic.eq_refl.
Definition G := GE_wp field (xG, yG).
Definition fa := @wrp _ field a.
Definition kG := pf_mul fa G k.
Definition P1 := GE_wp field (x1, y1).

(*Time Example kGeqP1 : GE_eqb kG P1 = true.
Proof. Time vm_compute. reflexivity. Qed. (*36s*)
*)

Definition rbL := hStobL
  "40F1EC59 F793D9F4 9E09DCEF 49130D41 94F79FB1 EED2CAA5 5BACDB49 C4E755D1".
Definition r := bLtoN rbL.

(*Example r_test : r = (e + x1) mod n := Logic.eq_refl. *)

Definition factor1 := P_inv n(1 + dA) .
Definition factor2 := P_sub n k (P_mul n r dA).
Definition sbL := hStobL
  "6FC6DAC3 2C5D5CF1 0C77DFB2 0F7C2EB6 67A45787 2FB09EC5 6327A67E C7DEEBE7".
Definition s := bLtoN sbL.

(*Example s_test : s = P_mul n factor1 factor2.
Proof. vm_compute. reflexivity. Qed.  *)

Definition fb := @wrp _ field b.
Definition crv := @pf_curve _ field fa fb Logic.eq_refl.

(*Example sigA1_test : SigWithList SM3_Hash crv nbL xGbL yGbL ENTLa IDa
  dAbL xAbL yAbL M [k] = Some (M, (NtoBbL r, NtoBbL s)).
Proof. Time vm_compute. reflexivity. Qed. *)
(*41.326s*)
(*Definition tt := P_add nN rt st .

Definition x0't := hStoN "7DEACE5F D121BC38 5A3C6317 249F413D 28C17291 A60DFD83 B835A453 92D22B0A".

Definition y0't := hStoN "2E49D5E5 279E5FA9 1E71FD8F 693A64A3 C4A94611 15A4FC9D 79F34EDC 8BDDEBD0".
*)

(*
Time Compute pf_mul  (bLtoN pIn) (bLtoN aIn) GIn st.
Cop
         (56953972629032959544647951044806105100227418879105314443365623701807475862282,
         20936847120531059614594560449863630384405530616210027663248420985042997472208)
     : FEp
Finished transaction in 641.294 secs (640.154u,0.485s) (successful)
Correct!
*)
(*
Definition x00't := hStoN "1657FA75 BF2ADCDC 3C1F6CF0 5AB7B45E 04D3ACBE 8E4085CF A669CB25 64F17A9F".

Definition y00't := hStoN "19F0115F 21E16D2F 5C3A485F 8575A128 BBCDDF80 296A62F6 AC2EB842 DD058E50".

Definition P_At := Cop (bLtoN xAIn, bLtoN yAIn).
*)
  (*
Time Compute pf_mul P_At tt (bLtoN pIn) (bLtoN aIn) .
   = Cop
         (10106326974500318093811212845647691935066743080403682598448107247190051748511,
         11731984404579341477271988893658593900522406460222700443798045098506979741264)
     : FEp
Finished transaction in 623.69 secs (621.976u,0.888s) (successful)
Correct!
*)
(*Definition x1't := hStoN "110FCDA5 7615705D 5E7B9324 AC4B856D 23E6D918 8B2AE477 59514657 CE25D112".
Definition y1't := hStoN
  "1C65D68A 4A08601D F24B431E 0CAB4EBE 084772B3 817E8581 1A8510B2 DF7ECA1A".
Definition P1t := pf_add (bLtoN pIn) (bLtoN aIn) (Cop (x0't, y0't)) (Cop (x00't, y00't)) .
*)(*Compute P1t. Correct*)
(*
Compute NtohS (P_add nN (bLtoN et) x1't).  (*Correct*)
*)
Example veryA_1_test : VeriSig SM3_Hash crv nbL xGbL yGbL xAbL yAbL rbL sbL ZA M = None.
Proof. Time vm_compute. reflexivity. Qed.
(*70s*)
Definition A2_end_description := "Example A.2 on SM2p2 Annex A, page 10, ended. ".
Print A2_end_description.
End A_1.

(*Module A_2.
Definition m := 257%N.
Definition gp := (N.shiftl 1 257) + (N.shiftl 1 12) + 1.
Definition b := false :: (hStobL "E78BCD09 746C2023 78A7E72B 12BCE002 66B9627E CB0B5A25 367AD1AD 4CC6242B").
Definition xG := false :: (hStobL "CDB9CA7F 1E6B0441 F658343F 4B10297C 0EF9B649 1082400A 62E7A748 5735FADD").
Definition yG := true :: (hStobL "3DE74DA6 5951C4D7 6DC89220 D5F7777A 611B1C38 BAE260B1 75951DC8 060C2B3E").
Definition n := hStobL "7FFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF BC972CF7 E6B6F900 945B3C6A 0CF6161D".
Definition M := strtobL "message digest".
Definition dA := hStobL "771EF3DB FF5F1CDC 32B9C572 93047619 1998B2BF 7CB981D7 F5B39202 645F0931".
Definition xA := true :: (hStobL "65961645 281A8626 607B917F 657D7E93 82F1EA5C D931F40F 6627F357 542653B2").
Definition yA := true :: (hStobL "68652213 0D590FB8 DE635D8F CA715CC6 BF3D05BE F3F75DA5 D5434544 48166612").
Definition k := hStobL "36CD79FC 8E24B735 7A8A7B4A 46D454C3 97703D64 98158C60 5399B341 ADA186D6".
Definition IDa := hStobL "414C 49434531 32334059 41484F4F 2E434F4D".
Definition ENTLa := hStobL "0090".

Definition e := hStoN "AD673CBD A3114171 29A9EAA5 F9AB1AA1 633AD477 18A84DFD 46C17C6F A0AA3B12".
Definition x1 := hStoN "00 3FD87D69 47A15F94 25B32EDD 39381ADF D5E71CD4 BB357E3C 6A6E0397 EEA7CD66".
Definition y1 := hStoN "00 80771114 6D73951E 9EB373A6 58214054 B7B56D1D 50B4CD6E B32ED387 A65AA6A2".

Definition nN := bLtoN n.
Definition r := hStobL "6D3FBA26 EAB2A105 4F5D1983 32E33581 7C8AC453 ED26D339 1CD4439D 825BF25B".
Definition s := hStobL "3124C568 8D95F0A1 0252A9BE D033BEC8 4439DA38 4621B6D6 FAD77F94 B74A9556".
Definition G := Cop (bLtoN xG, bLtoN yG).
Definition a := NtobL_len 257 0.

Definition Z_A := hStobL "26352AF8 2EC19F20 7BBC6F94 74E11E90 CE0F7DDA CE03B27F 801817E8 97A81FD5".

(*
Time Compute bfp_mul m gp 0 G (bLtoN k).
  *)
(*
* Cop
         (28878213983369220209949422064733326048509454351103134932255078508052236193126,
         58106417299780141903471788656951832429470650752450945419547271270608922125986)
     : GE
Finished transaction in 1146.773 secs (1143.449u,1.716s) (successful)
*)
(*
Compute NtohS (P_add nN e x1).
*)
(*
Time Compute match SigWithZAList_bfp SM3_HashN m gp a b n xG yG Z_A dA xA yA M [bLtoN k] with
  | None => None
  | Some (m',  (r, s)) =>
    Some (bLtostr m', ((bLtohS r), (bLtohS s)))
  end.
*)
(*Correct*)
(*
Time Compute VeriSig_bfp SM3_HashN m gp (bLtoN a) (bLtoN n) (bLtoN xG) (bLtoN yG) (bLtoN xA) (bLtoN yA) r s Z_A M.
= None
     : option string
     *)
 (*
Finished transaction in 2264.387 secs (2254.81u,4.95s) (successful)
*)
End A_2.
*)


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Facts on:
    Deterministic Simple Stack Machines
*)

Require Import List.
Import ListNotations.
Require Import PeanoNat Psatz.
Require Import Relations.Relation_Operators Relations.Operators_Properties.

Require Import ssreflect ssrfun ssrbool.

(* uniform boundedness of deterministic simple stack machines *)
From Undecidability.SM Require Import SSM_prelim DSSM_UB.

From Undecidability.SM.DSSM Require Import Utils.

(* width of a configuration *)
Definition width : config -> nat := fun '(A, _, B) => length A + length B.

Lemma stack_eq_dec (A B: stack) : {A = B} + {A <> B}.
Proof. by do 2 (decide equality). Qed.

Section DSSM.

Context {M : ssm}.
Variable detM : deterministic M.

(* reachability is monotone wrt. stacks *)
Lemma reachable_app {x x': state} {A B A' B' C D: stack} :
  reachable M (A, x, B) (A', x', B') -> reachable M (A++C, x, B++D) (A'++C, x', B'++D).
Proof.
  move HX: (A, x, B) => X. move HX': (A', x', B') => X'.
  move=> H. elim: H C D x x' A B A' B' HX HX'; clear.
  - move=> X X'. case; clear.
    + move=> > H >. case=> -> -> ->. case=> -> -> ->.
      apply: rt_step. by apply: step_l.
    + move=> > H >. case=> -> -> ->. case=> -> -> ->.
      apply: rt_step. by apply: step_r.
  - move=> > <-. case=> -> -> ->.
    by apply: rt_refl.
  - move=> X [[A' x'] B'] Z ? IHXY ? IHYZ *.
    apply: rt_trans; [by apply: IHXY | by apply: IHYZ].
Qed.

(* step is confluent *)
Lemma reachable_confluent {X X1 X2: config} : reachable M X X1 -> reachable M X X2 ->
  exists (Y: config), reachable M X1 Y /\ reachable M X2 Y.
Proof.
  move=> /(clos_rt_rt1n config) H /(clos_rt_rt1n config).
  elim: H X2; move: detM; clear=> detM.
    move=> X X2 HX.
    exists X2. constructor; [by apply: clos_rt1n_rt | by apply: rt_refl].
  move=> X Y Z HXY HYZ IH X2. case.
    exists Z. constructor.
      by apply: rt_refl.
    apply: clos_rt1n_rt.
    apply: Relation_Operators.rt1n_trans; by eassumption.
  move=> Y' Z'. move /(detM _ _ _ HXY)=> ?. subst Y'.
  by move /IH.
Qed.

(* joinability of configurations *)
Definition equiv (X Y: config) := exists (Z: config), reachable M X Z /\ reachable M Y Z.

Lemma equiv_refl {X: config} : equiv X X.
Proof. exists X. constructor; by apply: rt_refl. Qed.

Lemma equiv_sym {X Y: config} : equiv X Y <-> equiv Y X.
Proof. constructor; move=> [Z [? ?]]; exists Z; by constructor. Qed.

Lemma equiv_trans {X Y Z: config} : equiv X Y -> equiv Y Z -> equiv X Z.
Proof.
  move=> [Z0 [? HYZ0]] [Z1 [HYZ1 ?]].
  have [Z2 [? ?]] := (reachable_confluent HYZ0 HYZ1).
  exists Z2. constructor; apply: rt_trans; by eassumption.
Qed.

(* joinability is monotone wrt. stacks *)
Lemma equiv_app {x x': state} {A B A' B' C D: stack} : equiv (A, x, B) (A', x', B') ->
  equiv (A++C, x, B++D) (A'++C, x', B'++D).
Proof.
  move=> [[[A'' x''] B''] [? ?]].
  exists (A''++C, x'', B''++D). constructor; by apply: reachable_app.
Qed.

Corollary equiv_appR {x x': state} {A B A' B': stack} {b: bool} : equiv (A, x, B) (A', x', B') ->
  equiv (A, x, B ++ [b]) (A', x', B' ++ [b]).
Proof. move /(equiv_app (C := []) (D := [b])). by rewrite ? app_nil_r. Qed.

Corollary equiv_appL {x x': state} {A B A' B': stack} {a: bool} : equiv (A, x, B) (A', x', B') ->
  equiv (A++[a], x, B) (A'++[a], x', B').
Proof. move /(equiv_app (C := [a]) (D := [])). by rewrite ? app_nil_r. Qed.

(* list all stacks of length n *)
Fixpoint enum_stacks (n: nat) : list stack :=
  if n is S n then (map (cons true) (enum_stacks n)) ++ (map (cons false) (enum_stacks n)) else [[]].

(* all stacks of fixed length are enumerated *)
Lemma enum_stacksP {A: stack} : In A (enum_stacks (length A)).
Proof.
  elim: A => /=.
    by left.
  move=> a A IH. rewrite in_app_iff ? in_map_iff.
  case: a; [left | right]; exists A; by constructor.
Qed.

(* list all states occurring in M' *)
Fixpoint enum_states (M': ssm) : list state :=
  match M' with
  | [] => []
  | (x, y, _, _, _) :: M' => x :: y :: enum_states M'
  end.

Lemma enum_statesP {x y: state} {a b: symbol} {d: dir} : In (x, y, a, b, d) M ->
  In x (enum_states M) /\ In y (enum_states M).
Proof.
  elim: M x y a b d=> /=; clear; first done.
  move=> i M IH >. case.
    move=> ->. constructor; [by left | by right; left].
  move /IH=> [? ?]. move: i=> [[[[? ?] ?] ?] ?]. constructor; right; by right.
Qed.

Definition get_state : config -> state :=
  fun '(_, x, _) => x.

Lemma enum_states_step {X Y: config} : step M X Y ->
  In (get_state X) (enum_states M) /\ In (get_state Y) (enum_states M).
Proof.
  case=> > /enum_statesP [? ?]; by constructor.
Qed.

(* reachable configuration are either equal or have a state occurring in M *)
Lemma enum_states_reachable {X Y: config} : reachable M X Y ->
  X = Y \/ (In (get_state X) (enum_states M) /\ In (get_state Y) (enum_states M)).
Proof.
  elim.
  - move=> ? ? /enum_states_step ?. by right.
  - move=> ?. by left.
  - move=> > _ + _. case.
      move=> ->. case; [move=> ->; by left | move=> ?; by right].
    move=> [? ?]. case; [move=> <- | move=> [? ?]]; by right.
Qed.

(* list all configurations with stack lengths lA and lB *)
Definition enum_configs (lA lB: nat) : list config :=
  list_prod (list_prod (enum_stacks lA) (enum_states M)) (enum_stacks lB).

(* all configurations with states occurring in M are listed *)
Lemma enum_configsP (x: state) (A B: stack) : In x (enum_states M) ->
  In (A, x, B) (enum_configs (length A) (length B)).
Proof.
  move=> Hx. rewrite /enum_configs ? in_prod_iff.
  have ? := enum_stacksP. by (constructor; first by constructor).
Qed.

(* space X is an overapproximation of reachable states from X *)
Definition space (X: config) : list config :=
  X :: flat_map (fun i => enum_configs i (width X - i)) (seq 0 (width X + 1)).

(* reachability preserves configuration width *)
Lemma reachable_width {X Y: config} : reachable M X Y -> width X = width Y.
Proof.
  elim; clear.
  - move=> X Y. case=> *; rewrite /width /length; by lia.
  - done.
  - move=> *. by lia.
Qed.

Lemma spaceP {X Y: config} : In (get_state X) (enum_states M) -> width X = width Y -> In X (space Y).
Proof.
  rewrite /space. case: X => [[A x] B]. move=> HX <-. right.
  apply /in_flat_map. exists (length A). constructor=> /=.
    apply /in_seq. by lia.
  have -> : (length A + length B - length A = length B) by lia.
  by apply: enum_configsP.
Qed.

Lemma spaceP0 {X Y: config} : reachable M X Y -> In Y (space X).
Proof.
  move=> /copy [/enum_states_reachable + /reachable_width]. case.
    move=> <- _. by left.
  move=> [_ /spaceP] + ?. by apply.
Qed.

Lemma space_equivP {X Y: config} : equiv X Y -> In Y (space X).
Proof.
  move=> [Z] /copy [[/reachable_width + /reachable_width]] => <- /spaceP HY.
  move=> [/enum_states_reachable + /enum_states_reachable]. case.
    move=> <-. case.
      move=> <-. by left.
    move=> [? ?]. by apply: HY.
  move=> [? ?]. case.
    move=> ?. subst Z. by apply: HY.
  move=> [? ?]. by apply: HY.
Qed.

Definition get_left : config -> stack :=
  fun '(A, _, _) => A.

Definition get_right : config -> stack :=
  fun '(_, _, B) => B.

(* step relation is decidable *)
Lemma step_dec (X Y: config) : decidable (step M X Y).
Proof.
  case: (Exists_dec (fun '(x, y, a, b, d) =>
    (get_state X, get_state Y, if d then get_left X else b :: get_left X, if d then b :: get_right X else get_right X) =
    (x, y, if d then a :: get_left Y else get_left Y, if d then get_right Y else a :: get_right Y)) M).
  - move=> [[[[x y] a] b] d]. do 4 (decide equality).
  - move=> H. left. move: H. rewrite Exists_exists.
    move=> [[[[[x y] a] b] d]]. case: d.
      move=> [?]. move: X Y => [[A ?] ?] [[? ?] B] /=. case: A; case: B=> //=.
      move=> >. case=> *. subst.
      by apply: step_l.
    move=> [?]. move: X Y => [[? ?] B] [[A ?] ?] /=. case: A; case: B=> //=.
    move=> >. case=> *. subst.
    by apply: step_r.
  - move=> H. right. move=> HXY. apply: H. rewrite Exists_exists. case: HXY.
      move=> x y a b A B H. exists (x, y, a, b, true) => /=. by constructor.
    move=> x y a b A B H. exists (x, y, b, a, false) => /=. by constructor.
Qed.

(* deterministic step function *)
Definition step_f (X: config) : config :=
  if find (fun Z => step_dec X Z) (space X) is Some Y then Y else X.

Lemma step_fI {X Y: config} : step M X Y -> step_f X = Y.
Proof.
  move /copy => [HXY] /(rt_step config) /spaceP0. rewrite /step_f.
  move: (space X) => L. elim: L HXY; first done.
  move=> Z L IH HXY /=. case.
    move=> ?. subst Z. by case: (step_dec X Y).
  move /IH => {}IH. case: (step_dec X Z) => /=.
    by move /detM => /(_ _ HXY) ->.
  move=> _. by apply: IH.
Qed.

Lemma step_fE {X: config} : step_f X = X \/ step M X (step_f X).
Proof.
  rewrite /step_f.
  move HoZ: (find (fun Z : config => step_dec X Z) (space X)) => oZ.
  case: oZ HoZ.
    move=> Z /(@find_some config) [_]. case: (step_dec X Z); last done.
    move=> *. by right.
  move=> *. by left.
Qed.

Lemma reachable_fE {X Y: config} : reachable M X Y ->
  exists (n: nat), Nat.iter n step_f X = Y.
Proof.
  rewrite /reachable. move /(clos_rt_rtn1 config). elim.
  + by exists 0.
  + move=> > /step_fI ? _ [n ?]. exists (S n) => /=. by subst.
Qed.

Lemma reachable_fI {X: config} {n: nat}: reachable M X (Nat.iter n step_f X).
Proof.
  elim: n X.
    move=> ?. by apply: rt_refl.
  move=> n IH X /=. rewrite /reachable.
  apply: rt_trans.
    apply: IH.
  move: (Nat.iter n step_f X)=> Y.
  rewrite /step_f. elim: (space Y) => /=.
    by apply: rt_refl.
  move=> Z L IH2. case: (step_dec Y Z)=> /=.
    move=> ?. by apply: rt_step.
  move=> _. by apply: IH2.
Qed.

Lemma step_f_bounded {X Y: config} {n: nat} {L: list config} :
  (Forall (fun i => In (Nat.iter i step_f X) L) (seq 0 n)) -> Nat.iter n step_f X = Y ->
  exists (m: nat), m <= length L /\ Nat.iter m step_f X = Y.
Proof.
  elim /(measure_ind id): n L X Y. case.
    move=> /= *. exists 0. constructor; last done.
    by lia.
  move=> n IH L X Y. rewrite seq_last.
  move=> /=. move HZ: (Nat.iter n step_f X) => Z.
  rewrite ? Forall_norm. move=> [HL /(@in_split config)]. move=> [L1 [L2 ?]].
  case: (Exists_dec (fun i => Nat.iter i step_f X = Z) (seq 0 n)).
  - do 4 (decide equality).
  - rewrite Exists_exists => [[i]]. rewrite in_seq => [[? ?]] ?.
    have: Nat.iter (1+i) step_f X = Y.
      subst => /=. by f_equal.
    apply /IH; first by lia.
    move: HL. rewrite ? Forall_forall. move=> + j => /(_ j). rewrite ? in_seq.
    move=> + ?. apply. by lia.
  - move=> HnZ ?. subst L. move: (HZ). move /(IH n ltac:(lia) (L1++L2)). apply: unnest.
      move: HL. rewrite ? Forall_forall. move=> + j => /(_ j). rewrite ? in_seq.
      move=> + Hj => /(_ Hj). rewrite ? in_app_iff => /=.
      { case; last case.
        + move=> ?. by left.
        + move=> H. exfalso. apply: HnZ. rewrite Exists_exists.
          exists j. rewrite in_seq. subst. by constructor.
        + move=> ?. by right. }
    move=> [m]. rewrite ? app_length. move=> [? ?] /=.
    exists (S m) => /=. constructor; first by lia.
    clear HZ. by subst.
Qed.

Corollary step_f_space {X Y: config} : reachable M X Y ->
  exists (n: nat), n <= length (space X) /\ Nat.iter n step_f X = Y.
Proof.
  move /reachable_fE => [n]. move /(step_f_bounded (L := (space X))).
  apply.
  rewrite Forall_forall. move=> i _. move HZ: (Nat.iter i step_f X)=> Z.
  apply: spaceP0. subst Z. by apply: reachable_fI.
Qed.

(* reachability is decidable *)
Lemma reachable_dec (X Y: config) : decidable (reachable M X Y).
Proof.
  case: (Exists_dec (fun i => Nat.iter i step_f X = Y) (seq 0 (1+ length (space X)))).
  - move=> i. do 4 (decide equality).
  - move=> + /ltac:(left). rewrite Exists_exists. move=> [n [_ <-]]. by apply: reachable_fI.
  - move=> + /ltac:(right) /step_f_space => + [n [? ?]]. apply.
    rewrite Exists_exists. exists n. constructor; last done.
    rewrite in_seq. by lia.
Qed.

(* joinability is decidable *)
Lemma equiv_dec (X Y: config) : decidable (equiv X Y).
Proof.
  case: (Exists_dec (fun Z => reachable M X Z /\ reachable M Y Z) (space X)).
  - move=> Z. case: (reachable_dec X Z) => ?; case: (reachable_dec Y Z) => ?; by firstorder done.
  - move=> + /ltac:(left). rewrite Exists_exists. move=> [Z [? ?]].
    eexists. by eassumption.
  - move=> + /ltac:(right) => + [Z [? ?]]. apply. rewrite Exists_exists.
    exists Z. constructor.
      by apply: spaceP0.
    by constructor.
Qed.

(* X is narrow iff X ~ A|x|ϵ *)
Definition narrow (X: config) := exists (x: state) (A: stack), equiv X (A, x, []).

(* narrow X is decidable *)
Lemma narrow_dec (X: config) : decidable (narrow X).
Proof.
  case: (Exists_dec (fun Y => get_right Y = [] /\ equiv X Y) (space X)).
  - move=> [[A y]]. case; first last.
      move=> >. right. by move=> [+].
    case: (equiv_dec X (A, y, [])).
      move=> ?. by left.
    move=> ?. right. by move=> [_].
  - move=> + /ltac:(left). rewrite Exists_exists. move=> [[[A y] B] [_]] /= [->] ?.
    by exists y, A.
  - move=> + /ltac:(right) => + [y [A HX]]. rewrite Exists_exists. apply.
    exists (A, y, []). constructor; last done.
    by apply: space_equivP.
Qed.

Lemma narrow_appL {x: state} {A B: stack} {a: bool} : narrow (A, x, B) -> narrow (A ++ [a], x, B).
Proof.
  move=> [y [A']].
  move /(equiv_app (C := [a]) (D := [])). rewrite ? app_nil_r => ?.
  do 2 eexists. by eassumption.
Qed.

Lemma remove_rendundant_suffixL {x: state} {A B: stack} {a: symbol} {Y: config}: reachable M (A++[a], x, B) Y ->
  (exists (x': state) (B': stack), reachable M (A++[a], x, B) ([], x', B')) \/
  (exists (C: stack), get_left Y = C ++ [a] /\ reachable M (A, x, B) (C, get_state Y, get_right Y)).
Proof.
  move HX: (A ++ [a], x, B) => X H. elim: H x A B a HX.
  - move=> ? ?. case.
    + move=> x y a b. case.
      * move=> B ? > _. left. exists y, (b::B). apply: rt_step. by apply: step_l.
      * move=> a' A B ? >.
        have [A'' [a'' ->]] := (@exists_last _ (a' :: A) ltac:(done)).
        case. rewrite app_comm_cons. move /(@app_inj_tail symbol). case=> ? ? ? ?. subst.
        right. exists A''. constructor; first done.
        apply: rt_step. by apply: step_l.
    + move=> > ? >. case=> <- -> ->. right. eexists. constructor.
        rewrite app_comm_cons. by reflexivity.
      apply: rt_step. by apply: step_r.
  - move=> > <-. right. eexists. constructor; first by reflexivity.
    by apply: rt_refl.
  - move=> {}X {}[[A' x'] B'] Z. move=> _ IH1 _ IH2 x A B a ?. subst.
    case: (IH1 x A B a ltac:(done)).
      move=> ?. by left.
    move=> /= [C' [? Hxx']]. subst.
    case: (IH2 x' C' B' a ltac:(done)).
      move=> [x'' [B'' ?]]. left.
      exists x'', B''. apply: rt_trans; last by eassumption.
      have -> : (B = B ++ []) by rewrite app_nil_r.
      have -> : (B' = B' ++ []) by rewrite app_nil_r.
      by apply: reachable_app.
    move=> [C'' [? ?]]. right. exists C''. constructor; first done.
    apply: rt_trans; by eassumption.
Qed.

Lemma remove_rendundant_suffixR {x: state} {A B: stack} {b: symbol} {Y: config} : reachable M (A, x, B++[b]) Y ->
  (exists (x': state) (A': stack), reachable M (A, x, B++[b]) (A', x', [])) \/
  (exists (D: stack), get_right Y = D ++ [b] /\ reachable M (A, x, B) (get_left Y, get_state Y, D)).
Proof.
  move HX: (A, x, B ++ [b]) => X H. elim: H x A B b HX.
  - move=> ? ?. case.
    + move=> > ? >. case=> -> -> <-. right. eexists. constructor.
        rewrite app_comm_cons. by reflexivity.
      apply: rt_step. by apply: step_l.
    + move=> x y a b A. case.
      * move=> ? > _. left. exists y, (a::A). apply: rt_step. by apply: step_r.
      * move=> b' B ? >.
        have [B'' [b'' ->]] := (@exists_last _ (b' :: B) ltac:(done)).
        case=> ? ?. rewrite app_comm_cons. move /(@app_inj_tail symbol). case=> ? ?. subst.
        right. exists B''. constructor; first done.
        apply: rt_step. by apply: step_r.
  - move=> > <-. right. eexists. constructor; first by reflexivity.
    by apply: rt_refl.
  - move=> {}X {}[[A' x'] B'] Z. move=> _ IH1 _ IH2 x A B b ?. subst.
    case: (IH1 x A B b ltac:(done)).
      move=> ?. by left.
    move=> /= [D' [? Hxx']]. subst.
    case: (IH2 x' A' D' b ltac:(done)).
      move=> [x'' [A'' ?]]. left.
      exists x'', A''. apply: rt_trans; last by eassumption.
      have -> : (A = A ++ []) by rewrite app_nil_r.
      have -> : (A' = A' ++ []) by rewrite app_nil_r.
      by apply: reachable_app.
    move=> [D'' [? ?]]. right. exists D''. constructor; first done.
    apply: rt_trans; by eassumption.
Qed.

(* if M is bounded, then the sizes of right stacks of reachable configurations differ at most by n *)
Lemma bounded_stack_difference {n: nat} {x y: state} {A B C D: stack} : bounded M n -> reachable M (A, x, B) (C, y, D) ->
  length B <= length D + n /\ length D <= length B + n.
Proof.
  move /(_ (A, x, B)) => [L [HL1 HL2]].
  move /reachable_fE => [m]. move /(step_f_bounded (L := L)).
  apply: unnest.
    rewrite Forall_forall => m' _. apply: HL1. by apply: reachable_fI.
  move=> [{}m [?]].
  move=> H. suff: length B <= length D + m /\ length D <= length B + m by lia.
  move: detM H. clear=> detM.
  elim: m x y A B C D.
    move=> > /=. case=> *. subst. by lia.
  move=> m IH x y A B C D /=.
  move HZ: (Nat.iter m step_f (A, x, B)) => [[A' x'] B'].
  move: HZ. move /IH => [HBB' HB'B].
  case: (step_fE (X := (A', x', B'))).
    move=> ->. case=> *. subst. by lia.
  move=> + H. move: H => ->. move HX: (A', x', B') => X. move HY: (C, y, D) => Y.
  move=> H. case: H HX HY.
  - move=> > ?. case=> ? ? ?. case=> ? ? ?. subst. move=> /=. by lia.
  - move=> > ?. case=> ? ? ?. case=> ? ? ?. subst. move: HBB' HB'B => /=. by lia.
Qed.

(* bound on size of the right stack for narrow configurations with empty left stack *)
Definition bounded' (n: nat) : Prop := forall (c: config) (x y: state) (A B: stack),
  reachable M (A, x, []) c -> reachable M ([], y, B) c -> length B <= n.

Lemma length_flat_map_le {X: Type} {f g: nat -> list X} {l1 l2: nat} : l1 <= l2 ->
  (forall i, length (f i) <= length (g i)) ->
  length (flat_map f (seq 0 l1)) <= length (flat_map g (seq 0 l2)).
Proof.
  move: (X in (seq X)) => i. move=> + Hfg. elim: l1 l2 i.
    move=> /= *. by lia.
  move=> l1 IH l2 i ?. have -> : (l2 = S (l2 - 1)) by lia.
  move=> /=. rewrite ? app_length.
  have := (IH (l2 - 1) (S i) ltac:(lia)).
  have := (Hfg i). by lia.
Qed.

Lemma length_enum_stacks {l: nat} : length (enum_stacks l) = Nat.pow 2 l.
Proof.
  elim: l; first done.
  move=> l /=. rewrite app_length ? map_length. move=> ->. by lia.
Qed.

Lemma length_enum_configs {lA lB} : length (enum_configs lA lB) = length (enum_stacks lA) * length (enum_states M) * length (enum_stacks lB).
Proof.
  by rewrite /enum_configs ? prod_length.
Qed.

(* size of space is monotonous in configuration width *)
Lemma space_length {X Y: config} :
  width X <= width Y -> length (space X) <= length (space Y).
Proof.
  rewrite /space => /=. move: (width X) => l1. move: (width Y) => l2. clear.
  move=> H. apply: le_n_S.
  apply: length_flat_map_le; first by lia.
  move=> i. rewrite ? length_enum_configs ? length_enum_stacks.
  have: 2 ^ (l1 - i) <= 2 ^ (l2 - i).
    apply: Nat.pow_le_mono_r; by lia.
  by nia.
Qed.

(* a configuration X either explores its full space or has a redundint suffix on one of the stacks *)
Theorem reachable_suffixes (X: config) :
  (exists A x y B, reachable M X (A, x, []) /\ reachable M X ([], y, B)) \/
  (exists AX a, get_left X = AX ++ [a] /\ forall Y, reachable M X Y -> exists AY, get_left Y = AY ++ [a] /\
    reachable M (AX, get_state X, get_right X) (AY, get_state Y, get_right Y)) \/
  (exists BX b, get_right X = BX ++ [b] /\ forall Y, reachable M X Y -> exists BY, get_right Y = BY ++ [b] /\
    reachable M (get_left X, get_state X, BX) (get_left Y, get_state Y, BY)).
Proof.
  case: (Exists_dec (fun Y => get_right Y = [] /\ reachable M X Y) (space X)).
    move=> [[A x]]. case; first last.
      move=> >. right. by move => [? ?].
    case: (reachable_dec X (A, x, [])); first last.
      move=> >. right. by move => [? ?].
    move=> ?. by left.
  case: (Exists_dec (fun Y => get_left Y = [] /\ reachable M X Y) (space X)).
    move=> [[+ x] B]. case; first last.
      move=> >. right. by move => [? ?].
    case: (reachable_dec X ([], x, B)); first last.
      move=> >. right. by move => [? ?].
    move=> ?. by left.
  all: rewrite ?Exists_exists.
  - move=> [[[A1 x1] B1]] + [[[A2 x2] B2]] => /= [[_ [? ?]]] [_ [? ?]]. subst.
    left. do 4 eexists. constructor; by eassumption.
  - move=> HX _. right. left. case: (stack_eq_dec (get_left X) []).
      move=> ?. exfalso. apply: HX. exists X. constructor; first by left.
      constructor; first done. apply: rt_refl.
    move /exists_last => [A [a HAa]]. exists A, a. constructor; first done.
    move=> Y. move: X HX HAa => [[AX xX] BX] HX /= HAa. subst.
    case /remove_rendundant_suffixL; last done.
    move=> [x' [B' ?]]. exfalso. apply: HX. exists ([], x', B').
    constructor; first by apply: spaceP0.
    by constructor.
  - move=> HX. right. right. case: (stack_eq_dec (get_right X) []).
      move=> ?. exfalso. apply: HX. exists X. constructor; first by left.
      constructor; first done. apply: rt_refl.
    move /exists_last => [B [b HBb]]. exists B, b. constructor; first done.
    move=> Y. move: X HX HBb => [[AX xX] BX] HX /= HBb. subst.
    case /remove_rendundant_suffixR; last done.
    move=> [x' [A' ?]]. exfalso. apply: HX. exists (A', x', []).
    constructor; first by apply: spaceP0.
    by constructor.
Qed.

(* if sizes of right stacks of narrow configurations with empty left stack are bounded by m,
  then M is bounded *)
Lemma bounded_of_bounded' {n: nat}: bounded' n -> exists (m: nat), bounded M m.
Proof.
  move=> Hn.
  pose W := (repeat false n, 0, repeat false n) : config.
  exists (length (space W)). elim /(measure_ind width).
  move=> X IH. case: (reachable_suffixes X); last case.
  - move=> [?] [?] [?] [?] [+ /copy] => /reachable_confluent H [/H{H}] [Y].
    move=> [/Hn] H /H{H} ? /reachable_width HwX. move=> /= in HwX.
    exists (space X). constructor.
      by move=> ? /spaceP0.
    apply: space_length => /=. rewrite repeat_length. by lia.
  - move: X IH => [[A x] B] IH. move=> [AX] [a] [HA HX]. move=> /= in HA. subst.
    case: (IH (AX, x, B)).
      move=> /=. rewrite app_length /length. by lia.
    move=> L [HL1 HL2]. exists (map (fun '(A, x, B) => (A ++ [a], x, B)) L).
    constructor; last by rewrite map_length.
    move=> [[A' y] B'] /HX [AY] /= [->] /HL1 ?. rewrite in_map_iff.
    eexists. by constructor; last by eassumption.
  - move: X IH => [[A x] B] IH. move=> [BX] [b] [HB HX]. move=> /= in HB. subst.
    case: (IH (A, x, BX)).
      move=> /=. rewrite app_length /length. by lia.
    move=> L [HL1 HL2]. exists (map (fun '(A, x, B) => (A, x, B ++ [b])) L).
    constructor; last by rewrite map_length.
    move=> [[A' y] B'] /HX [BY] /= [->] /HL1 ?. rewrite in_map_iff.
    eexists. by constructor; last by eassumption.
Qed.

Lemma bounded_to_bounded' {n: nat}: bounded M n -> exists (m: nat), bounded' m.
Proof.
  move=> Hn. exists (n+n). rewrite /bounded'.
  move=> [[A' z] B'] x y A B /(bounded_stack_difference Hn) + /(bounded_stack_difference Hn) => /=.
  by lia.
Qed.

(* right stack size bound translates to all narrow configurations *)
Lemma extend_bounded' {n: nat} {X: config} : bounded' n -> narrow X -> length (get_right X) <= n.
Proof.
  move: X => [[A x] B] Hn. elim /(measure_ind (@length symbol)) : A => A IH.
  case: (stack_eq_dec A []).
    move=> -> [y [A']] [Z [+ ?]]. move /Hn. apply. by eassumption.
  move /exists_last => [A' [a HA]]. subst A. rename A' into A.
  move=> [y [A']] [Z [Hx]]. case: (stack_eq_dec A' []).
    move=> ->. move: Hx => /reachable_width + /reachable_width => <- /=. by lia.
  move /exists_last => [A'' [a' HA']]. subst A'. rename A'' into A'.
  move: Z Hx => [[A'' z] B''] /copy [/remove_rendundant_suffixL]. case.
    move=> [x' [B']] /copy [/reachable_width] /= HB Hx1 Hx2 Hy.
    have [Y [HY1 HY2]] := (reachable_confluent Hx1 Hx2).
    move: Hy HY2 HY1 => /(@rt_trans config). move=> H /H{H}.
    move /Hn => H /H{H}. by lia.
  move=> /= [A''' [? Hx]]. subst A''. rename A''' into A''.
  move=> _ /copy [/remove_rendundant_suffixL]. case.
    move=> [x' [B']]. move=> /copy [/reachable_width] /=.
    rewrite app_length => /= ?. move /Hn.
    move /(_ _ _ ltac:(apply: rt_refl)) => ?.
    move: Hx => /reachable_width + /reachable_width => /=.
    rewrite ?app_length => /=. by lia.
  move=> [A''']. move=> [/(@app_inj_tail symbol) [? ?]]. subst.
  move=> ? _. apply: (IH A).
    rewrite app_length /length. by lia.
  do 3 eexists. constructor; by eassumption.
Qed.

(* equivalent characterizations of boundedness *)
Theorem boundedP : (exists n, bounded M n) <-> (exists m, bounded' m).
Proof.
  constructor.
    move=> [?]. by apply /bounded_to_bounded'.
  move=> [?]. by apply /bounded_of_bounded'.
Qed.

Lemma narrow_equiv {X Y: config} : equiv X Y -> narrow X -> narrow Y.
Proof.
  move=> /equiv_sym HXY [x [A HX]]. exists x, A.
  apply: (equiv_trans); by eassumption.
Qed.

End DSSM.


(** Definition of algebras, homomorphisms, 2-cells, and h-initiality for W A B. **)

Require Import HoTT.

Local Open Scope path_scope.
Local Open Scope fibration_scope.
Local Open Scope equiv_scope.

Section AssumeFunext.
Context `{Funext}.

(* Algebras for W A B. *)
Definition WAlg (A : Type) (B : A -> Type) : Type
  := { C : Type & forall x : A, (B x -> C) -> C }.

(* Algebra homomorphisms for W A B. *)
Definition WHom (A : Type) (B : A -> Type) (X Y : WAlg A B) : Type
  := { h : X.1 -> Y.1 &
     forall x f, h (X.2 x f) = Y.2 x (fun b => h (f b)) }.

(* Algebra 2-cells for W A B. *)
Definition WCell (A : Type) (B : A -> Type) (X Y : WAlg A B) (h_1 h_2 : WHom A B X Y) : Type
  := { alpha : h_1.1 == h_2.1 &
     forall x f,
     alpha (X.2 x f) = h_1.2 x f @ ap (Y.2 x) (path_arrow _ _ (fun b => alpha (f b))) @ (h_2.2 x f)^ }.

(* H-initial algebras for W A B. *)
Definition wHinit (A : Type) (B : A -> Type) (X : WAlg A B) : Type
  := forall (Y : WAlg A B), Contr (WHom A B X Y).

(***********************************************************************)
(***********************************************************************)

(** We show that for any homomorphisms h_1, h_2 from X to Y we have
      h_1 = h_2 <-> WCell A B X Y h_1 h_2

    The above logical equality can in fact be strengthened to an
    equivalence; however, the HoTT library does not yet have the tools
    to prove this in an elegant way.
**)
Theorem wPath2Cell (A : Type) (B : A -> Type) (X Y : WAlg A B) (h_1 h_2 : WHom A B X Y) :
  h_1 = h_2 -> WCell A B X Y h_1 h_2.
Proof.
intro p.
induction p.
split with (fun x => 1).
intros.
rewrite path_arrow_1.
hott_simpl.
Defined.

Theorem wCell2Path (A : Type) (B : A -> Type) (X Y : WAlg A B) (h_1 h_2 : WHom A B X Y) :
  WCell A B X Y h_1 h_2 -> h_1 = h_2.
Proof.
intro c. destruct c as [a t].
destruct h_1 as [g p].
destruct h_2 as [h q].
apply path_sigma_uncurried.
split with (path_arrow _ _ a).
apply H; intro x.
rewrite transport_forall_constant.
apply H; intro f.
rewrite transport_forall_constant.
rewrite transport_paths_FlFr.
rewrite ap_apply_l.
rewrite ap10_path_arrow.
rewrite ap_apply_Fr.
rewrite ap_lambda.
rewrite (t x f).
rewrite inv_pV.
rewrite inv_pp.
hott_simpl.
apply moveR_pM.
apply whiskerL.
rewrite inverse_ap.
repeat apply ap.
apply H; intro.
rewrite ap_apply_l.
rewrite ap10_path_arrow.
reflexivity.
Defined.

End AssumeFunext.

(***********************************************************************)
(***********************************************************************)


(** * StlcProp: Properties of STLC *)

Require Export Stlc.

Module STLCProp.
Import STLC.

(** In this chapter, we develop the fundamental theory of the Simply
    Typed Lambda Calculus -- in particular, the type safety
    theorem. *)

(* ###################################################################### *)
(** * Canonical Forms *)

Lemma canonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x0. exists t0.  auto.
Qed.

(* ###################################################################### *)
(** * Progress *)

(** As before, the _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take an evaluation step.  The proof is a relatively
    straightforward extension of the progress proof we saw in the
    [Types] chapter. *)

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

(** _Proof_: by induction on the derivation of [|- t \in T].

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we know immediately that [t] is a value.

    - If the last rule of the derivation was [T_App], then [t = t1
      t2], and we know that [t1] and [t2] are also well typed in the
      empty context; in particular, there exists a type [T2] such that
      [|- t1 \in T2 -> T] and [|- t2 \in T2].  By the induction
      hypothesis, either [t1] is a value or it can take an evaluation
      step.

        - If [t1] is a value, we now consider [t2], which by the other
          induction hypothesis must also either be a value or take an
          evaluation step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation was [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]).
*)

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  Case "T_App".
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply canonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      SSCase "t2 steps".
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      destruct (canonical_forms_bool t1); subst; eauto.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.

(** **** Exercise: 3 stars, optional (progress_from_term_ind) *)
(** Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  t_cases (induction t) Case; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Preservation *)

(** The other half of the type soundness property is the preservation
    of types during reduction.  For this, we need to develop some
    technical machinery for reasoning about variables and
    substitution.  Working from top to bottom (the high-level property
    we are actually interested in to the lowest-level technical lemmas
    that are needed by various cases of the more interesting proofs),
    the story goes like this:

      - The _preservation theorem_ is proved by induction on a typing
        derivation, pretty much as we did in the [Types] chapter.  The
        one case that is significantly different is the one for the
        [ST_AppAbs] rule, which is defined using the substitution
        operation.  To see that this step preserves typing, we need to
        know that the substitution itself does.  So we prove a...

      - _substitution lemma_, stating that substituting a (closed)
        term [s] for a variable [x] in a term [t] preserves the type
        of [t].  The proof goes by induction on the form of [t] and
        requires looking at all the different cases in the definition
        of substitition.  This time, the tricky cases are the ones for
        variables and for function abstractions.  In both cases, we
        discover that we need to take a term [s] that has been shown
        to be well-typed in some context [Gamma] and consider the same
        term [s] in a slightly different context [Gamma'].  For this
        we prove a...

      - _context invariance_ lemma, showing that typing is preserved
        under "inessential changes" to the context [Gamma] -- in
        particular, changes that do not affect any of the free
        variables of the term.  For this, we need a careful definition
        of

      - the _free variables_ of a term -- i.e., the variables occuring
        in the term that are not in the scope of a function
        abstraction that binds them.
*)

(* ###################################################################### *)
(** ** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].  For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]  *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

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

(* ###################################################################### *)
(** ** Substitution *)

(** We first need a technical lemma connecting free variables and
    typing contexts.  If a variable [x] appears free in a term [t],
    and if we know [t] is well typed in context [Gamma], then it must
    be the case that [Gamma] assigns a type to [x]. *)

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_: We show, by induction on the proof that [x] appears free
      in [t], that, for all contexts [Gamma], if [t] is well typed
      under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used was [afi_var], then [t = x], and from
        the assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used was [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12], and [x] appears free in [t12]; we also know that
        [x] is different from [y].  The difference from the previous
        cases is that whereas [t] is well typed under [Gamma], its
        body [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [extend_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite extend_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

(** **** Exercise: 2 stars, optional (typable_empty__closed) *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

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_: By induction on the derivation of [Gamma |- t \in T].

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t \in T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [Gamma, y:T11 |- t12 \in T12].  The induction
        hypothesis is that for any context [Gamma''], if [Gamma,
        y:T11] and [Gamma''] assign the same types to all the free
        variables in [t12], then [t12] has type [T12] under [Gamma''].
        Let [Gamma'] be a context which agrees with [Gamma] on the
        free variables in [t]; we must show [Gamma' |- \y:T11. t12 \in
        T11 -> T12].

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 \in
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

        Any variable occurring free in [t12] must either be [y], or
        some other variable.  [Gamma, y:T11] and [Gamma', y:T11]
        clearly agree on [y].  Otherwise, we note that any variable
        other than [y] which occurs free in [t12] also occurs free in
        [t = \y:T11. t12], and by assumption [Gamma] and [Gamma']
        agree on all such variables, and hence so do [Gamma, y:T11]
        and [Gamma', y:T11].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 \in T2 -> T] and [Gamma |- t2 \in T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  However, we note that all
        free variables in [t1] are also free in [t1 t2], and similarly
        for free variables in [t2]; hence the desired result follows
        by the two IHs.
*)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. destruct (eq_id_dec x0 x1)...
  Case "T_App".
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types.

    Formally, the so-called _Substitution Lemma_ says this: suppose we
    have a term [t] with a free variable [x], and suppose we've been
    able to assign a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

(** _Lemma_: If [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     extend Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

(** One technical subtlety in the statement of the lemma is that we
    assign [v] the type [U] in the _empty_ context -- in other words,
    we assume [v] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- v \in
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [v] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [v] clashing with the variable being introduced
    into the context by [T_Abs].

    _Proof_: We prove, by induction on [t], that, for all [T] and
    [Gamma], if [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T].

      - If [t] is a variable, there are two cases to consider, depending
        on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [Gamma, x:U |- x \in T] we
            conclude that [U = T].  We must show that [[x:=v]x = v] has
            type [T] under [Gamma], given the assumption that [v] has
            type [U = T] under the empty context.  This follows from
            context invariance: if a closed term has type [T] in the
            empty context, it has that type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [Gamma,
            x:U] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 \in T']
        and [|- v \in U], then [Gamma' |- [x:=v]t12 \in T'].

        The substitution in the conclusion behaves differently,
        depending on whether [x] and [y] are the same variable name.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t \in T].  But we know [Gamma,x:U |- t : T], and since the
        variable [y] does not appear free in [\y:T11. t12], the
        context invariance lemma yields [Gamma |- t \in T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 \in
        T12] by inversion of the typing relation, and [Gamma,y:T11,x:U
        |- t12 \in T12] follows from this by the context invariance
        lemma, so the IH applies, giving us [Gamma,y:T11 |- [x:=v]t12 \in
        T12].  By [T_Abs], [Gamma |- \y:T11. [x:=v]t12 \in T11->T12], and
        by the definition of substitution (noting that [x <> y]),
        [Gamma |- \y:T11. [x:=v]t12 \in T11->T12] as required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    Another technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [extend Gamma x U |- t \in T] is not completely generic, in
    the sense that one of the "slots" in the typing relation -- namely
    the context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  Case "tvar".
    rename i into y. destruct (eq_id_dec x y).
    SCase "x=y".
      subst.
      rewrite extend_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite extend_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst. rewrite neq_id...
Qed.

(** The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way. *)

(* ###################################################################### *)
(** ** Main Theorem *)

(** We now have the tools we need to prove preservation: if a closed
    term [t] has type [T], and takes an evaluation step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    evaluation relation preserves types.
*)

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

(** _Proof_: by induction on the derivation of [|- t \in T].

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as the final rules in the derivation, since in each of
      these cases [t] cannot take a step.

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been used to show that [t1 t2] takes a step to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then by the IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], the result is immediate, since
          [t2] and [t3] have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired conclusion
          follows directly from the induction hypothesis.
*)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  has_type_cases (induction HT) Case;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  Case "T_App".
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars (subject_expansion_stlc) *)
(** An exercise in the [Types] chapter asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That is,
    is it always the case that, if [t ==> t'] and [has_type t' T],
    then [empty |- t \in T]?  If so, prove it.  If not, give a
    counter-example not involving conditionals.

(* FILL IN HERE *)
[]
*)

(* ###################################################################### *)
(** * Type Soundness *)

(** **** Exercise: 2 stars, optional (type_soundness) *)

(** Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

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

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(** * Uniqueness of Types *)

(** **** Exercise: 3 stars (types_unique) *)
(** Another pleasant property of the STLC is that types are
    unique: a given term (in a given context) has at most one
    type. *)
(** Formalize this statement and prove it. *)

(* FILL IN HERE *)
(** [] *)

(* ###################################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 1 star (progress_preservation_statement) *)
(** Without peeking, write down the progress and preservation
    theorems for the simply typed lambda-calculus. *)
(** [] *)

(** **** Exercise: 2 stars (stlc_variation1) *)
(** Suppose we add a new term [zap] with the following reduction rule:
                         ---------                  (ST_Zap)
                         t ==> zap
and the following typing rule:
                      ----------------               (T_Zap)
                      Gamma |- zap : T
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation2) *)
(** Suppose instead that we add a new term [foo] with the following reduction rules:
                       -----------------                (ST_Foo1)
                       (\x:A. x) ==> foo

                         ------------                   (ST_Foo2)
                         foo ==> true
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation3) *)
(** Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC remain
    true in the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars, optional (stlc_variation4) *)
(** Suppose instead that we add the following new rule to the reduction relation:
            ----------------------------------        (ST_FunnyIfTrue)
            (if true then t1 else t2) ==> true
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation5) *)
(** Suppose instead that we add the following new rule to the typing relation:
                 Gamma |- t1 \in Bool->Bool->Bool
                     Gamma |- t2 \in Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 \in Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation6) *)
(** Suppose instead that we add the following new rule to the typing relation:
                     Gamma |- t1 \in Bool
                     Gamma |- t2 \in Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 \in Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation7) *)
(** Suppose we add the following new rule to the typing
    relation of the STLC:
                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t \in Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

End STLCProp.

(* ###################################################################### *)
(* ###################################################################### *)
(** ** Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity) *)

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty
  | TNat   : ty.

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing... *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "tnat"
  | Case_aux c "tsucc" | Case_aux c "tpred"
  | Case_aux c "tmult" | Case_aux c "tif0" ].

(** **** Exercise: 4 stars (stlc_arith) *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Progress theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties (up to [soundness]) of
      the original STLC to deal with the new syntactic forms.  Make
      sure Coq accepts the whole file. *)

(* FILL IN HERE *)
(** [] *)

End STLCArith.

(* $Date: 2014-04-23 09:37:37 -0400 (Wed, 23 Apr 2014) $ *)


Require Export D.

(** 2 stars, optional (orb_false_elim)  *)
Theorem orb_false_elim : forall b c,
  orb b c = false -> b = false /\ c = false.
Proof.
  intros b c H. destruct b.
  Case "b=true". inversion H.
  Case "b=false". destruct c.
    SCase "c=true". inversion H.
    SCase "c=false". apply conj. reflexivity. reflexivity.
Qed.