(* begin hide *)
From Coq Require Import RelationClasses.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
From mathcomp Require Import bigop path.
From RegLang Require Import languages.
From RegexpBrzozowski Require Import glue gfinset regexp finite_der.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* end hide *)

(** From now on, we consider the alphabet to be {0, 1}, but the
    following also holds for any _finite_ set with a decidable
    equality *)
Section Equiv.

Definition bregexp := regular_expression [eqType of bool].
Definition bword := word [eqType of bool].

(** The similarity is still abstracted *)
Variable similar : bregexp -> bregexp -> bool.

Definition sim : grel bregexp := similar.
Definition nsim r1 r2 := ~ sim r1 r2.

Context `{Equivalence bregexp similar}.
Variable similar_ok : forall c1 c2, similar c1 c2 -> (c1 =i c2).
Variable similar_Plus_id : forall c, similar (Plus c c) c.
Variable similar_PlusC : forall c1 c2, similar (Plus c1 c2) (Plus c2 c1).
Variable similar_PlusA : forall c1 c2 c3,
 similar (Plus (Plus c1 c2) c3) (Plus c1 (Plus c2 c3)).

Variable similar_congr_Conc : forall a b c d, similar a b -> similar c d ->
 similar (Conc a c) (Conc b d).
Variable similar_congr_Plus : forall a b c d, similar a b -> similar c d ->
 similar (Plus a c) (Plus b d).
Variable similar_congr_And : forall a b c d, similar a b -> similar c d ->
 similar (And a c) (And b d).
Variable similar_congr_Star : forall a b,
  similar a b -> similar (Star a) (Star b).
Variable similar_congr_Not : forall a b, similar a b ->
  similar (Not a) (Not b).

Let has_eps_sim := has_eps_sim similar_ok.

(** Two regexp are equivalent if their associated languages are equal *)
Definition EQUIV (E F:bregexp) := forall s:bword, (s \in E ) = (s \in F).
Notation "E ≡ F" := (EQUIV E F) ( at level 30).

(** This can be translated in the following form *)
Lemma EQUIV2 : forall E F, E ≡ F <->
  forall s, (has_eps (wder s E)) = (has_eps (wder s F)).
Proof.
rewrite /EQUIV => E F. split => h.
- move => s. rewrite -2!mem_wder 2!mem_derE. by apply: h.
- move => s. rewrite -2!mem_derE 2!mem_wder. by apply: h.
Qed.

Definition set_pair_der (E F:bregexp) : gset (bregexp*bregexp) :=
  fun G => let (e,f) := G in
     exists2 s, similar e (wder s E) & similar f (wder s F).

Definition set_pair_ders (E F:bregexp) : gset (bregexp*bregexp) :=
  fun G => let (e,f) := G in
 exists2 s, e = (wder s E) & f = (wder s F).

(** Or even further simplified:
   E and F are equivalent iff
   forall u:word, delta (E/u) = delta (F/u)
*)
Lemma EQUIV3 : forall E F, E ≡ F <->
  (forall e f, set_pair_der E F (e,f) -> has_eps e = has_eps f).
Proof.
rewrite /EQUIV => E F; split => h.
- rewrite /set_pair_der. move => e f [s] h1 h2.
  rewrite (has_eps_sim h1) (has_eps_sim h2) -!mem_wder !mem_derE.
  by apply: h.
- rewrite /set_pair_der in h => s. apply EQUIV2. move => t.
  rewrite (h (wder t E) (wder t F)) => //.
  exists t; reflexivity.
Qed.

(* begin hide *)
Definition wsim (a b: bword) : Prop := True.
Definition nwsim (a b: bword) : Prop := False.

Lemma wsim_dec : forall (a b : bword), {wsim a b}+{~wsim a b}.
Proof.
rewrite /wsim => a b. by left.
Defined.

Global Instance wsim_Eq : Equivalence wsim.
Proof.
split; by move => s.
Qed.

Definition sim3 := eq_prod (eq_prod sim sim) wsim.

Global Program Instance sim3_Eq : Equivalence sim3.

Lemma sim_dec3 : forall x y, {sim3 x y}+{~sim3 x y}.
Proof.
case => [[a1 b1] s1] [[a2 b2] s2]. rewrite /sim3 /wsim /sim /=.
case: (similar a1 a2). case: (similar b1 b2).
by left; split.
by right; case => [[]].
by right; case => [[]].
Defined.

Definition bT : bword -> Prop := fun _ => True.

Definition sim_dec2 := eq_prod_dec (sim_dec similar) (sim_dec similar).

Definition sim2 := eq_prod similar similar.
Definition nsim2 := r_prod nsim nsim.
(* end hide *)

(** The derivation function that takes a list and return the same list +
    the derivatives of each element, if it was not already there.
    To be able to give a witness in case of non-equivalence, we store the
    word use for derivation (actually we store the reverse word for
    efficienty *)
Definition der1 (E:bregexp) : bregexp  := der true E.
Definition der0 E := der false E.

(* words are stored in reverse *)
Fixpoint DER l := match l with
 | [::] => [::]
 | ((hdl,hdr),s) :: tl =>
   [:: (der1 hdl, der1 hdr, true::s) , (der0 hdl, der0 hdr, false::s) &
    DER tl ]
end.

Fixpoint DER1 l := match l with
 | [::] => [::]
 | (hd,s) :: tl => [:: (der1 hd,true::s) , (der0 hd,false::s) & DER1 tl ]
end.

Definition set_of_der := set_of_der similar.

(** The set { (e,f) | exists u, e ~ E/u & f ~ F/u } is finite
    because it is included in Der E x Der F *)
Lemma set_pair_der_is_finite: forall E F,
  Bar (r_prod (r_prod nsim nsim) nwsim) (Prod (set_pair_der E F) bT).
Proof.
move => E F.
apply (@Bar_gset_incl _   (Prod (Prod (set_of_der E) (set_of_der F)) bT)).
apply Bar_gset_prod. apply Bar_gset_prod.
by apply finite_number_of_der.
by apply finite_number_of_der.
apply cBar => x _. apply cBar => y. case => _. by rewrite /nwsim.
case => [[e f] s]. rewrite /set_pair_der /= => [[[u sime simf] _]].
split => //. split. by exists u. by exists u.
Qed.

Lemma Set_of_der_compat: forall E F,
 E_compat sim3 (Prod (set_pair_der E F) bT).
Proof.
rewrite /E_compat /set_pair_der => E F [[e f] s] [[e' f'] s'] [[] ].
rewrite /sim => h1 h2 _ [[u h3 h4] _].
split => //. exists u.
- transitivity e => //; by symmetry.
transitivity f => //; by symmetry.
Qed.

Lemma Set_of_der_compat1 : forall E, E_compat sim (set_of_der E).
Proof.
rewrite /E_compat. by apply : set_of_der_compat.
Qed.

(**  L(x) = L(y) -->  L(der a x) = L(der a y) *)
Lemma in_der_compat : forall (r1 r2:bregexp) , r1 ≡ r2 ->
  forall a,(der a r1) ≡ (der a r2).
Proof.
move => r1 r2 heq a u.
by rewrite !derE !in_residual !heq.
Qed.

Lemma in_wder_compat : forall (r1 r2:bregexp), r1 ≡ r2 -> forall s,
  (wder s r1) ≡ (wder s r2).
Proof.
move => r1 r2 heq. elim/last_ind => [ | s a hi] //= u.
rewrite -!cats1 !wder_cat /=. by apply in_der_compat.
Qed.

(** set of derivative without _up to equality_ and not symmetry *)
Definition ders (E:bregexp) := fun G => exists s, G = wder s E.

(** inclusion for = implies inclusion for ~ *)
(* TODO: maybe move this to finite_der_bis.v since I
also use it there
*)
Lemma lincl_mem_sim : forall (A:eqType) (eqA: grel A)
  (hE: Equivalence eqA) (hdec: forall x y, {eqA x y}+{~eqA x y}),
  forall (l:seq A) a, (a \in l) -> InA hdec l a.
Proof.
move => A eqA hE hdec. elim => [ | hd tl hi] //= a.
rewrite in_cons; case/orP => hu.
- rewrite (eqP hu). case: (hdec hd hd) => //=. case; by reflexivity.
- case: (hdec a hd) => //= _. by apply: hi.
Qed.

(** subset for = implies subset for ~ *)
Lemma lincl_sim : forall (A:eqType) (eqA: grel A) (hE: Equivalence eqA)
 (hdec: forall x y, {eqA x y}+{~eqA x y}),
 forall (l l':seq A), lincl l l' -> r_subset eqA l l'.
Proof.
move => A eqA hE hdec l l' hl. apply/(@R_elim _ _ hE hdec).
elim : l l' hl => [ | hd tl hi] l' //=. case/andP => hhd htl x.
case: (hdec x hd) => //=. move => heq _. rewrite (InA_eq hdec l' heq).
by apply: lincl_mem_sim.
move => _ hin. by apply: hi.
Qed.

Global Program Instance sim2_Eq : Equivalence (eq_prod sim sim).

Lemma In_DER1 : forall f f' v Y, (f,f',v) \in Y ->
  InA sim_dec3 (DER Y) (der true f, der true f',true::v).
Proof.
move => f f' v; elim => [ | [[hdl hdr] s] tl hi] //.
rewrite in_cons. case/orP.
- by move => heq; rewrite -(eqP heq) {1}/DER -/DER InA_hd.
- move => hIn.
  rewrite {1}/DER -/DER InA_tl //.
  rewrite {1}/DER -/DER InA_tl //.
  by apply: hi.
Qed.

Lemma In_DER0 : forall f f' v Y, (f,f',v) \in Y ->
   InA sim_dec3 (DER Y) (der false f, der false f',false::v).
Proof.
move => f f' v; elim => [ | [[hdl hdr] s] tl hi] //.
rewrite in_cons. case/orP.
- by move => heq; rewrite -(eqP heq) {1}/DER -/DER InA_tl // InA_hd.
- move => hIn.
  rewrite {1}/DER -/DER InA_tl //.
  rewrite {1}/DER -/DER InA_tl //.
  by apply: hi.
Qed.

Lemma tool_bl : forall (Y:seq (bregexp*bregexp*bword)),
  r_subset sim3 (DER Y) Y ->
  forall e e', ((e,e',[::]) \in Y) ->
  forall u, exists f, exists f', exists v, [/\ (f,f',v) \in Y ,
    (wder u e) ≡ f & (wder u e') ≡ f'].
Proof.
move => Y hsub e e' he.
elim/last_ind => [ | u a hi] /=.
- by exists e; exists e'; exists [::]; split .
- case: hi => f [f' [v [hf1 hf2 hf3]]].
  move/(@R_elim _ _ sim3_Eq sim_dec3) : hsub.
  have hf : (InA sim_dec3 (DER Y) (der a f,der a f',a::v)).
  + case: a.
    by apply: In_DER1.
    by apply: In_DER0.
  rewrite -!cats1 !wder_cat  => hsub.
  have hg : (InA sim_dec3 Y (der a f,der a f',a::v)).
  + by apply: hsub.
  case: (InA_inv sim3_Eq hg) => [[[g g'] w]] hg1.
  rewrite /sim3 /sim => [[[ hg2l hg2r] _]].
  exists g; exists g'; exists w; split => //.
  + move => s /=.
    rewrite (in_der_compat hf2 a s).
    by apply similar_ok; symmetry.
  + move => s /=.
    rewrite (in_der_compat hf3 a s).
    by apply similar_ok; symmetry.
Qed.

(** function that tests if a list of pairs validate the delta operator *)
Definition delta2 (efw:bregexp * bregexp * bword) := let (ef,_) := efw in
 let (e,f) := ef in has_eps e == has_eps f.

(** a derivative for = is a derivative for ~ *)
Lemma ders2der : forall E F,
 (forall x, Prod (set_pair_ders E F) bT x ->
           Prod (set_pair_der E F) bT x).
Proof.
rewrite /set_pair_ders /set_pair_der => E F [[e f] u] [[s -> ->] _].
split => //. by exists s; reflexivity.
Qed.

(** the derivative of an = derivative is an = derivative *)
Lemma gpred_list_DERs : forall E F,
(forall X, gpred_list (Prod (set_pair_ders E F) bT) X ->
           gpred_list (Prod (set_pair_ders E F) bT) (DER X)).
Proof.
move => E F.
elim => [ | [[hdl hdr] u] tl] //=  => hi.
case => [[[s -> ->] _]] htl; split.
by split => //; exists (s++[::true]); rewrite /der1 !wder_cat /=. split.
by split => //; exists (s++[::false]); rewrite /der0 !wder_cat /=.
by apply: hi.
Qed.

(** sets of pair of derivative is inductively finite for ~ *)
Lemma set_pair_der_finite: forall E F, Bar (neq sim3) (Prod (set_pair_der E F) bT).
Proof.
move => E F.
apply: (@Bar_grel_incl _ _  (r_prod nsim2 nwsim)).
- by apply set_pair_der_is_finite.
rewrite /nsim2 /nsim /r_prod /neq /sim3 /eq_prod /sim  =>
   [[[a a'] u]] [[b b'] u'].
case: (similar a b) => /=. move => hneq. left; right => hneq2.
by apply: hneq. move => _. by left; left.
Qed.

Lemma gpred_listP2 : forall (A:eqType) (E:gset A) (l:seq A) (x:A),
  (x \in l) -> gpred_list E l -> E x.
Proof.
move => A E l x. elim: l => [ | hd tl hi] //=.
rewrite in_cons. case/orP => hu [hhd htl]. by rewrite (eqP hu).
by apply: hi.
Qed.

Lemma DER_cat : forall l1 l2,
  sim_incl sim_dec3 (DER (l1 ++ l2)) ((DER l1) ++ (DER l2)).
Proof.
move => l1 l2; elim : l1 => [ | hd tl ] //=.
- by apply : sim_incl_refl.
- case: hd => [[hdl hdr] s] hi.
  rewrite !cat_cons.
  change [:: (der1 hdl, der1 hdr,true::s ),
             (der0 hdl, der0 hdr,false::s) & DER (tl ++l2)]
    with ([:: (der1 hdl, der1 hdr,true::s);
              (der0 hdl, der0 hdr,false::s)]++(DER (tl ++l2))).
  change [:: (der1 hdl, der1 hdr,true::s),
             (der0 hdl, der0 hdr,false::s) & DER tl ++ DER l2]
    with ([:: (der1 hdl, der1 hdr,true::s);
              (der0 hdl, der0 hdr,false::s)]++(DER tl ++ DER l2)).
  by rewrite sim_incl_lcongr.
Qed.

Scheme Acc_rect_dep := Induction for Acc Sort Type.

(* begin hide *)
Definition build_list_fun_acc : forall (E F:bregexp),
 forall (X Y:seq (bregexp* bregexp*bword)),
 Acc (gpred_list (Prod (set_pair_der E F) bT)) (sup sim3) X ->
 gpred_list (Prod (set_pair_ders E F) bT) X ->
 gpred_list (Prod (set_pair_ders E F) bT) Y ->
 ldisjoint sim_dec3 X Y ->
 seq (bregexp*bregexp*bword).
Proof.
move => E F X Y ha. move: Y.
elim ha using Acc_rect_dep. clear X ha.
move => X hp hi [ | hdY tlY] hpred1 hpred2.
- move => _; exact X.
- move/ldisjointP => hd.
  set Z := (X ++ hdY :: tlY).
  apply: (hi Z _ _ (lminus sim_dec3 (DER (hdY :: tlY)) Z)).
  + apply (gpred_list_incl (@ders2der E F)). by apply gpred_list_cat.
  + apply/(@sub_elim _ _ _ sim_dec3).
    split; first by move => x hx; rewrite InA_cat hx.
    exists hdY. move : (hd hdY). case: (InA sim_dec3 X hdY) => //=.
    case : sim_dec3 => //=. move => _. by case.
    case; by reflexivity. rewrite InA_cat /=.
    case: sim_dec3 => //=. by rewrite orbT.
    by case; reflexivity.
  + by apply gpred_list_cat.
  + apply: lminus_pred. by apply : gpred_list_DERs.
  + by apply: ldisjoint_lminus.
Defined.

Lemma lAcc: forall (E F:bregexp) (X:seq (bregexp*bregexp*bword)),
  Acc (gpred_list (Prod (set_pair_der E F) bT)) (sup sim3) X.
Proof.
move => E F X.
apply (guard 100). move => X'. apply: wf_sup.
- by apply: sim_dec3.
- by apply: Set_of_der_compat.
- by apply: set_pair_der_finite.
Defined.

(* simple proof of (e,f) \in [ (e,f) ] *)
Lemma EF_in_der : forall (E F:bregexp), gpred_list (Prod (set_pair_ders E F) bT) [:: (E,F,[::])].
Proof.
rewrite /set_pair_ders /= => E F. split => //. by split; [exists [::] | ].
Qed.
(* end hide *)

(** Major function: this function build the set of pairs of derivatives from two regular expressions, and then extract a list of pairs (with witness)
    from it (since it is inductively finite set) *)
Definition build_list_fun : bregexp -> bregexp ->
 seq (bregexp*bregexp*bword).
move => E F.
apply (@build_list_fun_acc E F [::(E,F,[::])]
                       (lminus sim_dec3 (DER [::(E,F,[::])]) [::(E,F,[::])])
                       (lAcc E F [:: (E,F,[::])]) (EF_in_der E F)).
- apply: lminus_pred. apply: gpred_list_DERs. by apply: EF_in_der.
- by apply: ldisjoint_lminus.
Defined.

(** Properties of this list *)
(** 1: (e,f) is in the list(e,f) *)
Lemma l1 : forall (E F:bregexp),
 forall (X Y:seq (bregexp* bregexp*bword))
 (ha: Acc (gpred_list (Prod (set_pair_der E F) bT)) (sup sim3) X)
 (hp1: gpred_list (Prod (set_pair_ders E F) bT) X)
 (hp2: gpred_list (Prod (set_pair_ders E F) bT) Y)
 (hd : ldisjoint sim_dec3 X Y),
 lincl X (build_list_fun_acc ha hp1 hp2 hd).
Proof.
move => E F X Y ha. move: Y.
elim ha using Acc_rect_dep. clear X ha.
move => X hp hi [ | hdY tlY] hp1 hp2 /=.
- move =>  _; by apply : lincl_refl.
- move =>  hd. apply: (@lincl_trans _ (X ++ hdY :: tlY)).
  by apply: lincl_catr; apply: lincl_refl.
  by apply: hi.
Qed.

(** 2: the list is made of = derivatives *)
Lemma l2 : forall (E F:bregexp),
 forall (X Y:seq (bregexp* bregexp*bword))
 (ha: Acc (gpred_list (Prod (set_pair_der E F) bT)) (sup sim3) X)
 (hp1: gpred_list (Prod (set_pair_ders E F) bT) X)
 (hp2: gpred_list (Prod (set_pair_ders E F) bT) Y)
 (hd : ldisjoint sim_dec3 X Y),
 (gpred_list (Prod (set_pair_ders E F) bT))
            (build_list_fun_acc ha hp1 hp2 hd).
Proof.
move => E F X Y ha. move : Y.
elim ha using Acc_rect_dep. clear X ha.
move => X hp hi [ | hdY tlY] hp1 hp2 /=.
- move => _. by apply: hp1.
- move => hd. by apply: hi.
Qed.

(** 3: the list is stable by derivation *)
Lemma l3 : forall (E F:bregexp),
 forall (X Y:seq (bregexp* bregexp*bword))
 (ha: Acc (gpred_list (Prod (set_pair_der E F) bT)) (sup sim3) X)
 (hp1: gpred_list (Prod (set_pair_ders E F) bT) X)
 (hp2: gpred_list (Prod (set_pair_ders E F) bT) Y)
 (hd : ldisjoint sim_dec3 X Y)
 (hs: sim_incl sim_dec3 (DER X) (X ++ Y)),
  r_subset sim3 (DER (build_list_fun_acc ha hp1 hp2 hd))
                (build_list_fun_acc ha hp1 hp2 hd).
Proof.
move => E F X Y ha. move: Y.
elim ha using Acc_rect_dep. clear X ha.
move => X hp hi [ | hdY tlY] hp1 hp2 /=.
- rewrite cats0 => _ hs. by  apply/(@sim_inclP _ _ _ sim_dec3).
- move => hd hs. apply: hi.
  apply: (@sim_incl_trans _ _ _ _ (DER X ++ DER (hdY :: tlY)))
   => /=.
  by apply: DER_cat.
  rewrite sim_incl_cat. apply/andP; split.
  by apply: sim_incl_cat2l.
  by rewrite lminus_incl.
Qed.

(** Function which test the equivalence of regular expression *)
Definition bregexp_eq (r1 r2: bregexp) : bool :=
  (all delta2  (build_list_fun r1 r2)).

(** Proof of correctness of the boolean function *)
Lemma bregexp_eqP : forall (r1 r2:bregexp),
  reflect (r1 ≡ r2) (bregexp_eq r1 r2).
Proof.
move => r1 r2.
have h1 : (r1,r2,[::]) \in build_list_fun r1 r2.
 rewrite /build_list_fun.
 apply: (linclP [:: (r1,r2,[::])]); first by apply: l1.
 by rewrite /= in_cons eq_refl.
have h2: r_subset sim3 (DER (build_list_fun r1 r2))
 (build_list_fun r1 r2).
 rewrite /build_list_fun; apply: l3.
 by rewrite lminus_incl.
apply: (iffP allP).
- rewrite /bregexp_eq => h. apply EQUIV3.
  move => e f. rewrite /set_pair_der  => [[s he hf]].
  rewrite (has_eps_sim he) (has_eps_sim hf) !has_epsE.
  case: (tool_bl  h2 h1 s) => e' [f' [v' [h'1 h'2 h'3]]].
  rewrite (h'2 [::]) (h'3 [::]) -!has_epsE. move: (h (e',f',v') h'1).
  rewrite /delta2 => heq. by rewrite (eqP heq).
- move => h [[e f] v] hIn. rewrite /delta2 !has_epsE.
  have: (Prod (set_pair_ders r1 r2) bT (e,f,v)).
   by apply: (gpred_listP2 hIn); apply: l2.
  case => [[s -> ->]] _. apply/eqP. by apply in_wder_compat.
Qed.

Lemma bregexp_dec : forall (r1 r2:bregexp), {r1 ≡ r2}+{~ r1 ≡ r2}.
Proof.
move => r1 r2.
have:= bregexp_eqP r1 r2.
case : (bregexp_eq r1 r2). move => h. left. by apply/h.
move => h. right. by move/h.
Qed.

(** For free: Inclusion for languages *)
Definition SUB (r1 r2: bregexp) := forall s, (s \in r1) -> (s \in r2).

Lemma SUB2 : forall r1 r2, SUB r1 r2 <->  r2 ≡ (Plus r1 r2).
Proof.
rewrite /SUB /EQUIV => r1 r2; split => h s.
- rewrite -!topredE /=. apply/idP/orP.
  move => h'; by right. case => hu //. by apply: h.
- rewrite (h s) -!topredE /= => h1. apply/orP. by left.
Qed.

(** To test the inclusion of L(r1) in L(r2), it suffices to test
    that r1 + r2 and r2 are equivalent *)
Definition bregexp_sub (r1 r2:bregexp) := bregexp_eq r2 (Plus r1 r2).

(* correctness of bregexp_sub *)
Lemma bregexp_subP : forall r1 r2,
  reflect (SUB r1 r2) (bregexp_sub r1 r2).
Proof.
rewrite /SUB /bregexp_sub => r1 r2. apply: (iffP idP).
- move/bregexp_eqP => h. by apply SUB2.
- move => h. apply/bregexp_eqP. by apply SUB2.
Qed.

(** In case of non equivalence, here is the function that extracts a
    witness *)
Fixpoint extract_word (l: seq (bregexp*bregexp*bword)) : option bword :=
 match l with
  | [::] => None
  | ((a,b),u) :: tl => if has_eps a == has_eps b
                       then extract_word tl
                       else Some u
end.

Definition bregexp_ce (r1 r2:bregexp) : option bword :=
  extract_word (build_list_fun r1 r2).

Lemma extract_word_tool : forall l,
 match extract_word l with
  | None => all delta2 l
  | Some u => exists e,exists f, (e,f,u) \in l /\ (predC delta2) (e,f,u)
end.
Proof.
elim => [ | [[a b] u] tl hi] //=.
case heq : (has_eps a == has_eps b) => //=.
- move : hi. case: (extract_word tl) => //=. move => w [e [f [h1 h2]]].
  exists e; exists f; rewrite in_cons. by rewrite h1 orbT.
- by exists a; exists b; rewrite in_cons heq eq_refl.
Qed.

(* begin hide *)
Definition ff (r1 r2:bregexp) (efw:bregexp*bregexp*bword) :=
 let (ef,w) := efw in let (e,f) := ef in
  (wder (rev w) r1) ≡ e /\
  (wder (rev w) r2) ≡ f.

Lemma wder_rcons : forall  a u (r:bregexp),
  wder (rcons u a) r = der a (wder u r).
Proof.
move => a. elim => [ | hd tl hi] //= r.
Qed.

(* test about the added words *)
Lemma DER_preserves_lang : forall E F X,
  gpred_list (ff E F) X -> gpred_list (ff E F) (DER X).
Proof.
move => E F. elim => [ | [[r1 r2] u] tl hi] //= [[h1 h2] h3].
rewrite !rev_cons !wder_rcons /=. split.
- split. move => s. by apply in_der_compat.
- move => s;  by apply in_der_compat.
- split. split. move => s;  by apply in_der_compat.
- move => s;  by apply in_der_compat.
by apply: hi.
Qed.

Lemma l4 : forall (E F:bregexp),
 forall (X Y:seq (bregexp*bregexp*bword))
 (ha : Acc (gpred_list (Prod (set_pair_der E F) bT)) (sup sim3) X)
 (hp1 : gpred_list (Prod (set_pair_ders E F) bT) X)
 (hp2 : gpred_list (Prod (set_pair_ders E F) bT) Y)
 (hs: ldisjoint sim_dec3 X Y),
 gpred_list (ff E F) X ->
 gpred_list (ff E F) Y ->
 gpred_list (ff E F) (build_list_fun_acc ha hp1 hp2 hs).
Proof.
move => E F X Y ha. move: Y.
elim ha using Acc_rect_dep. clear X ha.
move => X hp hi [ | hdY tlY] hhp1 hp2 hs /=.
- by move => h _.
- move => hX hY. apply: hi. apply/gpred_list_cat; split => //.
  apply: lminus_pred.
  clear hp2 hs. case: hdY hY => [[hdl hdr] s] [].
  rewrite {1}/ff  => [[h1 h2]] h3 /=; split.
  + rewrite !rev_cons !wder_rcons. split.
    move => w. by apply in_der_compat.
    move => w. by apply in_der_compat.
    split.
  + rewrite !rev_cons !wder_rcons. split.
    move => w. by apply in_der_compat.
    move => w. by apply in_der_compat.
  + by apply: DER_preserves_lang.
Qed.
(* end hide *)
(** Correctness of the above function:
    - if r1 and r2 are equivlent, we return a proof of it
    - if not, we return a word u and a proof that
      either u in L(r1) and not u in L(r2) or the other
      way around
*)
Lemma bregexp_ceP : forall r1 r2, match bregexp_ce r1 r2 with
 | None => r1 ≡ r2
 | Some s => ((rev s \in r1) && (rev s \notin r2)) \/
             ((rev s\notin r1) && (rev s\in r2))
end.
Proof.
move => r1 r2.
have htemp : gpred_list (ff r1 r2) [:: (r1, r2, [::])].
- rewrite /ff /=. by split.
have htemp2: gpred_list (ff r1 r2)
  (lminus sim_dec3 (DER [::(r1,r2,[::])]) [::(r1,r2,[::])]).
- apply: lminus_pred. by apply: DER_preserves_lang.
rewrite /bregexp_ce.
move: (extract_word_tool (build_list_fun r1 r2)).
case: extract_word.
- move => a [e [f [h1]]]. rewrite /predC /= => h2.
  have hpred : gpred_list (ff r1 r2) (build_list_fun r1 r2).
  + by rewrite /build_list_fun; apply: l4.
  move: (gpred_listP2 h1 hpred). rewrite /ff => [[hl1 hl2]].
  move : (hl1 [::]) (hl2 [::]); clear hl1 hl2.
  rewrite -!mem_derE !mem_wder /= => -> ->. move : h2.
  case: (has_eps e) => //=.  case: (has_eps f) => //= _; by left.
  case: (has_eps f) => //= _; by right.
- by move/bregexp_eqP.
Qed.

(** Extract the list of derivatives for a regexp *)
Definition build_list_der (E:bregexp) : seq (bregexp*bword) :=
 strip ( build_list_fun E E).

Lemma build_list_der_ok : forall (E:bregexp) u, exists F:bregexp, exists v,
  ((F,v) \in (build_list_der E)) /\ (wder u E) ≡ F.
Proof.
move => E u.
set L := build_list_fun E E.
case: (@tool_bl L _ E E _ u) => [ | | f [f' [v [h1 h2 h3]]]].
- rewrite /L /build_list_fun. apply: l3.
  by apply: lminus_incl.
-  apply: (linclP [:: (E,E,[::])]).
   by apply: l1. by rewrite /= in_cons eq_refl.
exists f; exists v; split => //.
rewrite /build_list_der. move/strip_in : h1.
rewrite /L => h; exact h.
Qed.

End Equiv.


Section GeneralPatternMatching.
Require Import ZArith.
Open Scope Z_scope.

(* Variables (reused) *)
Inductive Var : Set :=
    | VId : nat -> Var.

(* Patterns at p.114 *)
Inductive Pat : Set :=
    | PVar  : Var -> Pat
    | PNil  : Pat
    | PCons : Pat -> Pat -> Pat
    | PWild : Pat.

(* Expressions at p.114 *)
Inductive Exp : Set :=
    | EInt    : Z -> Exp
    | EBool   : bool -> Exp
    | EVar    : Var -> Exp
    | EPlus   : Exp -> Exp -> Exp
    | EMinus  : Exp -> Exp -> Exp
    | ETimes  : Exp -> Exp -> Exp
    | ELt     : Exp -> Exp -> Exp
    | EIf     : Exp -> Exp -> Exp -> Exp
    | ELet    : Var -> Exp -> Exp -> Exp
    | EFun    : Var -> Exp -> Exp
    | EApp    : Exp -> Exp -> Exp
    | ELetRec : Var -> Var -> Exp -> Exp -> Exp
    | ENil    : Exp
    | ECons   : Exp -> Exp -> Exp
    | EMatch  : Exp -> Clauses -> Exp
    with Clauses : Set :=
    | COne  : Pat -> Exp -> Clauses
    | CCons : Pat -> Exp -> Clauses -> Clauses.

(* Values and environments (reused) *)
Inductive Value : Set :=
    | VInt    : Z -> Value
    | VBool   : bool -> Value
    | VFun    : Env -> Var -> Exp -> Value
    | VRecFun : Env -> Var -> Var -> Exp -> Value
    | VNil    : Value
    | VCons   : Value -> Value -> Value
    with Env : Set :=
    | EEmpty  : Env
    | EBind   : Env -> Var -> Value -> Env.

(* Domains (reused) *)
Inductive in_dom : Env -> Var -> Prop :=
    | Dom_EBind1 : forall (E : Env) (x : Var) (v : Value),
                   in_dom (EBind E x v) x
    | Dom_EBind2 : forall (E : Env) (x y : Var) (v : Value),
                   in_dom E x -> in_dom (EBind E y v) x.

(* Merger of two disjoint environments *)
Inductive MergeTo : Env -> Env -> Env -> Prop :=
    | Mer_Empty  : MergeTo EEmpty EEmpty EEmpty
    | Mer_Bind_l : forall (E : Env) (x : Var) (v : Value),
                   ~ in_dom E x ->
                   MergeTo (EBind E x v) EEmpty (EBind E x v)
    | Mer_Bind_r : forall (E E1 E2 : Env) (x : Var) (v : Value),
                   MergeTo E1 E2 E -> ~ in_dom E1 x -> ~ in_dom E2 x ->
                   MergeTo E1 (EBind E2 x v) (EBind E x v).

(* Success of pattern match at p.115 *)
Inductive Match : Pat -> Value -> Env -> Prop :=
    | M_Var  : forall (x : Var) (v : Value),
               Match (PVar x) v (EBind EEmpty x v)
    | M_Nil  : Match PNil VNil EEmpty
    | M_Cons : forall (p1 p2 : Pat) (v1 v2 : Value) (E E1 E2 : Env),
               Match p1 v1 E1 -> Match p2 v2 E2 -> MergeTo E1 E2 E ->
               Match (PCons p1 p2) (VCons v1 v2) E
    | M_Wild : forall v : Value,
               Match PWild v EEmpty.

(* Failure of pattern match at p.116 *)
Inductive NotMatch : Pat -> Value -> Prop :=
    | NM_ConsNil   : forall v1 v2 : Value,
                     NotMatch PNil (VCons v1 v2)
    | NM_NilCons   : forall p1 p2 : Pat,
                     NotMatch (PCons p1 p2) VNil
    | NM_ConsConsL : forall (p1 p2 : Pat) (v1 v2 : Value),
                     NotMatch p1 v1 ->
                     NotMatch (PCons p1 p2) (VCons v1 v2)
    | NM_ConsConsR : forall (p1 p2 : Pat) (v1 v2 : Value),
                     NotMatch p2 v2 ->
                     NotMatch (PCons p1 p2) (VCons v1 v2).

(* Binary operations as relations (reused) *)
Inductive Plus : Z -> Z -> Z -> Prop :=
    | B_Plus : forall i1 i2 i3 : Z, i3 = i1 + i2 -> Plus i1 i2 i3.
Inductive Minus : Z -> Z -> Z -> Prop :=
    | B_Minus : forall i1 i2 i3 : Z, i3 = i1 - i2 -> Minus i1 i2 i3.
Inductive Times : Z -> Z -> Z -> Prop :=
    | B_Times : forall i1 i2 i3 : Z, i3 = i1 * i2 -> Times i1 i2 i3.
Inductive Lt : Z -> Z -> bool -> Prop :=
    | B_Lt : forall (i1 i2 : Z) (b3 : bool), b3 = (i1 <? i2) -> Lt i1 i2 b3.

(* Concatination of two environments (not necessarily disjoint) *)
Inductive ConcatTo : Env -> Env -> Env -> Prop :=
    | Con_Empty : forall E : Env, ConcatTo E EEmpty E
    | Con_Bind  : forall (E E1 E2 : Env) (x : Var) (v : Value),
                  ConcatTo E1 E2 E ->
                  ConcatTo E1 (EBind E2 x v) (EBind E x v).

(* Environment lookup (reused) *)
Inductive has_value : Env -> Var -> Value -> Prop :=
    | HV_Bind1 : forall (E : Env) (x : Var) (v : Value),
                 has_value (EBind E x v) x v
    | HV_Bind2 : forall (E : Env) (x y : Var) (v v0 : Value),
                 has_value E x v -> y <> x ->
                 has_value (EBind E y v0) x v.

(* Evaluation rules at p.117 *)
Inductive EvalTo : Env -> Exp -> Value -> Prop :=
    | E_Int     : forall (E : Env) (i : Z),
                  EvalTo E (EInt i) (VInt i)
    | E_Bool    : forall (E : Env) (b : bool),
                  EvalTo E (EBool b) (VBool b)
    | E_Var     : forall (E : Env) (x : Var) (v : Value),
                  has_value E x v ->
                  EvalTo E (EVar x) v
    | E_Plus    : forall (E : Env) (e1 e2 : Exp) (i1 i2 i3 : Z),
                  EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                  Plus i1 i2 i3 ->
                  EvalTo E (EPlus e1 e2) (VInt i3)
    | E_Minus   : forall (E : Env) (e1 e2 : Exp) (i1 i2 i3 : Z),
                  EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                  Minus i1 i2 i3 ->
                  EvalTo E (EMinus e1 e2) (VInt i3)
    | E_Times   : forall (E : Env) (e1 e2 : Exp) (i1 i2 i3 : Z),
                  EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                  Times i1 i2 i3 ->
                  EvalTo E (ETimes e1 e2) (VInt i3)
    | E_Lt      : forall (E : Env) (e1 e2 : Exp) (i1 i2 : Z) (b3 : bool),
                  EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                  Lt i1 i2 b3 ->
                  EvalTo E (ELt e1 e2) (VBool b3)
    | E_IfT     : forall (E : Env) (e1 e2 e3 : Exp) (v : Value),
                  EvalTo E e1 (VBool true) -> EvalTo E e2 v ->
                  EvalTo E (EIf e1 e2 e3) v
    | E_IfF     : forall (E : Env) (e1 e2 e3 : Exp) (v : Value),
                  EvalTo E e1 (VBool false) -> EvalTo E e3 v ->
                  EvalTo E (EIf e1 e2 e3) v
    | E_Let     : forall (E : Env) (e1 e2 : Exp) (x : Var) (v1 v : Value),
                  EvalTo E e1 v1 -> EvalTo (EBind E x v1) e2 v ->
                  EvalTo E (ELet x e1 e2) v
    | E_Fun     : forall (E : Env) (x : Var) (e : Exp),
                  EvalTo E (EFun x e) (VFun E x e)
    | E_App     : forall (E E2 : Env) (e1 e2 e0 : Exp) (x : Var)
                         (v v2 : Value),
                  EvalTo E e1 (VFun E2 x e0) -> EvalTo E e2 v2 ->
                  EvalTo (EBind E2 x v2) e0 v ->
                  EvalTo E (EApp e1 e2) v
    | E_LetRec  : forall (E : Env) (x y : Var) (e1 e2 : Exp) (v : Value),
                  EvalTo (EBind E x (VRecFun E x y e1)) e2 v ->
                  EvalTo E (ELetRec x y e1 e2) v
    | E_AppRec  : forall (E E2 : Env) (e1 e2 e0 : Exp) (x y : Var)
                         (v v2 : Value),
                  EvalTo E e1 (VRecFun E2 x y e0) -> EvalTo E e2 v2 ->
                  EvalTo (EBind (EBind E2 x (VRecFun E2 x y e0)) y v2) e0 v ->
                  EvalTo E (EApp e1 e2) v
    | E_Nil     : forall (E : Env),
                  EvalTo E ENil VNil
    | E_Cons    : forall (E : Env) (e1 e2 : Exp) (v1 v2 : Value),
                  EvalTo E e1 v1 -> EvalTo E e2 v2 ->
                  EvalTo E (ECons e1 e2) (VCons v1 v2)
    | E_MatchM1 : forall (E E1 E2 : Env) (e e0 : Exp) (v v' : Value) (p : Pat),
                  EvalTo E e0 v -> Match p v E1 ->
                  ConcatTo E E1 E2 -> EvalTo E2 e v' ->
                  EvalTo E (EMatch e0 (COne p e)) v'
    | E_MatchM2 : forall (E E1 E2 : Env) (e e0 : Exp) (v v' : Value)
                         (p : Pat) (c : Clauses),
                  EvalTo E e0 v -> Match p v E1 ->
                  ConcatTo E E1 E2 -> EvalTo E2 e v' ->
                  EvalTo E (EMatch e0 (CCons p e c)) v'
    | E_MatchN  : forall (E : Env) (e e0 : Exp) (v v' : Value)
                         (p : Pat) (c : Clauses),
                  EvalTo E e0 v -> NotMatch p v -> EvalTo E (EMatch e0 c) v' ->
                  EvalTo E (EMatch e0 (CCons p e c)) v'.

End GeneralPatternMatching.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Arith.
Require Import Bool.

Local Open Scope nat_scope.

Definition zerob (n:nat) : bool :=
  match n with
    | O => true
    | S _ => false
  end.

Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true.
Proof.
  destruct n; [ trivial with bool | inversion 1 ].
Qed.
Hint Resolve zerob_true_intro: bool.

Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0.
Proof.
  destruct n; [ trivial with bool | inversion 1 ].
Qed.

Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false.
Proof.
  destruct n; [ destruct 1; auto with bool | trivial with bool ].
Qed.
Hint Resolve zerob_false_intro: bool.

Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0.
Proof.
  destruct n; [ inversion 1 | auto with bool ].
Qed.


Add LoadPath "D:\sfsol".
Require Export Imp.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st || st1 ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2.
  Case "E_Skip". reflexivity.
  Case "E_Ass". reflexivity.
  Case "E_Seq".
    assert (st' = st'0) as EQ1.
      SCase "Proof of assertion". apply IHE1_1; assumption.
    subst st'0.
    apply IHE1_2. assumption.
  Case "E_IfTrue".
    SCase "b evaluates to true".
      apply IHE1. assumption.
    SCase "b evaluates to false (contradiction)".
      rewrite H in H5. inversion H5.
  Case "E_IfFalse".
    SCase "b evaluates to true (contradiction)".
      rewrite H in H5. inversion H5.
    SCase "b evaluates to false".
      apply IHE1. assumption.
  Case "E_WhileEnd".
    SCase "b evaluates to false".
      reflexivity.
    SCase "b evaluates to true (contradiction)".
      rewrite H in H2. inversion H2.
  Case "E_WhileLoop".
    SCase "b evaluates to false (contradiction)".
      rewrite H in H4. inversion H4.
    SCase "b evaluates to true".
      assert (st' = st'0) as EQ1.
        SSCase "Proof of assertion". apply IHE1_1; assumption.
      subst st'0.
      apply IHE1_2. assumption. Qed.

Example auto_example_1 : forall (P Q R: Prop), (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_1' : forall (P Q R: Prop), (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  auto.
Qed.

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

Example auto_example_3 : forall (P Q R S T U: Prop),
                           (P -> Q) -> (Q -> R) -> (R -> S) ->
                           (S -> T) -> (T -> U) -> P -> U.
Proof.
  auto.
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof.
  auto. Qed.

Example auto_example_5: 2 = 2.
Proof.
  info_auto.
Qed.

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto.
Qed.

Definition is_fortytwo x := x = 42.

Example auto_example_7: forall x, (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x, (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  info_auto.
Qed.

Hint Constructors ceval.

Definition st12 := update (update empty_state X 1) Y 2.
Definition st21 := update (update empty_state X 2) Y 1.

Example auto_example_8 : exists s',
  (IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI) / st21 || s'.
Proof.
  eexists. info_auto.
Qed.

Example auto_example_8' : exists s',
  (IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI) / st12 || s'.
Proof.
  eexists. info_auto.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; auto.
  Case "E_Seq".
    assert (st' = st'0) as EQ1.
      SCase "Proof of assertion". auto.
    subst st'0.
    auto.
  Case "E_IfTrue".
    SCase "b evaluates to false (contradiction)".
      rewrite H in H5. inversion H5.
  Case "E_IfFalse".
    SCase "b evaluates to true (contradiction)".
      rewrite H in H5. inversion H5.
  Case "E_WhileEnd".
    SCase "b evaluates to true (contradiction)".
      rewrite H in H2. inversion H2.
  Case "E_WhileLoop".
    SCase "b evaluates to false (contradiction)".
      rewrite H in H4. inversion H4.
    SCase "b evaluates to true".
      assert (st' = st'0) as EQ1.
        SSCase "Proof of assertion". auto.
      subst st'0.
      auto. Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; auto.
  Case "E_Seq".
    assert (st' = st'0) as EQ1.
      SCase "Proof of assertion". auto.
    subst st'0.
    auto.
  Case "E_IfTrue".
    SCase "b evaluates to false (contradiction)".
      rwinv H H5.
  Case "E_IfFalse".
    SCase "b evaluates to true (contradiction)".
      rwinv H H5.
  Case "E_WhileEnd".
    SCase "b evaluates to true (contradiction)".
      rwinv H H2.
  Case "E_WhileLoop".
    SCase "b evaluates to false (contradiction)".
      rwinv H H4.
    SCase "b evaluates to true".
      assert (st' = st'0) as EQ1.
        SSCase "Proof of assertion". auto.
      subst st'0.
      auto. Qed.

Ltac find_rwinv :=
  match goal with
    H1: ?E = true, H2: ?E = false |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; try find_rwinv; auto.
  Case "E_Seq".
    assert (st' = st'0) as EQ1.
      SCase "Proof of assertion". auto.
    subst st'0.
    auto.
  Case "E_WhileLoop".
    SCase "b evaluates to true".
      assert (st' = st'0) as EQ1.
        SSCase "Proof of assertion". auto.
      subst st'0.
      auto. Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; try find_rwinv; auto.
  Case "E_Seq".
    rewrite (IHE1_1 st'0 H1) in *. auto.
  Case "E_WhileLoop".
    SCase "b evaluates to true".
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

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

Theorem ceval_deterministic''''': forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  Qed.

Module Repeat.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE"
  | Case_aux c "CRepeat" ].

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileEnd : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''
.

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass"
  | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_RepeatEnd" | Case_aux c "E_RepeatLoop"
].

Notation "c1 '/' st '||' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

Theorem ceval_deterministic: forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  Case "E_RepeatEnd".
    SCase "b evaluates to false (contradiction)".
       find_rwinv.
  case "E_RepeatLoop".
     SCase "b evaluates to true (contradiction)".
        find_rwinv.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  ceval_cases (induction E1) Case;
           intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.


Require Import List.

(** Pruefen, ob zwei Listen gleich sind (die gleichen Elemente haben). *)

Fixpoint eqb_list {A : Type} (eqbA: A -> A -> bool) (l l': list A) : bool :=
  match l with
    | nil  =>
      match l' with
        | nil => true
        | _   => false
      end
    | cons n m  =>
    match l' with
      | nil => false
      | cons n' m' =>andb (eqbA n n') (eqb_list  eqbA m m')
    end
  end.


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

(*
  Problem:
    Linear Polynomial (over N) Constraint Solvability (LPolyNC_SAT)

  A linear polynomial constraint has one of the following shapes
    x ≐ 1
    x ≐ y + z
    x ≐ X * y (where X is the polynomial indeterminate)

  A polynomial is mechanized by a list of its coefficients.

  LPolyNC_SAT:
    Given a list of constraints,
    is there a valuation φ : nat -> list nat such that
    for each constraint c we have
      if c is x ≐ 1, then φ(x) ≃ [1]
      if c is x ≐ y + z, then φ(x) ≃ poly_add (φ(y)) (φ(z))
      if c is x ≐ X * y, then φ(x) ≃ poly_mult [0; 1] (φ(y))
    where ≃ is equality up to trailing zeroes?
*)

Require Import List.
Import ListNotations.

Definition poly : Set := list nat.

(* constraint representation *)
Inductive polyc : Set :=
  | polyc_one : nat -> polyc
  | polyc_sum : nat -> nat -> nat -> polyc
  | polyc_prod : nat -> nat -> polyc.

(* test whether all coefficients are equal, default to 0 *)
Definition poly_eq (p q: poly) : Prop :=
  forall i, nth i p 0 = nth i q 0.

Local Notation "p ≃ q" := (poly_eq p q) (at level 65).

(* polynomial addition *)
Fixpoint poly_add (p q: poly) : poly :=
  match p, q with
  | [], q => q
  | p, [] => p
  | (c :: p), (d :: q) => (c + d) :: poly_add p q
  end.

(* polynomial multiplication *)
Fixpoint poly_mult (p q: poly) : poly :=
  match p with
  | [] => []
  | (c :: p) => poly_add (map (fun a => c * a) q) (0 :: (poly_mult p q))
  end.

Definition polyc_sem (φ: nat -> poly) (c: polyc) :=
  match c with
    | polyc_one x => φ x ≃ [1]
    | polyc_sum x y z => φ x ≃ poly_add (φ y) (φ z)
    | polyc_prod x y => φ x ≃ poly_mult [0; 1] (φ y)
  end.

(* given a list l of constraints,
  is there a valuation φ satisfying each constraint? *)
Definition LPolyNC_SAT (l : list polyc) := exists φ, forall c, In c l -> polyc_sem φ c.


Require Import Bool Arith List CpdtTactics.
Set Implicit Arguments.

Print list.
(*Inductive tuplen (n : nat) : Set :=
 | nil : tuplen n
 | cons : nat -> tuplen (n-1) -> tuplen n.
*)

Inductive tuplen (T: Set) : nat -> Set :=
| tnnil : tuplen T 0
| tncons : T -> forall l, tuplen T l -> tuplen T (S l).

Definition relation_n (T: Set) (r n: nat) : Set :=
  tuplen (tuplen T r) n.

Definition relation (T: Set) (r: nat) : Set :=
  list (tuplen T r).

Print sig.

Definition length_refined_lists (T: Set) (l: list T) (n: nat) : Set :=
  { l | @length T l = n }.

Inductive nattuplen : nat -> Set :=
| ntnnil : nattuplen 0
| ntncons : nat -> forall l, nattuplen l -> nattuplen (S l).

(* TODO length as part of tuple type *)
Inductive tuple : Set :=
  | tnil : tuple
  | tcons : nat -> tuple -> tuple.

Eval simpl in tcons 1 tnil.

Inductive Relation : Set :=
| rnil : Relation
| rcons : tuple -> Relation -> Relation.

Eval simpl in rcons (tcons 1 tnil) rnil.
Eval simpl in rcons (tcons 1 tnil) (rcons (tcons 2 tnil) rnil).

Print bool.

Inductive AttrRef : Set :=
 | Unnamed : nat -> AttrRef.

Inductive NExp : Set :=
 | NConst : nat -> NExp
 | AConst : AttrRef -> NExp.

Inductive nbinop : Set :=
 | Eq.

Inductive bbinop : Set :=
  | And
  | Or.

Inductive Pred : Set :=
  | BConst : bool -> Pred
  | NBinop : nbinop -> NExp -> NExp -> Pred
  | BBinop : bbinop -> Pred -> Pred -> Pred.

Eval simpl in BConst true.
Eval simpl in BConst false.
Eval simpl in BBinop And (BConst true) (BConst true).
Eval simpl in BBinop Or (NBinop Eq (AConst (Unnamed 0)) (NConst 3)) (NBinop Eq (NConst 2) (AConst (Unnamed 4))).

Fixpoint attrLookupHelper (t : tuple) (pos : nat) : option nat :=
 match t with
   | tnil => None
   | tcons attr rem => if (beq_nat pos 0) then (Some attr) else attrLookupHelper rem (pos-1)
end.

Definition attrLookup (t : tuple) (a : AttrRef) : option nat :=
 match a with
     | Unnamed pos => attrLookupHelper t pos
end.

Eval simpl in attrLookup (tcons 10 (tcons 20 tnil)) (Unnamed 1).
Eval simpl in attrLookup tnil (Unnamed 0).
Eval simpl in attrLookup (tcons 10 (tcons 20 (tcons 30 tnil))) (Unnamed 3).

Definition evalNExp (e : NExp) (t : tuple) : option nat :=
  match e with
  | NConst n => Some n
  | AConst aref => attrLookup t aref
end.

(* check it out : http://compcert.inria.fr/doc/html/Compiler.html *)

Fixpoint evalPred (p : Pred) (t : tuple) : option bool :=
  match p with
   | BConst b => Some b
   | NBinop op e1 e2 => let r1 := evalNExp e1 t in
                        match r1 with
                          | None => None
                          | Some n1 =>
                            let r2 := evalNExp e2 t in
                            match r2 with
                             | None => None
                             | Some n2 =>
                              match op with
                                 | Eq => Some (beq_nat n1 n2)
                              end
                           end
                        end
  | BBinop op p1 p2 => let r1 := evalPred p1 t in
                       match r1 with
                         | None => None
                         | Some b1 =>
                            let r2 := evalPred p2 t in
                            match r2 with
                              | None => None
                              | Some b2 =>
                                 match op with
                                   | And => Some (andb b1 b2)
                                   | Or => Some (orb b1 b2)
                                 end
                            end
                     end
   end.

Eval simpl in evalPred (NBinop Eq (NConst 3) (AConst (Unnamed 1))) (tcons 3 (tcons 3 tnil)).

Fixpoint selectHelper (src : Relation) (p : Pred) (res : Relation) : option Relation :=
  match src with
    | rnil => Some res
    | rcons t rem => let pres := evalPred p t in
                       match pres with
                         | None => None
                         | Some b => if b then selectHelper rem p (rcons t res)
                                          else selectHelper rem p res
                       end
 end.

Definition select (r : Relation) (p : Pred) : option Relation :=
 selectHelper r p rnil.

(* non tail recursive version. This might make proofs easier.
Given that loops in IMP will likely
be defined with tail recusion though, it is not clear which style is better *)
Fixpoint select' (r: Relation) (p: Pred) : option Relation :=
  match r with
    | rnil => Some rnil
    | rcons t r' =>
      match select' r' p with
        | None => None
        | Some r'' =>
          match evalPred p t with
            | None => None
            | Some true => Some (rcons t r'')
            | Some false => Some r''
          end
      end
  end.

Check select.

Eval simpl in rcons (tcons 1 (tcons 2 tnil)) (rcons (tcons 1 (tcons 3 tnil)) rnil).

Eval compute in select (rcons (tcons 1 (tcons 2 tnil)) (rcons (tcons 1 (tcons 3 tnil)) rnil)) (NBinop Eq (NConst 1) (AConst (Unnamed 0))).

Eval compute in select (rcons (tcons 1 (tcons 2 tnil)) (rcons (tcons 1 (tcons 3 tnil)) rnil)) (NBinop Eq (NConst 2) (AConst (Unnamed 1))).

Fixpoint rlength (r : Relation) : nat :=
  match r with
   | rnil => 0
   | rcons t rem => 1 + (rlength rem)
end.

Ltac inv H :=
  inversion H; subst; clear H.

Theorem select'_decreasing :
  forall rel pred sel,
  select' rel pred = Some sel ->
  rlength sel <= rlength rel.
Proof.
  induction rel; intros.
  inv H; auto.

  remember H as H'; clear HeqH'.
  simpl in H'.
  destruct (select' rel pred) eqn:?; try discriminate.
  destruct (evalPred pred t) eqn:?; try discriminate.
  destruct b; inv H'; simpl.
  apply le_n_S. eapply IHrel; eauto.
  specialize (IHrel pred sel).
  apply IHrel in Heqo. omega.
Qed.

Theorem select_decreasing :
  forall rel pred sel,
  select rel pred = Some sel ->
  rlength sel <= rlength rel.
Proof.
(*
  induction rel; simpl; intros.
  inversion H; subst. simpl; auto.
  destruct pred; simpl in H.
  destruct b. constructor.
*)

 forall pred rel, let rsel := select rel pred in
     match rsel with
       | None => True
       | Some rsel' => (rlength rsel') <= (rlength rel)
     end.
  induction rel.
  induction pred.
  intros.
  subst rsel.
  simpl.
  reflexivity.

  intros.
  subst rsel.
  simpl.
  reflexivity.

  Restart.
  induction pred.
  admit.
  admit.
  intros.
  subst rsel.
  (* actually need forall over preds *)
  Restart.

  intros.
  subst rsel.
  induction rel.
  induction pred.
  simpl.
  reflexivity.

  simpl.
  reflexivity.

  crush.

  (* here we dont have forall rel so can't unify *)
  apply IHrel.


(** * A correção do algoritmo de ordenação por inserção *)

(** O objetivo deste arquivo é servir de apoio ao desenvolvimento do projeto deste semestre. Aqui apresentaremos todo o processo de formalização do algoritmo de ordenação por inserção, e este processo deve servir como modelo para o desenvolvimento do seu projeto. *)

(* begin hide *)
Require Import Arith List.
(* end hide *)

(** Inicialmente apresentamos a definição do predicado [sorted] que é o mesmo apresentado no projeto, e por isto não nos preocuparemos em explicar aqui esta definição. *)

Inductive sorted :list nat -> Prop :=
  | nil_sorted : sorted nil
  | one_sorted: forall n:nat, sorted (n :: nil)
  | all_sorted : forall (x y: nat) (l:list nat), sorted (y :: l) -> x <= y -> sorted (x :: y :: l).

(** O algoritmo de ordenação por inserção é baseado em na função auxiliar [insert] que definimos a seguir. A função [insert] recebe um natural [x] e uma lista [l] como argumentos, e é definida recursivamente na estrutura de [l]: *)

Fixpoint insert (x:nat) (l: list nat) := match l with
                      | nil => x :: nil
                      | h :: tl => if x <=? h then (x :: l)
                                                  else (h :: (insert x tl))
                      end.

(** Como podemos observar, quando a lista [l] é a lista vazia, a função retorna a lista unitária contendo o elemento que foi inserido. Quando [l] não é a lista vazia, então ela tem a forma [h::tl], isto é, [l] tem [h] como primeiro elemento, e [tl] como cauda. Para saber onde inserir um elemento [x], comparamos [x] com [h], e quando [x] é menor ou igual a [h] simplesmente inserimos [x] na primeira posição da lista. Caso contrário, a função vai recursivamente encontrar a posição correta para inserir [x]. Assim, temos que a função [insert] é construída de forma a preservar a ordenação da lista recebida como segundo argumento. Este é exatamente o conteúdo do lema a seguir: *)

Lemma insert_preserves_sorting: forall l x, sorted l -> sorted (insert x l).
Proof.
  (* A prova deste lema será apresentada em um vídeo, mas você já pode utilizá-lo em provas posteriores. *)
Admitted.

(** A função principal do algoritmo é dada a seguir: *)

Fixpoint insertion_sort l := match l with
                             | nil =>l
                             | h :: tl => insert h (insertion_sort tl)
                             end.

(** A função [insertion_sort] é  definida recursivamente na estrutura da lista [l] que é dada como argumento. Quando a lista é vazia não há nada a fazer, e caso contrário, a função [insert] é chamada para inserir a cabeça [h] da lista na cauda [tl] onde a função é aplicada recursivamente. O lema a seguir pede para você provar que a função [insertion_sort] retorna uma lista ordenada. *)

Lemma insertion_sort_sorts: forall l, sorted (insertion_sort l).
Proof.
Admitted.

(** A seguir apresentamos a definição de permutação a partir da contagem do número de ocorrências dos elementos nas listas, assim como apresentada no projeto mergesort deste semestre, e os lemas a seguir nos permitem concluir que o algoritmo [insertion_sort] é correto. *)

Fixpoint num_oc n l  :=
  match l with
    | nil => 0
    | h :: tl =>
      if n =? h then S(num_oc n tl) else  num_oc n tl
  end.

Definition perm l l' := forall n:nat, num_oc n l = num_oc n l'.

Lemma perm_refl: forall l, perm l l.
Proof.
intro l. unfold perm. intro. reflexivity.
Qed.

Lemma num_oc_insert_neq: forall l n a, n =? a = false -> num_oc n (insert a l) = num_oc n l.
Proof.
Admitted.

Lemma num_oc_insert: forall l n, num_oc n (insert n l) = S (num_oc n l).
Proof.
Admitted.

Lemma ord_insercao_perm: forall l, perm l (insertion_sort l).
Proof.
Admitted.

Theorem correcao_ord_insercao: forall l, sorted (insertion_sort l) /\ perm l (insertion_sort l).
Proof.
Admitted.

(** Extração de código certificado *)

Require Extraction.

Recursive Extraction insertion_sort.
Extraction "insertion_sort.ml" insertion_sort.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (x : lst) (lf1 : natural) : natural :=
  len (append x (Cons lf1 x)).


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/05/08.                                             *)
(* Due: 2021/05/12, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment7.v) on CANVAS.         *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment7.vo" file is generated.         *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import PL.Imp PL.ImpCF PL.RTClosure.
Require Import Coq.Lists.List.
Local Open Scope imp.
Import Abstract_Pretty_Printing.

(* ################################################################# *)
(** * Task 1: Control flow --- denotations *)

(** When we write real programs, we do not write break/continue outside loops.
    We can formalize this property as follows. *)

Fixpoint legal (c: com): Prop :=
  match c with
  | CSkip => True
  | CAss _ _ => True
  | CSeq c1 c2 => legal c1 /\ legal c2
  | CIf _ c1 c2 => legal c1 /\ legal c2
  | CWhile _ _ => True
  | CBreak => False
  | CCont => False
  end.

(** For example, the following sample program 1 is legal but the following
    sample program 2 is not. *)

Definition sample_com_1 (X: var): com :=
  CSeq
    (CAss X 10)
    (CWhile
       (BTrue)
       (CSeq
          (CAss X (X - 1))
          (CIf (0 <= X) CSkip CBreak))).

Definition sample_com_2 (X: var): com :=
  CSeq
    (CAss X 10)
    (CSeq
      (CWhile
        (0 <= X)
        (CAss X (X - 1)))
      CCont).

(** **** Exercise: 1 star, standard *)
Fact sample_com_1_legal: forall X, legal (sample_com_1 X).
Proof.
  intros.
  simpl.
  tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard *)
Fact sample_com_2_legal: forall X, ~ legal (sample_com_2 X).
Proof.
  intros.
  simpl.
  tauto.
Qed.
(** [] *)

(** This definition of [legal] is syntactic. We can also define its semantic
    counterpart using denotational semantics. *)

Definition sem_legal (c: com): Prop :=
  BinRel.equiv (BreakExit (ceval c)) (BinRel.empty) /\
  BinRel.equiv (ContExit (ceval c)) (BinRel.empty).

(** Now, your task is to prove that: if a program is syntactically [legal] then
    it must be semantically legal, i.e. it satisfies [sem_legal]. Here,
    [BinRel_concat_empty] are auxiliary lemmas for proving [legal_sem_legal]. *)

(** **** Exercise: 2 stars, standard (BinRel_concat_empty) *)
Lemma BinRel_concat_empty: forall {A B C} (R: A -> B -> Prop),
  BinRel.equiv (BinRel.concat R (@BinRel.empty B C)) BinRel.empty.
Proof.
  intros.
  unfold BinRel.equiv, BinRel.concat, BinRel.empty.
  intros; split; intros.
  + destruct H as [? [? ?]].
    exact H0.
  + contradiction.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (BinRel_union_empty) *)
Lemma BinRel_union_empty: forall {A B} (R: A -> B -> Prop),
  BinRel.equiv (BinRel.union R BinRel.empty) R.
Proof.
  intros.
  unfold BinRel.equiv, BinRel.union, BinRel.empty.
  intros; split; intros.
  + destruct H.
    - exact H.
    - contradiction.
  + left.
    exact H.
Qed.
(** [] *)

(** Hint: remember that [rewrite] can be used for [BinRel.equiv] and may
    significantly simplify your proof for [legal_sem_legal]. *)

(** **** Exercise: 3 stars, standard (legal_sem_legal) *)
Lemma legal_sem_legal: forall c,
  legal c -> sem_legal c.
Proof.
  intros.
  induction c; unfold sem_legal; simpl.
  + split; reflexivity.
  + split; reflexivity.
  + destruct H.
    specialize (IHc1 H).
    specialize (IHc2 H0).
    clear H H0.
    unfold sem_legal in IHc1, IHc2.
    destruct IHc1, IHc2.
    rewrite H, H0, H1, H2.
    split;
    rewrite BinRel_concat_empty, BinRel_union_empty;
    reflexivity.
  + destruct H.
    specialize (IHc1 H).
    specialize (IHc2 H0).
    clear H H0.
    unfold sem_legal in IHc1, IHc2.
    destruct IHc1, IHc2.
    rewrite H, H0, H1, H2.
    unfold BinRel.test_rel, Sets.complement.
    split;
    rewrite BinRel_concat_empty, BinRel_concat_empty, BinRel_union_empty;
    reflexivity.
  + split; reflexivity.
  + destruct H.
  + destruct H.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard *)

(** Is it true that every semantically legal command is also syntactically
    legal? 1. Yes. 2. No. *)

Definition my_choice: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(* ################################################################# *)
(** * Task 2: Control flow --- steps *)

(** We learnt two small step semantics for programs with break/continue. We
    investigate an alternative definition of control-stack-based semantics. *)

Module S0.

(** We first define stack-irrelevant step relation: [si_cstep]. *)

Inductive si_cstep: (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st X a a',
      astep st a a' ->
      si_cstep (CAss X a, st) (CAss X a', st)
  | CS_Ass : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      si_cstep (CAss X (ANum n), st1) (CSkip, st2)
  | CS_SeqStep : forall st c1 c1' st' c2,
      si_cstep (c1, st) (c1', st') ->
      si_cstep (CSeq c1 c2 , st) (CSeq c1' c2, st')
  | CS_Seq : forall st c2,
      si_cstep (CSeq CSkip c2, st) (c2, st)
  | CS_IfStep : forall st b b' c1 c2,
      bstep st b b' ->
      si_cstep
        (CIf b c1 c2, st)
        (CIf b' c1 c2, st)
  | CS_IfTrue : forall st c1 c2,
      si_cstep (CIf BTrue c1 c2, st) (c1, st)
  | CS_IfFalse : forall st c1 c2,
      si_cstep (CIf BFalse c1 c2, st) (c2, st).

(** We then define a new [cstep]. A step is either a stack-irrelevant step, or
    some stack related step. *)

Inductive cstep : (com * cstack * state) -> (com * cstack * state) -> Prop :=
  | CS_SIStep : forall s st c st' c',   (* <--- stack-irrelevant step *)
      si_cstep (c, st) (c', st') ->
      cstep (c, s, st) (c', s, st')
  | CS_While : forall st s c b c1 c2,   (* <--- enter a loop *)
      start_with_loop c b c1 c2 ->
      cstep
        (c, s, st)
        (CIf b c1 CBreak, (b, c1, c2) :: s, st)
  | CS_Skip : forall st s b c1 c2,      (* <--- end of loop body *)
      cstep
        (CSkip, (b, c1, c2) :: s, st)
        (CIf b c1 CBreak, (b, c1, c2) :: s, st)
  | CS_Break : forall st s b c1 c2 c,   (* <--- break *)
      start_with_break c ->
      cstep
        (c, (b, c1, c2) :: s, st)
        (c2, s, st)
  | CS_Cont : forall st s b c1 c2 c,    (* <--- continue *)
      start_with_cont c ->
      cstep
        (c, (b, c1, c2) :: s, st)
        (CIf b c1 CBreak, (b, c1, c2) :: s, st)
.

End S0.

(** This task is to prove that our new small step semantics is the same as the
    original one. You only need to prove one direction. Hint: you can use
    [induction_cstep] to apply induction proof on [S0.si_cstep] or [S0.cstep]. *)

(** **** Exercise: 2 stars, standard (si_cstep_cstep) *)
Lemma si_cstep_cstep: forall s c st c' st',
  S0.si_cstep (c, st) (c', st') ->
  cstep (c, s, st) (c', s, st').
Proof.
  intros.
  induction_cstep H;
  constructor;
  try tauto.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (S0_cstep_cstep) *)
Lemma S0_cstep_cstep: forall c s st c' s' st',
  S0.cstep (c, s, st) (c', s', st') ->
  cstep (c, s, st) (c', s', st').
Proof.
  intros.
  induction_cstep H;
  [ apply si_cstep_cstep | constructor.. ];
  try tauto.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 3: Control flow --- Hoare logic *)

Module Task3.

(** In this task, we also consider the programming language in our lecture about
    control flows. In other words, there is no run time error. *)

(** **** Exercise: 1 star, standard *)

(** Can we prove the following Hoare triple, using the Hoare logic for control
    flow programs? Suppose the logic for assertion derivation is sound and
    complete. 1. Yes. 2. No.

       {{ {[ X ]} = n }}
          X ::= X - 1
       {{ {[ X ]} = n - 1 }}
       {{ False }}
       {{ {[ X ]} = n - 1 }}
*)

Definition my_choice1: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement true? Suppose [c] is an arbitrary program with
    possibly control flow commands involved and [b] is a boolean expression.
    [
       {{ P }}
          If b Then (c ;; While b Do c EndWhile) Else Skip EndIf
       {{ Q }}
       {{ QB }}
       {{ QC }}
    ]
    if and only if
    [
       {{ P }}
          While b Do c EndWhile
       {{ Q }}
       {{ QB }}
       {{ QC }}
    ].

    1. Yes. 2. No.
*)

Definition my_choice2: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement true? Suppose [c] is an arbitrary program with
    possibly control flow commands involved and [b] is a boolean expression.
    [
       {{ P }}
          While b Do c EndWhile
       {{ Q }}
       {{ QB }}
       {{ QC }}
    ]
    if and only if
    [
       {{ P }}
          While b Do c EndWhile
       {{ Q }}
       {{ False }}
       {{ False }}
    ]

    1. Yes. 2. No.
*)

Definition my_choice3: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task3.

(* ################################################################# *)
(** * Task 4: Control flow --- loops *)

Module Task4.

(** In this task, we also consider the programming language in our lecture about
    control flows. In other words, there is no run time error. *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement true? If [c] is an arbitrary program with
    possibly control flow commands involved and [b] is a boolean expression,
    then the components in
    [[
       ceval (While b Do c EndWhile)
    ]]
    are equivalent to corresponding components in
    [[
       ceval (While (0 == 0) Do If b Then c Else Break EndIf EndWhile).
    ]]

    1. Yes. 2. No.
*)

Definition my_choice1: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement true? Suppose [c] is an arbitrary program with
    possibly control flow commands involved and [b] is a boolean expression.
    For any [st], [c'], [s'], [st'],
    [[
       clos_refl_trans cstep
         (While b Do c EndWhile, nil, st)
         (c', s', st')
    ]]
    if and only if
    [[
       clos_refl_trans cstep
         (While (0 == 0) Do If b Then c Else Break EndIf EndWhile, nil, st)
         (c', s', st')
    ]]
    Here, we use the small step semantics with control stack.

    1. Yes. 2. No.
*)

Definition my_choice2: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task4.

(* ################################################################# *)
(** * Task 5: Diamond operator *)

Module Task5.

Local Open Scope Z.

(** Consider the following sample relations and sample sets. Please point out
    the results of [BinRel.dia]. *)

Definition relation_sample_1: Z -> Z -> Prop :=
  fun n m => n + 1 = m.

Definition relation_sample_2: Z -> Z -> Prop :=
  fun n m => n + 1 = m \/ n + 2 = m.

Definition set_sample_1: Z -> Prop :=
  fun n => exists m, n = m * 2.

Definition set_sample_2: Z -> Prop :=
  fun n => exists m, n = m * 3.

(** **** Exercise: 1 star, standard *)

(** Question 1: which of the following sets equals to

      [[  BinRel.dia relation_sample_1 set_sample_1?  ]]

    1. All even numbers.
    2. All odd numbers.
    3. All integers. *)

Definition my_choice1: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Question 2: which of the following sets equals to

      [[  BinRel.dia relation_sample_2 set_sample_1?  ]]

    1. All even numbers.
    2. All odd numbers.
    3. All integers. *)

Definition my_choice2: Z := 3.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Question 3: which of the following sets equals to

      [[  BinRel.dia relation_sample_2 set_sample_2?  ]]

    1. All integers in [set_sample_2].
    2. All integers outside [set_sample_2].
    3. All integers. *)

Definition my_choice3: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task5.

(* ################################################################# *)
(** * Task 6: Integer expressions with division *)

Module Task6.

(** Consider expression evaluation when divisions are involved. *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement correct?

    - When [st (X) = 1], evaluating [X / (X - 1)] on [st] ends in an error.

    1. Yes. 2. No. *)

Definition my_choice1: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement correct?

    - When [st (X) = 1] and [st (Y) = -1], evaluating [(X + Y) / (X - 1)] on
      [st] ends in an error.

    1. Yes. 2. No. *)

Definition my_choice2: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement correct?

    - When [st (X) = 1], evaluating [ (! (X == 0)) && (X / (X - 1) <= 10) ] on
      [st] ends in an error.

    1. Yes. 2. No. *)

Definition my_choice3: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Is the following statement correct?

    - When [st (X) = 1], evaluating [(2 <= X) && (X / (X - 1) <= 10) ] on [st]
      ends in an error.

    1. Yes. 2. No. *)

Definition my_choice4: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task6.

(* 2021-05-08 18:58 *)


Require Import Classical.

Theorem pierce (A B : Prop): ((A -> B) -> A) -> A.
Proof.
  intro.
  destruct (classic A).
  + exact H0.
  + apply H.
    intro.
    contradiction.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Pow2.
Require Import Crypto.Util.ZUtil.Log2.
Require Import Crypto.Util.ZUtil.Lnot.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.ZSimplify.Simple.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.UniquePose.
Local Open Scope bool_scope. Local Open Scope Z_scope.

Module Z.
  Lemma ones_le x y : x <= y -> Z.ones x <= Z.ones y.
  Proof.
    rewrite !Z.ones_equiv; auto with zarith.
  Qed.
  Hint Resolve ones_le : zarith.

  Lemma ones_lt_pow2 x y : 0 <= x <= y -> Z.ones x < 2^y.
  Proof.
    rewrite Z.ones_equiv, Z.lt_pred_le.
    auto with zarith.
  Qed.
  Hint Resolve ones_lt_pow2 : zarith.

  Lemma log2_ones_full x : Z.log2 (Z.ones x) = Z.max 0 (Z.pred x).
  Proof.
    rewrite Z.ones_equiv, Z.log2_pred_pow2_full; reflexivity.
  Qed.
  Hint Rewrite log2_ones_full : zsimplify.

  Lemma log2_ones_lt x y : 0 < x <= y -> Z.log2 (Z.ones x) < y.
  Proof.
    rewrite log2_ones_full; apply Z.max_case_strong; lia.
  Qed.
  Hint Resolve log2_ones_lt : zarith.

  Lemma log2_ones_le x y : 0 <= x <= y -> Z.log2 (Z.ones x) <= y.
  Proof.
    rewrite log2_ones_full; apply Z.max_case_strong; lia.
  Qed.
  Hint Resolve log2_ones_le : zarith.

  Lemma log2_ones_lt_nonneg x y : 0 < y -> x <= y -> Z.log2 (Z.ones x) < y.
  Proof.
    rewrite log2_ones_full; apply Z.max_case_strong; lia.
  Qed.
  Hint Resolve log2_ones_lt_nonneg : zarith.

  Lemma ones_pred : forall i, 0 < i -> Z.ones (Z.pred i) = Z.shiftr (Z.ones i) 1.
  Proof.
    induction i as [|p|p]; [ | | pose proof (Pos2Z.neg_is_neg p) ]; try lia.
    intros.
    unfold Z.ones.
    rewrite !Z.shiftl_1_l, Z.shiftr_div_pow2, <-!Z.sub_1_r, Z.pow_1_r, <-!Z.add_opp_r by lia.
    replace (2 ^ (Z.pos p)) with (2 ^ (Z.pos p - 1)* 2).
    rewrite Z.div_add_l by lia.
    reflexivity.
    change 2 with (2 ^ 1) at 2.
    rewrite <-Z.pow_add_r by (pose proof (Pos2Z.is_pos p); lia).
    f_equal. lia.
  Qed.
  Hint Rewrite <- ones_pred using zutil_arith : push_Zshift.

  Lemma ones_succ : forall x, (0 <= x) ->
    Z.ones (Z.succ x) = 2 ^ x + Z.ones x.
  Proof.
    unfold Z.ones; intros.
    rewrite !Z.shiftl_1_l.
    rewrite Z.add_pred_r.
    apply Z.succ_inj.
    rewrite !Z.succ_pred.
    rewrite Z.pow_succ_r; lia.
  Qed.

  Lemma ones_nonneg : forall i, (0 <= i) -> 0 <= Z.ones i.
  Proof.
    apply natlike_ind.
    + unfold Z.ones. simpl; lia.
    + intros.
      rewrite Z.ones_succ by assumption.
      Z.zero_bounds.
  Qed.
  Hint Resolve ones_nonneg : zarith.

  Lemma ones_bound m (Hm : 0 <= m) :
    0 <= Z.ones m < 2 ^ m.
  Proof. split. apply ones_nonneg; lia. rewrite Z.ones_equiv; lia. Qed.

  Lemma ones_pos_pos : forall i, (0 < i) -> 0 < Z.ones i.
  Proof.
    intros.
    unfold Z.ones.
    rewrite Z.shiftl_1_l.
    apply Z.lt_succ_lt_pred.
    apply Z.pow_gt_1; lia.
  Qed.
  Hint Resolve ones_pos_pos : zarith.

  Lemma lnot_ones_equiv n : Z.lnot (Z.ones n) = -2^n.
  Proof. rewrite Z.ones_equiv, Z.lnot_equiv, <- ?Z.sub_1_r; lia. Qed.

  Lemma land_ones_ones n m
    : Z.land (Z.ones n) (Z.ones m)
      = Z.ones (if ((n <? 0) || (m <? 0))
                then Z.max n m
                else Z.min n m).
  Proof.
    repeat first [ reflexivity
                 | break_innermost_match_step
                 | progress rewrite ?Bool.orb_true_iff in *
                 | progress rewrite ?Bool.orb_false_iff in *
                 | progress rewrite ?Z.ltb_lt, ?Z.ltb_ge in *
                 | progress destruct_head'_and
                 | apply Z.min_case_strong
                 | apply Z.max_case_strong
                 | progress intros
                 | progress destruct_head'_or
                 | rewrite !Z.pow_r_Zneg
                 | rewrite !Z.land_m1_l
                 | rewrite !Z.land_m1_r
                 | progress change (Z.pred 0) with (-1)
                 | rewrite Z.mod_small by lia
                 | match goal with
                   | [ H : ?x < 0 |- _ ] => is_var x; destruct x; try lia
                   | [ H : ?x <= Z.neg _ |- _ ] => is_var x; destruct x; try lia
                   | [ |- context[Z.ones (Z.neg ?x)] ] => rewrite (Z.ones_equiv (Z.neg x))
                   | [ H : ?n <= ?m |- Z.land (Z.ones ?m) (Z.ones ?n) = _ ]
                     => rewrite (Z.land_comm (Z.ones m) (Z.ones n))
                   | [ H : ?n <= ?m |- Z.land (Z.ones ?n) (Z.ones ?m) = _ ]
                     => progress rewrite ?Z.land_ones, ?Z.ones_equiv, <- ?Z.sub_1_r by auto
                   | [ H : ?n <= ?m |- _ ]
                     => is_var n; is_var m; unique pose proof (Z.pow_le_mono_r 2 n m ltac:(lia) H)
                   | [ |- context[2^?x] ] => unique pose proof (Z.pow2_gt_0 x ltac:(lia))
                   end ].
  Qed.
  Hint Rewrite land_ones_ones : zsimplify.

  Lemma lor_ones_ones n m
    : Z.lor (Z.ones n) (Z.ones m)
      = Z.ones (if ((n <? 0) || (m <? 0))
                then Z.min n m
                else Z.max n m).
  Proof.
    destruct (Z_zerop n), (Z_zerop m); subst;
      repeat first [ reflexivity
                   | break_innermost_match_step
                   | progress rewrite ?Bool.orb_true_iff in *
                   | progress rewrite ?Bool.orb_false_iff in *
                   | progress rewrite ?Z.ltb_lt, ?Z.ltb_ge in *
                   | progress destruct_head'_and
                   | apply Z.min_case_strong
                   | apply Z.max_case_strong
                   | progress intros
                   | progress destruct_head'_or
                   | rewrite !Z.pow_r_Zneg
                   | rewrite !Z.lor_m1_l
                   | rewrite !Z.lor_m1_r
                   | progress change (Z.pred 0) with (-1)
                   | rewrite Z.mod_small by lia
                   | lia
                   | match goal with
                     | [ H : ?x < 0 |- _ ] => is_var x; destruct x; try lia
                     | [ H : ?x <= Z.neg _ |- _ ] => is_var x; destruct x; try lia
                     | [ |- context[Z.ones (Z.neg ?x)] ] => rewrite (Z.ones_equiv (Z.neg x))
                     | [ H : ?n <= ?m |- Z.lor (Z.ones ?m) (Z.ones ?n) = _ ]
                       => rewrite (Z.lor_comm (Z.ones m) (Z.ones n))
                     | [ H : ?n <= ?m |- Z.lor (Z.ones ?n) (Z.ones ?m) = _ ]
                       => progress rewrite ?Z.lor_ones_low; try apply Z.log2_ones_lt_nonneg; rewrite ?Z.ones_equiv, <- ?Z.sub_1_r
                     | [ H : ?n <= ?m |- _ ]
                       => is_var n; is_var m; unique pose proof (Z.pow_le_mono_r 2 n m ltac:(lia) H)
                     | [ |- context[2^?x] ] => unique pose proof (Z.pow2_gt_0 x ltac:(lia))
                     end ].
  Qed.
  Hint Rewrite lor_ones_ones : zsimplify.

  Lemma lor_pow2_mod_pow2_r x e (He : 0 <= e) : Z.lor x (2^e-1) mod (2^e) = 2^e-1.
  Proof.
    destruct (Z_zerop e).
    { subst; autorewrite with zsimplify_const; reflexivity. }
    assert (0 <= x mod 2^e < 2^e) by auto with zarith.
    assert (0 <= x mod 2^e <= 2^e-1) by lia.
    assert (Z.log2 (x mod 2^e) <= Z.log2 (2^e-1)) by (apply Z.log2_le_mono; lia).
    assert (Z.log2 (x mod 2^e) < e) by (rewrite Z.sub_1_r, Z.log2_pred_pow2 in * by lia; lia).
    rewrite <- Z.land_ones, Z.land_lor_distr_l by assumption.
    rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones_ones, Z.min_id, Z.max_id, Bool.if_const.
    rewrite Z.land_ones by assumption.
    rewrite Z.lor_ones_low; auto with zarith.
  Qed.
  Hint Rewrite lor_pow2_mod_pow2_r using zutil_arith : zsimplify.
  Hint Rewrite lor_pow2_mod_pow2_r using assumption : zsimplify_fast.

  Lemma lor_pow2_mod_pow2_l x e (He : 0 <= e) : Z.lor (2^e-1) x mod (2^e) = 2^e-1.
  Proof. rewrite Z.lor_comm; apply lor_pow2_mod_pow2_r; assumption. Qed.
  Hint Rewrite lor_pow2_mod_pow2_l using zutil_arith : zsimplify.
  Hint Rewrite lor_pow2_mod_pow2_l using assumption : zsimplify_fast.

  Lemma lor_pow2_div_pow2_r x e (He : 0 <= e) : (Z.lor x (2^e-1)) / (2^e) = x / 2^e.
  Proof.
    destruct (Z_zerop e).
    { subst; autorewrite with zsimplify_const; reflexivity. }
    assert (0 < 2^e) by auto with zarith.
    rewrite <- Z.shiftr_div_pow2, Z.shiftr_lor, !Z.shiftr_div_pow2 by lia.
    rewrite (Z.div_small (_-1) _), Z.lor_0_r by lia.
    reflexivity.
  Qed.
  Hint Rewrite lor_pow2_div_pow2_r using zutil_arith : zsimplify.
  Hint Rewrite lor_pow2_div_pow2_r using assumption : zsimplify_fast.

  Lemma lor_pow2_div_pow2_l x e (He : 0 <= e) : (Z.lor (2^e-1) x) / (2^e) = x / 2^e.
  Proof. rewrite Z.lor_comm; apply lor_pow2_div_pow2_r; assumption. Qed.
  Hint Rewrite lor_pow2_div_pow2_l using zutil_arith : zsimplify.
  Hint Rewrite lor_pow2_div_pow2_l using assumption : zsimplify_fast.
End Z.


Require Import Iron.Language.SystemF.Step.
Require Import Iron.Language.SystemF.SubstExpExp.
Require Import Iron.Language.SystemF.SubstTypeExp.
Require Import Iron.Language.SystemF.SubstTypeType.
Require Import Iron.Language.SystemF.TyJudge.

(* A well typed expression is either a value, or can take a step. *)
Theorem progress
 :  forall x
 ,  (exists t, TYPE nil nil x t)
 -> value x \/ (exists x', STEP x x').
Proof.
 intros.
 induction x; destruct H as [tx].

 Case "XVar".
  inverts H. false.

 Case "XLAM".
  left. apply type_wfX in H. auto.

 Case "XAPP".
  inverts H.
  destruct IHx. eauto.
  SCase "x value".
   right. inverts H. inverts H4.
    inverts H1. false.
    inverts H0.
    exists (substTX 0 t x1). eapply ESLAMAPP.
    inverts H0.
  SCase "x steps".
   right.
    destruct H as [x'].
    exists (XAPP x' t).
    apply ESAPP1. auto.

 Case "XLam".
  left. apply type_wfX in H. auto.

 Case "XApp".
  right.
  inverts H.
  destruct IHx1; eauto.
  SCase "x1 value".
   destruct IHx2; eauto.
   inverts H.

   SSCase "x2 value".
    inverts H1.
     inverts H2. false.
     inverts H4.
     exists (substXX 0 x2 x0). apply ESLamApp. auto.

   SSCase "x2 steps".
    destruct H0 as [x2'].
    exists (XApp x1 x2').
    apply ESApp2; auto.

  SCase "x1 steps".
   destruct H as [x1'].
   exists (XApp x1' x2).
   apply ESApp1; auto.
Qed.