Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat seq choice fintype.
From mathcomp
Require Import div path bigop prime finset fingroup.

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

(** tentative formalization of the theorem V.3.1 of
    [Arnaudies&Fraysse]
    Arnaudies, J.M., Fraysse, H.: Cours de mathematiques 1, Algebre, Dunod Universite, 1987

    to illustrate the Mathematiques Components library
*)

(** Sect. 2: Basics of Coq *)

Lemma andC :
  forall P Q : Prop, P /\ Q -> Q /\ P.
Proof.
move=> P Q.
by case.
Show Proof.
(*exact (fun P Q PandQ => match PandQ with
  conj p q => conj q p end).*)
Qed.

Lemma andbC :
  forall P Q : bool, andb P Q = true -> andb Q P = true.
Proof.
case.
- by case.
- by case.
(*exact (fun P Q => match P with
| true => match Q with
          | true => id
          | false => id
          end
| false => match Q with
          | true => id
          | false => id
          end
      end).*)
Qed.

(** Sect. 5: Overview of Finite Groups *)

Local Open Scope group_scope.

Module Sect5.
Section sect5.

Variable gT : finGroupType.
Variables G : {group gT}.
Variables g h : gT.
Hypotheses (gG : g \in G) (hG : h \in G).
Check g * h : gT.
Check groupM gG hG : g * h \in G.

End sect5.
End Sect5.

Section coset_bijection.

Variable gT : finGroupType.
Variables G H : {group gT}.
Hypothesis HG : H \subset G.

(** Sect. 6: Left-cosets are disjoint *)

Lemma coset_disjoint L0 L1 :
  L0 \in lcosets H G ->
  L1 \in lcosets H G ->
  L0 :&: L1 != set0 -> L0 = L1.
Proof.
case/lcosetsP => g0 g0G ->{L0}.
case/lcosetsP => g1 g1G ->{L1}.
move=> g0_g1_disj.
apply/lcoset_eqP.
case/set0Pn : g0_g1_disj => /= g.
rewrite in_setI => /andP[].
rewrite 3!mem_lcoset => g_g0 g_g1.
rewrite -(mul1g g0).
rewrite -(mulgV g).
rewrite 2!mulgA.
rewrite -mulgA.
rewrite groupM //.
rewrite groupVl //.
rewrite invMg.
by rewrite invgK.
Qed.

(** Sect. 7: Injection into the set of left-cosets *)

Definition reprs := repr @: lcosets H G.

Lemma mem_repr_coset x : x \in G -> repr (x *: H) \in G.
Proof.
move=> xG.
rewrite /repr.
case: ifPn => // x1.
case: pickP => /=.
  move=> g0.
  case/lcosetP => g1 g1H ->.
  rewrite groupM //.
  by move/subsetP : (HG); apply.
move/(_ x).
by rewrite lcoset_refl.
Qed.

Lemma repr_form x : x \in G -> repr (x *: H) *: H = x *: H.
Proof.
move=> xG.
apply coset_disjoint.
- apply/lcosetsP.
  exists (repr (x *: H)) => //.
  by apply mem_repr_coset.
- apply/lcosetsP.
  by exists x.
- apply/set0Pn => /=.
  exists (repr (x *: H)) => //.
  rewrite in_setI.
  rewrite lcoset_refl /=.
  rewrite (mem_repr x) //.
  by rewrite lcoset_refl.
Qed.

Lemma reprs_subset : reprs \subset G.
Proof.
apply/subsetP => g.
case/imsetP => /= gs.
case/lcosetsP => g' g'H ->{gs} ->{g}.
by rewrite mem_repr_coset.
Qed.

Lemma injective_coset :
  {in reprs &, injective (fun g => g *: H)}.
Proof.
move=> /= g g' /imsetP[] /= L LHG gL.
move=> /imsetP[] /= K KHG g'K abs.
suff : L = K.
  move=> LK.
  rewrite LK in gL.
  by rewrite gL g'K.
case/lcosetsP : LHG => g0 g0G g0L.
rewrite {}g0L {L} in gL *.
case/lcosetsP : KHG => g1 g1G g1K.
rewrite {}g1K {K} in g'K *.
have <- : g *: H = g0 *: H.
  apply coset_disjoint.
  - apply/lcosetsP.
    exists g => //.
    by rewrite gL mem_repr_coset.
  - apply/lcosetsP.
    by exists g0.
  - apply/set0Pn.
    exists (repr (g0 *: H)).
    by rewrite !inE -gL lcoset_refl /= gL (mem_repr g0) // lcoset_refl.
suff : g' *: H = g1 *: H.
  by move=> <-.
apply coset_disjoint => //.
- apply/lcosetsP.
  exists g' => //.
  by rewrite g'K mem_repr_coset.
- apply/lcosetsP.
  by exists g1.
- apply/set0Pn.
  exists (repr (g1 *: H)).
  by rewrite inE -g'K lcoset_refl /= g'K (mem_repr g1) // lcoset_refl.
Qed.

Lemma surjective_coset : (fun x => x *: H) @: reprs = lcosets H G.
Proof.
apply/eqP.
rewrite eqEsubset.
apply/andP; split.
- apply/subsetP => i.
  case/imsetP => g.
  case/imsetP => L HL ->{g} ->{i}.
  apply/lcosetsP.
  exists (repr L) => //.
  case/lcosetsP : HL => x xG ->.
  by apply mem_repr_coset.
- apply/subsetP => i.
  case/lcosetsP => x xG ->{i}.
  apply/imsetP.
  exists (repr (x *: H)).
    rewrite /reprs.
    apply/imsetP.
    exists (x *: H) => //.
    apply/lcosetsP.
    by exists x.
  by rewrite repr_form.
Qed.

End coset_bijection.

(** Sect. 8: Transitivity of the group index *)

Notation "#| G : H |" := #| lcosets H G |.

Section index.

Variable gT : finGroupType.
Variables G H K : {group gT}.
Hypotheses (HG : H \subset G) (KG : K \subset G) (HK : K \proper H).

Lemma index_trans : #| G : K | = (#| G : H | * #| H : K |)%nat.
Proof.
rewrite /=.
set calG := reprs G H.
have calG_H_inj : {in calG &, injective (fun x => x *: H)}.
  by apply: injective_coset HG.
set calH := reprs H K.
have calH_K_inj : {in calH &, injective (fun x=> x *: K)}.
  apply: injective_coset.
  by move/proper_sub : HK.
pose phi := fun gh : gT * gT => let: (g, h) := gh in (g * h) *: K.
(* [Arnaudies&Fraysse] injectivite de phi:
   Si ghK = g'h'K avec g, g' \in calG et h, h' \in calH,
   on en deduit g'^-1ghK = h'K \proper H.
   Donc g'^-1gH \cap H n'est pas vide puisque h'K \proper H
   et h'K \proper g'^-1gH, et puisque g'^-1gH et H sont deux classes
   a gauche mod (H), necessairement g'^-1gH = H, d'ou gH = g'H,
   d'ou g = g' puisque alpha est bijective.
   On en deduit: hK = h'K, d'ou h = h' puisque beta est bijective,
   et finalement (g,h)=(g'.h'). *)
have phi_injective : {in setX calG calH & , injective phi}.
  case => g h.
  rewrite inE /=.
  case => g' h' /andP[gG hH].
  rewrite /phi inE /= => /andP[g'G h'H] ghK.
  have step1 : (g'^-1 * g * h) *: K = h' *: K.
    move: ghK.
    move/(congr1 (fun X => g'^-1 *: X)).
    by rewrite -2!lcosetM !mulgA mulVg mul1g.
  have step2 : h' *: K \proper H.
    apply/properP; split.
      apply/subsetP => x.
      case/lcosetP => x0 Hx0 ->.
      rewrite groupM //.
        by move/proper_sub : (HK) => /reprs_subset /subsetP; apply.
      move/proper_sub : HK => /subsetP; by apply.
    case/properP : HK => HK' [x xH xK].
    exists (h' * x) => //.
    rewrite groupM //.
      by move/proper_sub : (HK) => /reprs_subset /subsetP; apply.
    apply: contra xK.
    case/lcosetP => x0 x0K.
    by move/mulgI => ->.
  have {step2}step3 : (g'^-1 * g *: H) :&: H != set0.
    have step3 : h' *: K \proper (g'^-1 * g) *: H.
      rewrite -step1.
      apply/properP; split.
        rewrite sub_lcoset -lcosetM mulgA mulVg mul1g.
        apply/subsetP => x.
        case/lcosetP => x0 x0K ->.
        rewrite groupM //.
          by move/proper_sub : (HK) => /reprs_subset /subsetP; apply.
        by move/proper_sub : HK => /subsetP; apply.
      case/properP : HK => HK' [x xH xK].
      exists ((g'^-1 * g) * (h * x)) => //.
        rewrite mem_lcoset mulgA mulVg mul1g groupM //.
        by move/proper_sub : (HK) => /reprs_subset /subsetP; apply.
      rewrite mem_lcoset -(mulgA g'^-1 g (h * x)) (mulgA g h x).
      by rewrite (mulgA g'^-1 (g * h) x) (mulgA g'^-1 g h) mulgA mulVg mul1g.
    apply/set0Pn; exists h'.
    rewrite in_setI.
    apply/andP; split.
      move/proper_sub/subsetP : step3; apply.
      by rewrite mem_lcoset mulVg group1.
    move/proper_sub/subsetP : step2; apply.
    by rewrite mem_lcoset mulVg group1.
  have {step3}step4 : (g'^-1 * g) *: H = H.
    case/set0Pn : step3 => x.
    rewrite in_setI.
    case/andP.
    case/lcosetP => x0 Hx0 -> Htmp.
    rewrite lcoset_id //.
    by rewrite -(mulg1 g) -(mulgV x0) !mulgA groupM // groupVl // invgK.
  have {step4}step5 : g *: H = g' *: H.
    by rewrite -{2}step4 -lcosetM mulgA mulgV mul1g.
  have {step5}step6 : g = g'.
    by apply calG_H_inj.
  have step7 : h *: K = h' *: K.
    by rewrite -step1 step6 mulVg mul1g.
  have {step7}step8 : h = h'.
    by apply calH_K_inj.
  by rewrite step6 step8.
have calG_H_surj : (fun x => x *: H) @: calG = lcosets H G.
  by apply surjective_coset.
have calH_K_surj : (fun x => x *: K) @: calH = lcosets K H.
  apply surjective_coset.
  by move/proper_sub : (HK); apply.
(* [Arnaudies&Fraysse] surjectivite de phi:
   Soit l \in calG; alors lH \in (G/H)_g.
   On a donc un g \in calG tel que lH = gH;
   alors g^-1lH = H, donc g^-1l \in H.
   On a donc un h \in calH tel que g^-1lK = hK.
   On en deduit lK = ghK = phi(g, h). *)
have phi_surjective : phi @: (setX calG calH) = lcosets K G.
  apply/eqP.
  rewrite eqEsubset.
  apply/andP; split; apply/subsetP => i.
    case/imsetP => /=; case=> [x1 x2].
    rewrite !inE /= => /andP[Hx1 Hx2] ->{i}.
    apply/lcosetsP.
    exists (x1 * x2) => //.
    rewrite groupM //.
      by move : (HG) => /reprs_subset /subsetP; apply.
    move/subsetP : HG; apply.
    apply/subsetP: x2 Hx2.
    by apply/reprs_subset/proper_sub.
  case/lcosetsP => l lG ->{i}.
  apply/imsetP => /=.
  have [g [gcalG gHlH]] : exists g, g \in calG /\ g *: H = l *: H.
    exists (repr (l *: H)).
    split.
      apply/imsetP.
      exists (l *: H) => //.
      apply/lcosetsP.
      by exists l.
    by rewrite (repr_form HG).
  have step1 : (g^-1 * l) *: H = H.
    move/(congr1 (fun x => g^-1 *: x)) : gHlH.
    by rewrite -!lcosetM mulVg lcoset1.
  have {step1}step2 : g^-1 * l \in H.
    by rewrite -step1 lcoset_refl.
  have [h [hcalH glKhK]] : exists h, h \in calH /\ (g^-1 * l) *: K = h *: K.
    exists (repr ((g^-1 * l) *: K)).
    split.
      apply/imsetP.
      exists ((g^-1 * l) *: K) => //.
      apply/lcosetsP.
      by exists (g^-1 * l).
    rewrite (repr_form KG) // groupM // groupVl // invgK //.
    by move: (reprs_subset HG) => /subsetP; apply.
  exists (g, h).
    by rewrite in_setX gcalG.
  move/(congr1 (fun x => g *: x)) : glKhK.
  by rewrite -!lcosetM mulgA mulgV mul1g => ->.
rewrite -phi_surjective -calG_H_surj -calH_K_surj.
rewrite (card_in_imset phi_injective) cardsX.
by rewrite (card_in_imset calG_H_inj) (card_in_imset calH_K_inj).
Qed.

End index.

(* Sect. 9: Lagrange Theorem *)

Section lagrange.

Variable gT : finGroupType.
Variables G H : {group gT}.
Hypotheses (HG : H \subset G).

Lemma coset1 g : g *: (1%G : {group gT}) = [set g].
Proof.
apply/eqP; rewrite eqEsubset; apply/andP; split; apply/subsetP => j.
  case/lcosetP => x.
  rewrite !inE => /eqP ->.
  by rewrite mulg1 => /eqP.
rewrite in_set1 => /eqP ->.
apply/lcosetP.
exists 1 => //.
by rewrite mulg1.
Qed.

Lemma lcosets1 (K : {group gT}) : lcosets 1%G K = (set1) @: K.
Proof.
apply/eqP; rewrite eqEsubset; apply/andP; split; apply/subsetP => i.
  case/lcosetsP => g gK ->{i}.
  apply/imsetP.
  exists g => //.
  by apply coset1.
case/imsetP => g gK ->{i}.
apply/lcosetsP.
exists g => //.
by rewrite coset1.
Qed.

Theorem Lagrange : #| G | = (#| H | * #| G : H |)%nat.
Proof.
case/boolP : (1%G \proper H) => H1; last first.
  suff -> : H = 1%G.
    rewrite cards1 mul1n lcosets1 // card_imset //.
    exact: set1_inj.
  apply/trivGP.
  move: H1.
  by rewrite proper1G negbK => /eqP ->.
have G1 : 1%G \subset G.
  apply/subsetP => h.
  by rewrite inE => /eqP ->.
move: (index_trans HG G1 H1).
rewrite lcosets1 (card_imset _ set1_inj).
rewrite mulnC lcosets1 card_imset //.
exact: set1_inj.
Qed.

End lagrange.


Require Import Com.
Require Import Big_Step.
Require Import Star.
Local Open Scope Z_scope.

Inductive instr :=
| LOADI : Z -> instr
| LOAD : vname -> instr
| ADD : instr
| STORE : vname -> instr
| JMP : Z -> instr
| JMPLESS : Z -> instr
| JMPGE : Z -> instr.

Definition stack := list val.
Definition config : Set := Z * state * stack.

Definition iexec (ins : instr) (cfg : config) : config :=
  match cfg with
  | (i, s, stk) =>
    match ins with
    | LOADI n => (i + 1, s, n :: stk)
    | LOAD x => (i + 1, s, s x :: stk)
    | ADD => (i + 1, s, hd 0 (tl stk) + hd 0 stk :: tl (tl stk))
    | STORE x => (i + 1, update s x (hd 0 stk), tl stk)
    | JMP n => (i + 1 + n, s, stk)
    | JMPLESS n => (if (hd 0 (tl stk)) <? hd 0 stk then i + 1 + n else i + 1, s, tl (tl stk))
    | JMPGE n => (if (hd 0 (tl stk)) >=? hd 0 stk then i + 1 + n else i + 1, s, tl (tl stk))
    end
  end.

Definition size (P : list instr) := Z.of_nat (length P).
Definition znth {A} (n : Z) (l : list A) (x : A) := nth (Z.to_nat n) l x.

Definition exec1 (P : list instr) (c c' : config) : Prop :=
  exists i s stk, c = (i,s,stk) /\ c' = iexec (znth i P ADD) (i,s,stk)
                  /\ i >= 0 /\ i < size P.

Definition exec P := star (exec1 P).
Hint Unfold exec : yhints.

Lemma lem_exec1I :
  forall P i s stk c', c' = iexec (znth i P ADD) (i,s,stk) ->
                       0 <= i -> i < size P ->
                       exec1 P (i,s,stk) c'.
Proof.
  Reconstr.hobvious Reconstr.Empty
                    (@Coq.ZArith.BinInt.Z.lt_nge)
                    (@Coq.ZArith.BinInt.Z.ge, @znth, @exec1, @Coq.ZArith.BinInt.Z.lt).
Qed.

(* Helper instruction list functions *)

Lemma lem_n_succ_znth :
  forall {A} n (a : A) xs x, 0 <= n -> znth (n + 1) (a :: xs) x = znth n xs x.
Proof.
  induction n; sauto.
  - Reconstr.htrivial Reconstr.AllHyps
                      (@Coq.PArith.Pnat.Pos2Nat.inj_succ, @Coq.PArith.BinPos.Pos.add_1_r)
                      Reconstr.Empty.
  - Reconstr.htrivial Reconstr.AllHyps
                      (@Coq.PArith.BinPos.Pos.add_1_r, @Coq.PArith.Pnat.Pos2Nat.inj_succ,
                       @Coq.ZArith.Znat.Z2Nat.inj_pos, @Coq.Init.Peano.eq_add_S)
                      (@znth).
Qed.

Lemma lem_znth_app :
  forall xs ys i x, i >= 0 -> znth (size xs + i) (xs ++ ys) x = znth i ys x.
Proof.
  assert (forall n (xs ys : list instr) i x, i >= 0 -> n = length xs ->
                                             znth (Z.of_nat n + i) (xs ++ ys) x = znth i ys x);
    [idtac | scrush].
  induction n.
  - scrush.
  - assert (HH: Z.of_nat (S n) = Z.of_nat n + 1) by
        Reconstr.htrivial Reconstr.Empty
                          (@Coq.ZArith.Znat.Nat2Z.inj_succ)
                          (@Coq.ZArith.BinIntDef.Z.succ).
    rewrite HH; clear HH.
    intros xs ys i x H1 H2.
    assert (0 <= Z.of_nat n + i) by omega.
    assert (HH: Z.of_nat n + 1 + i = (Z.of_nat n + i) + 1) by omega.
    rewrite HH; clear HH.
    destruct xs; [ scrush | simpl ].
    rewrite lem_n_succ_znth by scrush.
    scrush.
Qed.

Lemma lem_size_succ :
  forall a xs, size (a :: xs) = size xs + 1.
Proof.
  assert (forall n a xs, n = size xs -> size (a :: xs) = n + 1); [idtac | scrush].
  induction n; sauto.
  - scrush.
  - Reconstr.htrivial Reconstr.AllHyps
                      (@Coq.PArith.BinPos.Pplus_one_succ_r, @Coq.ZArith.Znat.Zpos_P_of_succ_nat,
                       @Coq.ZArith.BinInt.Pos2Z.inj_succ)
                      (@Coq.ZArith.BinIntDef.Z.succ, @size).
  - scrush.
Qed.

Lemma lem_nth_append :
  forall xs ys i x, 0 <= i ->
                    znth i (xs ++ ys) x =
                    (if i <? size xs then znth i xs x else znth (i - size xs) ys x).
Proof.
  induction xs.
  - sauto.
    + Reconstr.hcrush Reconstr.AllHyps
                  (@Coq.ZArith.BinInt.Z.ltb_ge)
                  Reconstr.Empty.
    + scrush.
  - intros.
    assert (HH: i = 0 \/ exists i', i = i' + 1 /\ 0 <= i') by
        Reconstr.hcrush Reconstr.AllHyps
                        (@Coq.ZArith.BinInt.Z.lt_le_pred, @Coq.ZArith.BinInt.Z.lt_eq_cases,
                         @Coq.ZArith.BinInt.Z.succ_pred)
                        (@Coq.ZArith.BinIntDef.Z.succ).
    destruct HH as [ ? | HH ].
    scrush.
    destruct HH as [ i' HH ].
    destruct HH.
    subst; simpl.
    repeat rewrite lem_n_succ_znth by scrush.
    repeat rewrite lem_size_succ.
    sauto.
    + assert ((i' <? size xs) = true).
      Reconstr.hcrush Reconstr.AllHyps
                      (@Coq.ZArith.BinInt.Z.le_gt_cases, @Coq.Bool.Bool.diff_true_false,
                       @Coq.ZArith.BinInt.Z.ltb_ge, @Coq.ZArith.Zbool.Zlt_is_lt_bool,
                       @Coq.ZArith.BinInt.Z.add_le_mono_r)
                      (@size).
      scrush.
    + assert ((i' <? size xs) = false).
      Reconstr.heasy Reconstr.AllHyps
                     (@Coq.ZArith.BinInt.Z.ltb_nlt, @Coq.ZArith.BinInt.Z.add_lt_mono_r)
                     (@size).
      assert (i' + 1 - (size xs + 1) = i' - size xs) by auto with zarith.
      scrush.
Qed.

Lemma lem_size_app : forall xs ys, size (xs ++ ys) = size xs + size ys.
Proof.
  Reconstr.htrivial Reconstr.Empty
                    (@Coq.ZArith.Znat.Nat2Z.inj_add, @Coq.Lists.List.app_length)
                    (@size).
Qed.

Lemma lem_size_app_le : forall xs ys, size xs <= size (xs ++ ys).
Proof.
  Reconstr.hobvious Reconstr.Empty
                    (@Coq.Arith.Plus.le_plus_l, @Coq.ZArith.Znat.Nat2Z.inj_le, @Coq.Lists.List.app_length)
                    (@size).
Qed.

(* Verification infrastructure *)

Lemma lem_iexec_shift :
  forall x n i i' s s' stk stk',
    (n+i',s',stk') = iexec x (n+i,s,stk) <->
    (i',s',stk') = iexec x (i,s,stk).
Proof.
  split; intro H.
  - assert (forall n i i' k, n + i' = n + i + k -> i' = i + k) by auto with zarith.
    assert (forall n i i' k, n + i' = n + i + 1 + k -> i' = i + 1 + k) by auto with zarith.
    scrush.
  - assert (forall n i i' k, i' = i + k -> n + i' = n + i + k) by auto with zarith.
    assert (forall n i, n + (i + 1) = n + i + 1) by auto with zarith.
    scrush. (* takes 25s *)
Qed.

Lemma lem_exec1_hlp1 :
  forall n P P', 0 <= n -> n < size P ->
                 znth n P ADD = znth n (P ++ P') ADD.
Proof.
  induction n.
  - scrush.
  - Reconstr.hcrush Reconstr.Empty
                    (@lem_size_succ, @lem_nth_append, @Coq.ZArith.Zbool.Zlt_is_lt_bool)
                    Reconstr.Empty.
  - scrush.
Qed.

Lemma lem_exec1_appendR :
  forall P P' c c', exec1 P c c' -> exec1 (P ++ P') c c'.
Proof.
  unfold exec1.
  intros; simp_hyps.
  exists i.
  exists s.
  exists stk.
  rewrite <- lem_exec1_hlp1 by auto with zarith.
  assert (i < size (P ++ P')) by
      Reconstr.heasy Reconstr.AllHyps
                     (@lem_size_app_le, @Coq.ZArith.BinInt.Z.le_lt_trans,
                      @Coq.ZArith.BinInt.Z.nle_gt, @Coq.ZArith.BinInt.Z.lt_ge_cases)
                     (@size).
  scrush.
Qed.

Lemma lem_exec_appendR : forall P P' c c', exec P c c' -> exec (P ++ P') c c'.
Proof.
  unfold exec.
  intros P P' c c' H.
  induction H.
  - scrush.
  - pose @star_step; pose lem_exec1_appendR; scrush.
Qed.

Lemma lem_exec1_appendL :
  forall i i' P P' s s' stk stk', exec1 P (i,s,stk) (i',s',stk') ->
                                  exec1 (P' ++ P) (size P' + i,s,stk) (size P' + i',s',stk').
Proof.
  unfold exec1.
  intros; simp_hyps.
  exists (size P' + i0).
  exists s0.
  exists stk0.
  rewrite lem_znth_app by scrush.
  split; [ scrush | split ].
  - Reconstr.htrivial Reconstr.AllHyps
                      (@lem_iexec_shift)
                      Reconstr.Empty.
  - split.
    + Reconstr.hobvious Reconstr.AllHyps
                        (@Coq.ZArith.Zorder.Zle_0_nat, @Coq.ZArith.BinInt.Z.nle_gt,
                         @Coq.ZArith.BinInt.Z.add_neg_cases)
                        (@size, @Coq.ZArith.BinInt.Z.ge, @Coq.ZArith.BinInt.Z.lt).
    + Reconstr.hobvious Reconstr.AllHyps
                        (@lem_size_app, @Coq.ZArith.BinInt.Z.add_lt_mono_l)
                        (@size).
Qed.

Lemma lem_exec_appendL :
  forall i i' P P' s s' stk stk', exec P (i,s,stk) (i',s',stk') ->
                                  exec (P' ++ P) (size P' + i,s,stk) (size P' + i',s',stk').
Proof.
  assert (forall c c' P, exec P c c' ->
                       forall i i' P' s s' stk stk',
                         c = (i,s,stk) -> c' = (i',s',stk') ->
                         exec (P' ++ P) (size P' + i,s,stk) (size P' + i',s',stk')); [idtac|scrush].
  unfold exec.
  intros c c' P H.
  induction H.
  - scrush.
  - intros; simp_hyps; subst.
    destruct y as [ p stk0 ].
    destruct p as [ i0 s0 ].
    pose @star_step; pose lem_exec1_appendL; scrush.
Qed.

Lemma lem_exec_Cons_1 :
  forall ins P j s t stk stk',
    exec P (0,s,stk) (j,t,stk') ->
    exec (ins :: P) (1,s,stk) (1+j,t,stk').
Proof.
  intros ins P j.
  assert (HH: ins :: P = (ins :: nil) ++ P) by auto with datatypes.
  rewrite HH; clear HH.
  assert (HH: 1 + j = size (ins :: nil) + j) by scrush.
  rewrite HH; clear HH.
  assert (HH: 1 = size (ins :: nil) + 0) by scrush.
  rewrite HH; clear HH.
  pose lem_exec_appendL; scrush.
Qed.

Lemma lem_exec_appendL_if :
  forall i i' j P P' s s' stk stk',
    size P' <= i -> exec P (i - size P',s,stk) (j,s',stk') -> i' = size P' + j ->
    exec (P' ++ P) (i,s,stk) (i',s',stk').
Proof.
  intros.
  pose (k := i - size P').
  assert (HH: i = size P' + k) by
      Reconstr.htrivial Reconstr.Empty
                        (@Coq.ZArith.BinInt.Zplus_minus)
                        (@k).
  rewrite HH; clear HH.
  pose lem_exec_appendL; scrush.
Qed.

Lemma lem_exec_append_trans :
  forall i' i'' j'' P P' s s' s'' stk stk' stk'',
    exec P (0,s,stk) (i',s',stk') -> size P <= i' ->
    exec P' (i' - size P,s',stk') (i'',s'',stk'') ->
    j'' = size P + i'' ->
    exec (P ++ P') (0,s,stk) (j'',s'',stk'').
Proof.
  intros.
  assert (exec (P ++ P') (i',s',stk') (j'',s'',stk'')) by
      (apply lem_exec_appendL_if with (j := i''); sauto).
  assert (exec (P ++ P') (0,s,stk) (i',s',stk')) by
      (apply lem_exec_appendR; sauto).
  pose @lem_star_trans; scrush.
Qed.

Ltac escrush := unfold exec; pose @star_step; pose @star_refl; scrush.

Ltac exec_tac :=
  match goal with
  | [ |- exec ?A (?i, ?s, ?stk) ?B ] =>
    assert (exec1 A (i, s, stk) B) by
        (unfold exec1; exists i; exists s; exists stk; sauto);
    escrush
  end.

Ltac exec_append_tac :=
  intros; assert (H_exec_append_tac: forall l, size l - size l = 0) by (intro; omega);
  match goal with
  | [ |- exec (?l1 ++ ?l2) (0,?s,?stk) (size(?l1 ++ ?l2), ?s, ?a :: ?b :: ?stk) ] =>
    rewrite lem_size_app;
    apply lem_exec_append_trans with
    (i' := size(l1)) (i'' := size(l2)) (s' := s) (stk' := b :: stk);
    solve [ omega | ycrush | scrush ]
  | [ H1 : exec ?l1 (0,?s,?stk) (size(?l1), ?s1, ?stk1),
      H2 : exec ?l2 (0,?s1,?stk1) (size(?l2), ?s2, ?stk2)
      |- exec (?l1 ++ ?l2) (0,?s,?stk) (size(?l1 ++ ?l2), ?s2, ?stk2) ] =>
    rewrite lem_size_app;
    apply lem_exec_append_trans with
    (i' := size(l1)) (i'' := size(l2)) (s' := s1) (stk' := stk1);
    solve [ omega | ycrush | scrush ]
  | [ H1 : exec ?l1 (0,?s,?stk) (size(?l1), ?s1, ?stk1),
      H2 : exec ?l2 (0,?s1,?stk1) (size(?l2) + ?i, ?s2, ?stk2)
      |- exec (?l1 ++ ?l2) (0,?s,?stk) (size(?l1 ++ ?l2) + ?i, ?s2, ?stk2) ] =>
    rewrite lem_size_app;
    apply lem_exec_append_trans with
    (i' := size(l1)) (i'' := size(l2) + i) (s' := s1) (stk' := stk1);
    solve [ omega | ycrush | scrush ]
  end;
  clear H_exec_append_tac.

Ltac exec_append3_tac :=
  intros;
  match goal with
  | [ H2: exec ?l2 (0,?s1,?stk1) (size(?l2),?s2,?stk2),
      H3: exec ?l3 (0,?s2,?stk2) (size(?l3),?s3,?stk3)
      |- exec (?l1 ++ ?l2 ++ ?l3) (0,?s,?stk) (size(?l1 ++ ?l2 ++ ?l3), ?s3, ?stk3) ] =>
    assert (exec (l2 ++ l3) (0,s1,stk1) (size(l2 ++ l3),s3,stk3)) by exec_append_tac;
    exec_append_tac
  | [ H2: exec ?l2 (0,?s1,?stk1) (size(?l2),?s2,?stk2),
      H3: exec ?l3 (0,?s2,?stk2) (size(?l3) + ?i,?s3,?stk3)
      |- exec (?l1 ++ ?l2 ++ ?l3) (0,?s,?stk) (size(?l1 ++ ?l2 ++ ?l3) + ?i, ?s3, ?stk3) ] =>
    assert (exec (l2 ++ l3) (0,s1,stk1) (size(l2 ++ l3) + i,s3,stk3)) by exec_append_tac;
    exec_append_tac
  end.

(* Compilation *)

Fixpoint acomp (a : aexpr) : list instr :=
  match a with
  | Anum n => LOADI n :: nil
  | Avar x => LOAD x :: nil
  | Aplus a1 a2 => acomp a1 ++ acomp a2 ++ (ADD :: nil)
  end.

Lemma lem_acomp_correct :
  forall a s stk, exec (acomp a) (0, s, stk) (size(acomp a), s, aval s a :: stk).
Proof.
  induction a; sauto.
  - exec_tac.
  - exec_tac.
  - assert (exec (acomp a1 ++ acomp a2) (0,s,stk)
                 (size(acomp a1 ++ acomp a2),s,aval s a2 :: aval s a1 :: stk)) by exec_append_tac.
    assert (exec (ADD :: nil) (0,s,aval s a2 :: aval s a1 :: stk) (1,s,(aval s a1 + aval s a2) :: stk)) by
        exec_tac.
    assert (forall l, size l - size l = 0) by (intro; omega);
    assert (HH: exec ((acomp a1 ++ acomp a2) ++ ADD :: nil) (0, s, stk)
                     (size ((acomp a1 ++ acomp a2) ++ ADD :: nil), s, aval s a1 + aval s a2 :: stk)) by
        (apply lem_exec_append_trans with
         (i' := size(acomp a1 ++ acomp a2)) (s' := s) (stk' := aval s a2 :: aval s a1 :: stk) (i'' := 1);
         solve [ sauto | ycrush | rewrite lem_size_app; scrush ]).
    clear -HH; scrush.
Qed.

Lemma lem_acomp_append :
   forall a1 a2 s stk, exec (acomp a1 ++ acomp a2) (0, s, stk)
                            (size (acomp a1 ++ acomp a2), s, aval s a2 :: aval s a1 :: stk).
Proof.
  pose lem_acomp_correct; exec_append_tac.
Qed.

Fixpoint bcomp (b : bexpr) (f : bool) (n : Z) : list instr :=
  match b with
  | Bval v => if eqb v f then JMP n :: nil else nil
  | Bnot b' => bcomp b' (negb f) n
  | Band b1 b2 =>
    let cb2 := bcomp b2 f n in
    let m := if f then size cb2 else size cb2 + n in
    let cb1 := bcomp b1 false m in
    cb1 ++ cb2
  | Bless a1 a2 =>
    acomp a1 ++ acomp a2 ++ (if f then JMPLESS n :: nil else JMPGE n :: nil)
  end.

Lemma lem_bcomp_correct :
  forall b f n s stk, 0 <= n ->
                      exec (bcomp b f n) (0,s,stk)
                           (size(bcomp b f n) + (if eqb f (bval s b) then n else 0),s,stk).
Proof.
  induction b; simpl; intros f n s stk H.
  - sauto; try exec_tac;
      Reconstr.hsimple Reconstr.AllHyps
                       (@Coq.Bool.Bool.eqb_false_iff, @Coq.Bool.Bool.eqb_prop)
                       Reconstr.Empty.
  - assert (HH: (if eqb f (negb (bval s b)) then n else 0) =
                (if eqb (negb f) (bval s b) then n else 0)) by
        Reconstr.hsimple Reconstr.Empty
                         (@Coq.Bool.Bool.eqb_negb2, @Coq.Bool.Bool.negb_false_iff,
                          @Coq.Bool.Bool.negb_true_iff, @Coq.Bool.Bool.no_fixpoint_negb,
                          @Coq.Bool.Bool.negb_involutive, @Coq.Bool.Bool.diff_true_false,
                          @Coq.Bool.Bool.eqb_false_iff, @Coq.Bool.Bool.eqb_prop)
                         (@Coq.Bool.Bool.eqb, @Coq.Init.Datatypes.negb).
    rewrite HH; clear HH.
    scrush.
  - pose (m := if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n); fold m.
    assert (H0: 0 <= m) by
        (unfold m; clear -H; sauto; unfold size; omega).
    destruct (bval s b1) eqn:H1; simpl.
    + apply lem_exec_append_trans with
      (i' := size (bcomp b1 false m))
        (s' := s) (stk' := stk)
        (i'' := size (bcomp b2 f n) + (if eqb f (bval s b2) then n else 0)).
      * generalize (IHb1 false m s stk); scrush.
      * auto with zarith.
      * assert (HH: size (bcomp b1 false m) - size (bcomp b1 false m) = 0) by omega.
        rewrite HH; clear HH.
        auto.
      * rewrite lem_size_app; auto with zarith.
    + rewrite lem_size_app.
      assert (HH: size (bcomp b2 f n) + (if eqb f false then n else 0) = m) by
          (unfold m; destruct f; simpl; omega).
      rewrite <- ZArith.BinInt.Z.add_assoc; rewrite HH; clear HH.
      apply lem_exec_appendR.
      assert (HH: size (bcomp b1 false m) + m =
                  size (bcomp b1 false m) + if eqb false (bval s b1) then m else 0) by scrush.
      rewrite HH; clear HH.
      auto.
  - assert (HH: aval s a >=? aval s a0 = negb (aval s a <? aval s a0)) by
        Reconstr.htrivial Reconstr.Empty
                          (@Coq.ZArith.BinInt.Z.geb_leb, @Coq.Bool.Bool.negb_true_iff,
                           @Coq.ZArith.BinInt.Z.leb_antisym)
                          Reconstr.Empty.
    assert (exec (if f then JMPLESS n :: nil else JMPGE n :: nil) (0, s, aval s a0 :: aval s a :: stk)
                 (size (if f then JMPLESS n :: nil else JMPGE n :: nil) +
                  (if eqb f (aval s a <? aval s a0) then n else 0), s, stk)) by
        (sauto; exec_tac).
    clear HH.
    assert (HH: forall (l1 l2 l3 : list instr), l1 ++ l2 ++ l3 = (l1 ++ l2) ++ l3) by scrush.
    repeat rewrite HH; clear HH.
    pose proof (lem_acomp_append a a0 s stk).
    exec_append_tac.
Qed.

Fixpoint ccomp (c : com) : list instr :=
  match c with
  | Skip => nil
  | Assign x a => acomp a ++ STORE x :: nil
  | Seq c1 c2 => ccomp c1 ++ ccomp c2
  | If b c1 c2 =>
    let cc1 := ccomp c1 in
    let cc2 := ccomp c2 in
    let cb := bcomp b false (size cc1 + 1) in
    cb ++ cc1 ++ JMP (size cc2) :: cc2
  | While b c0 =>
    let cc := ccomp c0 in
    let cb := bcomp b false (size cc + 1) in
    cb ++ cc ++ JMP (-(size cb + size cc + 1)) :: nil
  end.

(* Preservation of semantics *)

Require Import Program.Equality.

Ltac assert_exec_bcomp_tac :=
  intros;
  match goal with
  | [ H0: bval ?s ?b = ?B |- exec ((bcomp ?b false ?k) ++ ?l) (0,?s,?stk) ?c ] =>
    let n := fresh "n" in
    let H := fresh "H" in
    pose (n := k); fold n;
    assert (H: exec (bcomp b false n) (0, s, stk)
                    (size (bcomp b false n) + if eqb false (bval s b) then n else 0, s, stk)) by
        (apply lem_bcomp_correct;
         Reconstr.hyelles 4 Reconstr.Empty
                          (@Coq.ZArith.BinInt.Z.pred_succ, @Coq.ZArith.BinInt.Z.lt_le_incl,
                           @Coq.ZArith.BinInt.Z.lt_le_pred, @Coq.ZArith.Zorder.Zle_0_nat)
                          (@Coq.ZArith.BinIntDef.Z.succ, @size, @n);
         Reconstr.htrivial Reconstr.AllHyps
                           (@Coq.ZArith.BinInt.Z.lt_succ_r)
                           (@Coq.ZArith.BinIntDef.Z.succ, @size, @n));
    rewrite H0 in H; cbn in H; autorewrite with yhints in H
  end.

Lemma lem_ccomp_bigstep :
  forall c s t, (c, s) ==> t -> forall stk, exec (ccomp c) (0, s, stk) (size (ccomp c), t, stk).
Proof.
  intros c s t H.
  dependent induction H; intro stk; sauto.
  - assert (exec (STORE x :: nil) (0, s, (aval s a) :: stk)
                 (size (STORE x :: nil), update s x (aval s a), stk)) by
        exec_tac.
    assert (exec (acomp a) (0, s, stk) (size (acomp a), s, aval s a :: stk)) by
        Reconstr.hobvious Reconstr.Empty (@lem_acomp_correct) Reconstr.Empty.
    exec_append_tac.
  - assert (exec (ccomp c1) (0, s, stk) (size (ccomp c1), s2, stk)) by scrush.
    assert (exec (ccomp c2) (0, s2, stk) (size (ccomp c2), s3, stk)) by scrush.
    exec_append_tac.
  - assert_exec_bcomp_tac.
    assert (exec (ccomp c1) (0, s, stk) (size (ccomp c1), s', stk)) by scrush.
    assert (exec (JMP (size (ccomp c2)) :: ccomp c2) (0, s', stk)
                 (size (JMP (size (ccomp c2)) :: ccomp c2), s', stk)) by
        (rewrite lem_size_succ; exec_tac).
    exec_append3_tac.
  - assert_exec_bcomp_tac.
    assert (exec (ccomp c2) (0, s, stk) (size (ccomp c2), s', stk)) by scrush.
    assert (exec (bcomp b false n ++ ccomp c1 ++ JMP (size (ccomp c2)) :: nil) (0, s, stk)
                 (size (bcomp b false n ++ ccomp c1 ++ JMP (size (ccomp c2)) :: nil), s, stk)) by
        (unfold n in *; repeat rewrite lem_size_app; pose lem_exec_appendR; scrush).
    assert (exec ((bcomp b false n ++ ccomp c1 ++ JMP (size (ccomp c2)) :: nil) ++ ccomp c2) (0, s, stk)
                 (size ((bcomp b false n ++ ccomp c1 ++ JMP (size (ccomp c2)) :: nil) ++ ccomp c2),
                  s', stk)) by
        exec_append_tac.
    scrush.
  - assert_exec_bcomp_tac.
    repeat rewrite lem_size_app; sauto;
    apply lem_exec_appendR; unfold n in H0; scrush.
  - assert_exec_bcomp_tac.
    assert (exec (ccomp c0) (0, s, stk) (size (ccomp c0), s2, stk)) by scrush.
    assert (HH1: exec (ccomp (While b c0)) (0, s2, stk) (size (ccomp (While b c0)), s3, stk)) by scrush.
    cbn in HH1; fold n in HH1.
    pose (k := size (bcomp b false n) + size (ccomp c0)); fold k; fold k in HH1.
    assert (exec (JMP (-(k+1)) :: nil) (0, s2, stk) (-k, s2, stk)) by
        (assert (1 + -(k+1) = -k) by omega; exec_tac).
    assert (Heq: size (JMP (-(k+1)) :: nil) + -(k+1) = -k) by
        (assert (Hs: size (JMP (-(k+1)) :: nil) = 1) by scrush; rewrite Hs; omega).
    assert (exec (JMP (-(k+1)) :: nil) (0, s2, stk) (size (JMP (-(k+1)) :: nil) + -(k+1), s2, stk)) by
        (rewrite Heq; assumption).
    assert (HH2: exec (bcomp b false n ++ ccomp c0 ++ JMP (- (k + 1)) :: nil) (0, s, stk)
                     (size (bcomp b false n ++ ccomp c0 ++ JMP (- (k + 1)) :: nil) + -(k+1), s2, stk)) by
        exec_append3_tac.
    repeat rewrite lem_size_app in HH2.
    assert (Heq2: size (bcomp b false n) +
                  (size (ccomp c0) + size (JMP (- (k + 1)) :: nil)) + -(k+1) = 0) by
        (rewrite Zplus_assoc; rewrite Zplus_assoc_reverse; rewrite Heq; unfold k; omega).
    rewrite Heq2 in HH2; clear Heq2.
    clear -HH1 HH2.
    unfold exec in *; pose @lem_star_trans; scrush.
Qed.


(** DEC Library Coq Implementation *)

From Coq Require ZArith.

Module Export Inequalities.

Set Warnings "-undo-batch-mode".

Import ZArith Z.

Open Scope Z_scope.

Notation "'(|' x '|)'" := (abs x).

Lemma le_refl : forall x : Z,
  x <= x.
Proof.
  intros x. apply le_refl. Qed.

Corollary le_refl_add : forall x y : Z,
  x + y <= x + y.
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_sub : forall x y : Z,
  x - y <= x - y.
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_abs_add : forall x y : Z,
  (|x + y|) <= (|x + y|).
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_abs_sub : forall x y : Z,
  (|x - y|) <= (|x - y|).
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_add_abs : forall x y : Z,
  (|x|) + (|y|) <= (|x|) + (|y|).
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_sub_abs : forall x y : Z,
  (|x|) - (|y|) <= (|x|) - (|y|).
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_abs_add_abs : forall x y : Z,
  (|(|x|) + (|y|)|) <= (|(|x|) + (|y|)|).
Proof. intros x y. apply le_refl. Qed.

Corollary le_refl_abs_sub_abs : forall x y : Z,
  (|(|x|) - (|y|)|) <= (|(|x|) - (|y|)|).
Proof. intros x y. apply le_refl. Qed.

Lemma le_abs : forall x : Z,
  x <= (|x|).
Proof.
  intros x. apply abs_le. apply le_refl. Qed.

Corollary le_abs_add : forall x y : Z,
  x + y <= (|x + y|).
Proof. intros x y. apply le_abs. Qed.

Corollary le_abs_sub : forall x y : Z,
  x - y <= (|x - y|).
Proof. intros x y. apply le_abs. Qed.

Corollary le_abs_add_abs : forall x y : Z,
  (|x|) + (|y|) <= (|(|x|) + (|y|)|).
Proof. intros x y. apply le_abs. Qed.

Corollary le_abs_sub_abs : forall x y : Z,
  (|x|) - (|y|) <= (|(|x|) - (|y|)|).
Proof. intros x y. apply le_abs. Qed.

Theorem abs_triangle : forall x y : Z,
  (|x + y|) <= (|x|) + (|y|).
Proof.
  intros x y.
  destruct (abs_spec (x + y)) as [[_ Hexy] | [_ Hexy]].
  - rewrite Hexy. destruct (abs_spec x) as [[_ Hex] | [_ Hex]].
    + rewrite Hex.
      apply add_le_mono_l. apply le_abs.
    + destruct (abs_spec y) as [[_ Hey] | [_ Hey]].
      * rewrite Hey. apply add_le_mono_r. apply le_abs.
      * apply add_le_mono.
        -- apply le_abs.
        -- apply le_abs.
  - rewrite Hexy. destruct (abs_spec x) as [[_ Hex] | [_ Hex]].
    + destruct (abs_spec y) as [[_ Hey] | [_ Hey]].
      * rewrite (opp_add_distr x y). rewrite <- (abs_opp x), <- (abs_opp y).
        apply add_le_mono.
        -- apply le_abs.
        -- apply le_abs.
      * rewrite Hey. rewrite (opp_add_distr x y). rewrite <- (abs_opp x).
        apply add_le_mono_r. apply le_abs.
    + rewrite Hex. rewrite (opp_add_distr x y). rewrite <- (abs_opp y).
      apply add_le_mono_l. apply le_abs. Qed.

Theorem abs_opp_triangle : forall x y : Z,
  (|x - y|) <= (|x|) + (|y|).
Proof.
  intros x y.
  rewrite <- (add_opp_r x y). rewrite <- (abs_opp y).
  remember (- y) as z eqn : Hez.
  apply abs_triangle. Qed.

Theorem abs_sub_triangle : forall x y : Z,
  (|x|) - (|y|) <= (|x - y|).
Proof.
  intros x y. apply (add_le_mono_r _ _ (|y|)).
  rewrite (sub_add _ _). remember (x - y) as z eqn : Hez.
  rewrite <- (sub_add y x). rewrite <- Hez.
  apply abs_triangle. Qed.

Theorem abs_opp_sub_triangle : forall x y : Z,
  (|x|) - (|y|) <= (|x + y|).
Proof.
  intros x y.
  rewrite <- (abs_opp y). rewrite <- (sub_opp_r x y).
  remember (- y) as z eqn : Hez.
  apply abs_sub_triangle. Qed.

Lemma abs_sub_comm : forall x y : Z,
  (|x - y|) = (|y - x|).
Proof.
  intros x y. destruct (abs_spec (x - y)) as [[Hlxy Hexy] | [Hlxy Hexy]].
  - rewrite Hexy. rewrite <- (add_opp_l x y). rewrite <- (opp_sub_distr y x).
    apply eq_sym. apply abs_neq.
    apply (le_sub_le_add_l y x 0). rewrite (add_0_r x).
    rewrite <- (add_0_r y). apply (le_add_le_sub_l y x 0).
    apply Hlxy.
  - apply lt_le_incl in Hlxy.
    rewrite Hexy. rewrite (opp_sub_distr x y). rewrite (add_opp_l y x).
    apply eq_sym. apply abs_eq.
    apply (le_add_le_sub_l x y 0). rewrite (add_0_r x).
    rewrite <- (add_0_r y). apply (le_sub_le_add_l x y 0).
    apply Hlxy. Qed.

Theorem abs_rev_triangle : forall x y : Z,
  (|(|x|) - (|y|)|) <= (|x - y|).
Proof.
  intros x y. apply abs_le. split.
  - apply opp_le_mono.
    rewrite (opp_sub_distr _ _). rewrite (add_opp_l _ _).
    rewrite (opp_involutive _). rewrite (abs_sub_comm x y).
    apply abs_sub_triangle.
  - apply abs_sub_triangle. Qed.

Theorem abs_opp_rev_triangle : forall x y : Z,
  (|(|x|) - (|y|)|) <= (|x + y|).
Proof.
  intros x y.
  rewrite <- (abs_opp y). rewrite <- (sub_opp_r x y).
  remember (- y) as z eqn : Hez.
  apply abs_rev_triangle. Qed.

Theorem abs_quadrangle : forall x y : Z,
  (|x|) - (|y|) <= (|x|) + (|y|).
Proof.
  intros x y. apply (le_trans _ (|x - y|) _).
  - apply abs_sub_triangle.
  - apply abs_opp_triangle. Restart.
  intros x y. apply (le_trans _ (|x + y|) _).
  - apply abs_opp_sub_triangle.
  - apply abs_triangle. Qed.

Theorem abs_rev_quadrangle : forall x y : Z,
  (|(|x|) - (|y|)|) <= (|x|) + (|y|).
Proof.
  intros x y. apply (le_trans _ (|x - y|) _).
  - apply abs_rev_triangle.
  - apply abs_opp_triangle. Restart.
  intros x y. apply (le_trans _ (|x + y|) _).
  - apply abs_opp_rev_triangle.
  - apply abs_triangle. Qed.

Theorem abs_pre_triangle : forall x y : Z,
  x + y <= (|x|) + (|y|).
Proof.
  intros x y. apply (le_trans _ (|x + y|) _).
  - apply le_abs.
  - apply abs_triangle. Qed.

Theorem abs_opp_pre_triangle : forall x y : Z,
  x - y <= (|x|) + (|y|).
Proof.
  intros x y.
  rewrite <- (add_opp_r x y). rewrite <- (abs_opp y).
  remember (- y) as z eqn : Hez.
  apply abs_pre_triangle. Qed.

Theorem abs_le_add_abs : forall x y : Z,
  (|(|x|) + (|y|)|) <= (|x|) + (|y|).
Proof.
  intros x y. apply (le_stepl ((|x|) + (|y|)) _ _).
  - apply le_refl.
  - apply eq_sym. apply abs_eq. apply (le_trans _ (|x + y|) _).
    + apply abs_nonneg.
    + apply abs_triangle. Qed.

Theorem abs_triangle_abs : forall x y : Z,
  (|x + y|) <= (|(|x|) + (|y|)|).
Proof.
  intros x y. apply (le_trans _ ((|x|) + (|y|)) _).
  - apply abs_triangle.
  - apply le_abs. Qed.

Theorem abs_opp_triangle_abs : forall x y : Z,
  (|x - y|) <= (|(|x|) + (|y|)|).
Proof.
  intros x y. apply (le_trans _ ((|x|) + (|y|)) _).
  - apply abs_opp_triangle.
  - apply le_abs. Qed.

Theorem abs_quadrangle_abs : forall x y : Z,
  (|x|) - (|y|) <= (|(|x|) + (|y|)|).
Proof.
  intros x y. apply (le_trans _ ((|x|) + (|y|)) _).
  - apply abs_quadrangle.
  - apply le_abs. Qed.

Theorem abs_rev_quadrangle_abs : forall x y : Z,
  (|(|x|) - (|y|)|) <= (|(|x|) + (|y|)|).
Proof.
  intros x y. apply (le_trans _ ((|x|) + (|y|)) _).
  - apply abs_rev_quadrangle.
  - apply le_abs. Qed.

Theorem abs_pre_triangle_abs : forall x y : Z,
  x + y <= (|(|x|) + (|y|)|).
Proof.
  intros x y. apply (le_trans _ ((|x|) + (|y|)) _).
  - apply abs_pre_triangle.
  - apply le_abs. Qed.

Theorem abs_opp_pre_triangle_abs : forall x y : Z,
  x - y <= (|(|x|) + (|y|)|).
Proof.
  intros x y.
  rewrite <- (add_opp_r x y). rewrite <- (abs_opp y).
  remember (- y) as z eqn : Hez.
  apply abs_pre_triangle_abs. Qed.

End Inequalities.


Inductive day : Type :=
|monday
|tuesday
|wednesday
|thursday
|friday
|saturday
|sunday.

Definition next_weekday(d: day ): day :=
match d with
|monday => tuesday
|tuesday => wednesday
|wednesday => thursday
|thursday => friday
|friday => monday
|saturday => monday
|sunday => monday
end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
(next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.


Add LoadPath "C:/Coq/buffer".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Maps.

Module AExp.

  Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.
  (* forall P : aexp -> Prop,
     (forall n : P (Anum n)) ->
     (forall a : aexp, P a -> (forall b : aexp, P b ->  (APlus a b))) ->
     (forall a : aexp, P a -> (forall b : aexp, P b -> (AMinus a b))) ->
     (forall a : aexp, P a -> (forall b : aexp, P b -> (AMult a b))) ->
     forall a : exp, P a *)

  Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.
  (* forall P : bexp -> Prop,
     P BTrue -> P BFalse ->
     (forall a a0 : aexp, P (BEq a a0)) ->
     (forall a a0 : aexp, P (BLe a a0)) ->
     (forall b : bexp, P b -> P (BNot b)) ->
     (forall b : bexp, P b -> forall b0 : bexp, P b0 -> P (BAnd b b0)) ->
     forall b : bexp, P b *)

  Fixpoint aeval (a : aexp) : nat :=
    match a with
    | ANum n => n
    | APlus a b => aeval a + aeval b
    | AMinus a b => aeval a - aeval b
    | AMult a b => aeval a * aeval b
    end.

  Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a b => beq_nat (aeval a) (aeval b)
  | BLe a b => leb (aeval a) (aeval b)
  | BNot b => negb (beval b)
  | BAnd a b => andb (beval a) (beval b)
  end.

  Fixpoint optimize_0plus (a : aexp) : aexp :=
    match a with
    | ANum n =>
      ANum n
    | APlus (ANum 0) e2 =>
      optimize_0plus e2
    | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
    | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
    | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
    end.

  Example test_optimize_0plus :
    optimize_0plus (APlus (ANum 2)
                          (APlus (ANum 0)
                                 (APlus (ANum 0) (ANum 1))))
    = APlus (ANum 2) (ANum 1).
  Proof. reflexivity. Qed.

  Theorem optimize_0plus_sound : forall a,
      aeval (optimize_0plus a) = aeval a.
  Proof.
    intros a. induction a.
    -reflexivity.
    -destruct a1.
     +destruct n.
      * apply IHa2.
      * simpl. rewrite <- IHa2. reflexivity.
     +simpl. simpl in IHa1. rewrite IHa1. rewrite IHa2. reflexivity.
     +simpl. simpl in IHa1. rewrite IHa1. rewrite IHa2. reflexivity.
     +simpl. simpl in IHa1. rewrite IHa1. rewrite IHa2. reflexivity.
    -simpl. simpl in IHa1. simpl in IHa2. rewrite IHa1. rewrite IHa2. reflexivity.
    -simpl. simpl in IHa1. simpl in IHa2. rewrite IHa1. rewrite IHa2. reflexivity.
  Qed.

  Theorem silly1 : forall ae, aeval ae = aeval ae.
  Proof. try reflexivity. Qed.

  Theorem silly2 : forall (P : Prop), P -> P.
  Proof.
    intros P HP.
    try reflexivity.
    apply HP.
  Qed.

  Lemma foo : forall n, leb 0 n = true.
  Proof.
    intros.
    destruct n.
    -simpl. reflexivity.
    -simpl. reflexivity.
  Qed.

  Lemma foo' : forall n, leb 0 n = true.
  Proof.
    intros.
    destruct n; simpl; reflexivity.
  Qed.

  Theorem optimize_0plus_sound' : forall a : aexp,
      aeval (optimize_0plus a) = aeval a.
  Proof. intros a. induction a;
           try ( simpl; rewrite IHa1; rewrite IHa2; reflexivity).
         - reflexivity.
         - destruct a1;
           try (simpl; simpl in IHa1; rewrite IHa1;
                rewrite IHa2; reflexivity).
           + destruct n;
             simpl; rewrite IHa2; reflexivity. Qed.

  Theorem optimize_0plus_sound'' : forall a : aexp,
      aeval (optimize_0plus a) = aeval a.
  Proof.
    intros a.
    induction a;
      try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);
      try reflexivity.
    - destruct a1; try (simpl; simpl in IHa1; rewrite IHa1;
                        rewrite IHa2; reflexivity).
      +destruct n;
        simpl; rewrite IHa2; reflexivity. Qed.

  Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
  Proof.
    repeat (try (left; reflexivity); right).
  Qed.

  Fixpoint optimize_0plus_b (b : bexp) : bexp :=
    match b with
    | BEq a b => BEq (optimize_0plus a) (optimize_0plus b)
    | BLe a b => BLe (optimize_0plus a) (optimize_0plus b)
    | b => b
    end.

  Theorem optimize_0plus_b_sound : forall b,
      beval (optimize_0plus_b b) = beval b.
  Proof. intros b.
         induction b;
           try (reflexivity);
           try (simpl; rewrite IHb1; rewrite IHb2; reflexivity);
           try (simpl; repeat rewrite optimize_0plus_sound; reflexivity).
  Qed.

  Example silly_presburger_example : forall m n o p,
      m + n <= n + o /\ o + 3 = p + 3 ->
      m <= p.
  Proof.
    intros. omega.
  Qed.

  Module aevalR_first_try.
    Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum : forall n : nat,
        aevalR (ANum n) n
    | E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
        aevalR e1 n1 ->
        aevalR e2 n2 ->
        aevalR (APlus e1 e2) (n1 + n2)
    | E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
        aevalR e1 n1 ->
        aevalR e2 n2 ->
        aevalR (AMinus e1 e2) (n1 - n2)
    | E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
        aevalR e1 n1 ->
        aevalR e2 n2 ->
        aevalR (AMult e1 e2) (n1 * n2).

    Notation "e \\ n" := (aevalR e n)
                             (at level 50, left associativity)
                           : type_scope.
  End aevalR_first_try.

  Reserved Notation "e '\\' n" (at level 50, left associativity).

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n : nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where " e \\ n " := (aevalR e n) : type_scope.

  Theorem aeval_iff_aevalR : forall a n,
      a \\ n <-> aeval a = n.
  Proof. intros a n. split.
         -intros H. induction H.
          +reflexivity.
          +simpl. rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
          +simpl. rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
          +simpl. rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
         -generalize dependent n. induction a;
            simpl; intros; subst; constructor;
            try apply IHa1; try apply IHa2; reflexivity.
          Qed.

  Inductive bevalR : bexp -> bool -> Prop :=
  | E_BTrue : bevalR BTrue true
  | E_BFalse : bevalR BFalse false
  | E_BEq : forall (n0 n1 : nat) (a0 a1 : aexp),
      a0 \\ n0 -> a1 \\ n1 -> bevalR (BEq a0 a1) (beq_nat n0 n1)
  | E_BLe : forall (n0 n1 : nat) (a0 a1 : aexp),
      a0 \\ n0 -> a1 \\ n1 -> bevalR (BLe a0 a1) (leb n0 n1)
  | E_BNot : forall (B : bexp) (b : bool), bevalR B b -> bevalR (BNot B) (negb b)
  | E_BAnd : forall (B0 B1 : bexp) (b0 b1 : bool),
      bevalR B0 b0 -> bevalR B1 b1 -> bevalR (BAnd B0 B1) (andb b0 b1).

  Theorem beval_iff_bevalR : forall (b : bexp) (bv : bool),
      bevalR b bv <-> beval b = bv.
  Proof. intros b bv. split.
         -intros H. induction H;
           try (simpl; reflexivity);
           try (simpl; rewrite aeval_iff_aevalR in H;
                rewrite aeval_iff_aevalR in H0; subst;
                reflexivity);
           try (simpl; subst; reflexivity).
         -intros H. generalize dependent bv. induction b;
            intros; destruct bv;
            try (inversion H; constructor; rewrite aeval_iff_aevalR; reflexivity).
            simpl in H.
          ++replace true with (negb false). apply E_BNot. apply IHb.
           apply negb_true_iff in H. apply H. reflexivity.
          *replace false with (negb true). apply E_BNot. apply IHb.
           simpl in H. apply negb_false_iff in H. apply H. reflexivity.
          *simpl in H. rewrite <- H. apply E_BAnd.
           **apply IHb1. reflexivity.
           **apply IHb2. reflexivity.
          *simpl in H. rewrite <- H. apply E_BAnd.
           **apply IHb1. reflexivity.
           **apply IHb2. reflexivity.
  Qed.

End AExp.

Module aevalR_division.

  Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp
  | ADiv: aexp -> aexp -> aexp.

  Reserved Notation "e '\\' n" (at level 50, left associativity).

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n : nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)
  | E_ADiv : forall (a1 a2 : aexp) (n1 n2 n3 : nat),
      a1 \\ n1 -> a2 \\ n2 -> (n2 > 0) ->
      (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3

  where " e \\ n " := (aevalR e n) : type_scope.

End aevalR_division.

Module aevalR_extended.

  Reserved Notation "e \\ n" (at level 50, left associativity).

  Inductive aexp : Type :=
  | AAny : aexp
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_AAny : forall (n : nat), AAny \\ n
  | E_ANum : forall (n : nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult : forall (e1 e2 : aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where " e \\ n " := (aevalR e n) : type_scope.

End aevalR_extended.

Definition state := total_map nat.

Definition empty_state : state := t_empty 0.

Inductive aexp : Type :=
| ANum : nat -> aexp
| AId : id -> aexp
| APlus : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp.

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".

Inductive bexp : Type :=
| BTrue : bexp
| BFalse : bexp
| BEq : aexp -> aexp -> bexp
| BLe : aexp -> aexp -> bexp
| BNot : bexp -> bexp
| BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2 => leb (aeval st a1) (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Example aexp1 :
  aeval (t_update empty_state X 5)
        (APlus (ANum 3) (AMult (AId X) (ANum 2))) = 13.
Proof. reflexivity. Qed.

Example bexp1 :
  beval (t_update empty_state X 5)
        (BAnd BTrue (BNot (BLe (AId X) (ANum 4)))) = true.
Proof. reflexivity. Qed.

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

Notation "'SKIP'" := (CSkip).
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
  END.

Fixpoint ceval_fun_no_while (st : state) (c : com) : state :=
  match c with
  | SKIP => st
  | x ::= a1 => t_update st x (aeval st a1)
  | c1 ;; c2 =>
    let st' := ceval_fun_no_while st c1 in
    ceval_fun_no_while st' c2
  | IFB b THEN c1 ELSE c2 FI =>
    if (beval st b)
    then ceval_fun_no_while st c1
    else ceval_fun_no_while st c2
  | WHILE b DO c END =>
    st (* bogus *)
  end.

Reserved Notation "c '/' st '\\' st'" (at level 40, st at level 39).

Inductive ceval_funR : com -> state -> state -> Prop :=
| E_Skip : forall s,
    SKIP / s \\ s
| E_Ass : forall st a1 n x,
    aeval st a1 = n ->
    (x ::= a1) / st \\ (t_update st x n)
| E_Seq : forall c1 c2 st st' st'',
    c1 / st \\ st' ->
    c2 / st' \\ st'' ->
    (c1 ;; c2) / st \\ st''
| E_IfTrue : forall c1 c2 b st st',
    c1 / st \\ st' ->
    beval st b = true ->
    IFB b THEN c1 ELSE c2 FI / st \\ st'
| E_IfFalse : forall c1 c2 b st st',
    c2 / st \\ st' ->
    beval st b = false ->
    IFB b THEN c1 ELSE c2 FI/ st \\ st'
| E_WhileEnd : forall c1 b st,
    beval st b = false ->
    WHILE b DO c1 END / st \\ st
| E_WhileLoop : forall c1 b st st' st'',
    beval st b = true ->
    c1 / st \\ st' ->
    WHILE b DO c1 END / st' \\ st'' ->
    WHILE b DO c1 END / st \\ st''

    where " c '/' st '\\' st' " := (ceval_funR c st st') : type_scope.

Example ceval_example2 :
  (X ::= ANum 0;; Y ::= ANum 1;; Z ::= ANum 2) / empty_state \\
  (t_update (t_update (t_update empty_state X 0) Y 1) Z 2).
Proof. apply E_Seq with (st' := (t_update empty_state X 0)).
       apply E_Ass. reflexivity.
       apply E_Seq with (st' := (t_update (t_update empty_state X 0) Y 1)).
       apply E_Ass. reflexivity.
       apply E_Ass. reflexivity.
Qed.

Definition pup_to_n : com :=
  (Y ::= ANum 0;;
   WHILE (BNot (BEq (AId X) (ANum 0))) DO
         Y ::= APlus (AId Y) (AId X);;
         X ::= AMinus (AId X) (ANum 1)
   END).

Theorem pup_to_2_ceval :
  pup_to_n / (t_update empty_state X 2) \\
           t_update (t_update (t_update (t_update (t_update (t_update
           empty_state X 2) Y 0) Y 2) X 1) Y 3) X 0.
Proof. unfold pup_to_n.
       apply E_Seq with (st' := (t_update (t_update empty_state X 2) Y 0)).
       -apply E_Ass. reflexivity.
       -apply E_WhileLoop with (st' := (t_update (t_update (t_update (t_update empty_state X 2) Y 0) Y 2) X 1)).
        reflexivity.
        apply E_Seq with (st' := (t_update (t_update (t_update
                          empty_state X 2) Y 0) Y 2)).
        apply E_Ass. reflexivity. apply E_Ass. reflexivity.
        apply E_WhileLoop with (st' := (t_update (t_update (t_update (t_update (t_update (t_update
                                empty_state X 2) Y 0) Y 2) X 1) Y 3) X 0)).
        reflexivity.
        apply E_Seq with (st' := (t_update (t_update (t_update (t_update (t_update
                          empty_state X 2) Y 0) Y 2) X 1) Y 3)).
        apply E_Ass. reflexivity.
        apply E_Ass. reflexivity.
        apply E_WhileEnd. reflexivity.
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.
       induction E1; intros st2 E2; inversion E2; subst.
       -reflexivity.
       -reflexivity.
       -assert (st' = st'0) as EQ1.
        { apply IHE1_1; assumption. }
        subst st'0.
        apply IHE1_2. assumption.
       -apply IHE1. assumption.
       -rewrite H in H6. inversion H6.
       -rewrite H in H6. inversion H6.
       - apply IHE1. assumption.
       - reflexivity.
       - rewrite H in H2. inversion H2.
       - rewrite H in H4. inversion H4.
       - apply IHE1_1 in H3. rewrite <- H3 in H6.
         apply IHE1_2 in H6. apply H6.
Qed.

Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).
Theorem plus2_spec : forall st n st',
    st X = n ->
    plus2 / st \\ st' ->
    st' X = n + 2.
Proof. intros st n st' HX Heval. inversion Heval.
       subst. clear Heval. simpl. apply t_update_eq. Qed.

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).
Theorem XtimesYinZ_spec : forall st st' n n',
    st X = n -> st Y = n' ->
    XtimesYinZ / st \\ st' ->
    st' Z = n * n'.
Proof. intros st st' n n' HX HY Heval.
       inversion Heval. subst. simpl. apply t_update_eq.
Qed.

Definition loop : com :=
  WHILE BTrue DO SKIP END.
Theorem loop_never_stops : forall st st',
    ~ (loop / st \\ st').
Proof. intros st st' contra. unfold loop in contra.
       remember(WHILE BTrue DO SKIP END) as loopdef
                eqn:Heqloopdef.
       induction contra; try inversion Heqloopdef.
       +rewrite H1 in H. inversion H.
       +apply IHcontra2. apply Heqloopdef.
Qed.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP
  | _ ::= _ => true
  | c1 ;; c2
  | IFB _ THEN c1 ELSE c2 FI => andb (no_whiles c1) (no_whiles c2)
  | WHILE _ DO _ END => false
  end.

Inductive no_whilesR : com -> Prop :=
| no_whiles_SKIP : no_whilesR SKIP
| no_whiles_CAss : forall i x, no_whilesR (i ::= x)
| no_whiles_CSeq : forall x1 x2,
    no_whilesR x1 -> no_whilesR x2 -> no_whilesR (x1 ;; x2)
| no_whiles_CIFB :  forall x1 x2,
    no_whilesR x1 -> no_whilesR x2 -> (forall b, no_whilesR (IFB b THEN x1 ELSE x2 FI)).

(* first in front of [ ] notation *)
Theorem no_whiles_eqv :
  forall c, no_whiles c = true <-> no_whilesR c.
Proof. intros c. split; intros H. induction c.
       - apply no_whiles_SKIP.
       - apply no_whiles_CAss.
       - simpl in H. rewrite andb_true_iff in H. destruct H. apply no_whiles_CSeq.
            apply IHc1. apply H. apply IHc2. apply H0.
       - simpl in H. rewrite andb_true_iff in H. destruct H. apply no_whiles_CIFB.
            apply IHc1. apply H. apply IHc2. apply H0.
       - inversion H.
       - induction c; try (simpl; reflexivity).
         * inversion H. subst. apply IHc1 in H2. apply IHc2 in H3.
           simpl. apply andb_true_iff. split. apply H2. apply H3.
         * inversion H. subst. apply IHc1 in H2. apply IHc2 in H4.
           simpl. apply andb_true_iff. split. apply H2. apply H4.
         * inversion H.
Qed.
(*dependent pattern matching / when to use eqn
  Searching for proofs : ctrl-c ctrl-a then ctrl-a
*)
Theorem no_whiles_terminating : forall c, no_whilesR c ->
        (forall s1, (exists s2, c / s1 \\ s2)).
Proof. intros c H. induction H; intros.
       -exists s1. constructor.
       -exists (t_update s1 i (aeval s1 x)). constructor. reflexivity.
       -destruct IHno_whilesR1 with (s1 := s1).
        destruct IHno_whilesR2 with (s1 := x). exists x0.
        apply E_Seq with (st' := x). apply H1. apply H2.
       -destruct (beval s1 b) eqn:?;
        [destruct IHno_whilesR1 with (s1:=s1) | destruct IHno_whilesR2 with (s1:=s1)];
        exists x; [apply E_IfTrue | apply E_IfFalse]; try apply H1; try apply Heqb0.
Qed.

Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

Fixpoint s_execute (st : state) (stack : list nat)
                   (prog : list sinstr)
                   : list nat :=
  match prog, stack with
  | SPush n :: t, _  => s_execute st (n :: stack) t
  | SLoad i :: t, _  => s_execute st (st i :: stack) t
  | SPlus :: t, h :: h' :: t' => s_execute st ((h' + h) :: t') t
  | SMinus :: t, h :: h' :: t' => s_execute st ((h' - h) :: t') t
  | SMult :: t, h :: h' :: t' => s_execute st ((h' * h) :: t') t
  | _ , _ => stack
  end.

Example s_execute1 :
  s_execute empty_state []
            [SPush 5; SPush 3; SPush 1; SMinus]
  = [2 ; 5].
Proof. reflexivity. Qed.

Example s_execute2 :
  s_execute (t_update empty_state X 3) [3 ; 4]
            [SPush 4; SLoad X; SMult; SPlus]
  = [15 ; 4].
Proof. reflexivity. Qed.

Fixpoint s_compile (e : aexp) : list sinstr :=
  match e with
  | ANum n => SPush n :: nil
  | AId i => SLoad i :: nil
  | APlus a b => (s_compile a) ++ (s_compile b) ++ [SPlus]
  | AMinus a b => (s_compile a) ++ (s_compile b) ++ [SMinus]
  | AMult a b => (s_compile a) ++ (s_compile b) ++ [SMult]
  end.

Example s_compile1 :
  s_compile (AMinus (AId X) (AMult (ANum 2) (AId Y)))
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
Proof. reflexivity. Qed.
(* this is too hard to prove!
Lemma s_compile_plus : forall (st : state) (a b a' b': aexp) (na nb : list nat),
    s_execute st na (s_compile a) = [aeval st a'] ->
    s_execute st nb (s_compile b) = [aeval st b'] ->
    s_execute st (na ++ nb) (s_compile a ++ s_compile b ++ [SPlus]) = [aeval st (APlus a' b')].
Proof. intros st a b a' b' na nb Ha Hb.
 *)

Lemma s_execute_args : forall (st : state) (e : aexp) (l : list nat) (p : list sinstr),
    s_execute st l (s_compile e ++ p) =
    s_execute st (s_execute st [] (s_compile e) ++ l) p.
Proof. intros st e. induction e.
       -reflexivity.
       -reflexivity.
       -intros l p. simpl.

Lemma s_execute_nat : forall (st : state) (e : aexp),
    (exists n : nat, s_execute st [] (s_compile e) = [n]).
Proof. intros st e. induction e as [ n | i | | IHe1 | IHe2];
         [exists n | exists (st i) | | | ]; try reflexivity.
       -

Theorem s_compile_correct : forall (st : state) (e : aexp),
    s_execute st [] (s_compile e) = [ aeval st e ].
Proof. intros st e.


Require Export GSM.

Set Implicit Arguments.
Unset Strict Implicit.

Inductive form :=
    | Var : var -> form
    | Bot : form
    | Imp : form -> form -> form
    | AX : act -> form -> form
    | AG : form -> form
    | EG : form -> form.

Definition Not A := Imp A Bot.
Definition Top := Not Bot.
Definition Or A B := Imp (Not A) B.
Definition And A B := Not (Imp A (Not B)).
Definition EX a A := Not (AX a (Not A)).
Definition AF A := Not (EG (Not A)).

Inductive step (a : act) : state -> state -> Prop :=
    | here s : step a s s
    | there b s t r : trans a s t -> step b t r -> step a s r.

Fixpoint eval (e : form) (s : state) : Prop :=
    match e with
    | Var n => valuation n s
    | Bot => False
    | Imp e1 e2 => eval e1 s -> eval e2 s
    | AX a e' => forall s', trans a s s' -> eval e' s'
    | AG e' => forall a s', step a s s' -> eval e' s'
    | EG e' => exists a s', eval e' s' /\ (forall t, step a s t -> step a t s' -> eval e' t)
    end.

Notation "s |= e" := (eval e s)(at level 80).
Notation "⊤" := Top.
Notation "⊥" := Bot.
Notation "¬ e" := (Not e)(at level 10).
Notation "e1 ∧ e2" := (And e1 e2) (at level 30).
Notation "e1 ∨ e2" := (Or e1 e2) (at level 30).
Notation "[ a ] e" :=(AX a e)(at level 20).
Notation "< a > e" := (EX a e) (at level 20).
Notation "e1 → e2" := (Imp e1 e2) (at level 50).


Require Import Basics.
Require Import Types.
Require Import Colimits.Pushout.
Require Import Colimits.SpanPushout.
Require Import HoTT.Truncations.
Require Import Homotopy.Join.
Require Import Homotopy.Suspension.
Require Import Homotopy.BlakersMassey.

Import TrM.

(** * The Freudenthal Suspension Theorem *)

(** The Freudenthal suspension theorem is a fairly trivial corollary of the Blakers-Massey theorem.  The only real work is to relate the span-pushout that we used for Blakers-Massey to the naive pushout that we used to define suspension. *)

Global Instance freudenthal `{Univalence} (n : trunc_index)
           (X : Type) `{IsConnected n.+1 X}
  : IsConnMap (n +2+ n) (@merid X).
Proof.
  pose (blakers_massey n n (fun (u v:Unit) => X) tt tt).
  pose (f := equiv_pushout (equiv_contr_sigma (fun _ : Unit * Unit => X))^-1
                           (equiv_idmap Unit) (equiv_idmap Unit)
                           (fun x : X => idpath) (fun x : X => idpath)
        : Susp X <~> SPushout (fun (u v:Unit) => X)).
  srefine (@cancelR_equiv_conn_map (n +2+ n) _ _ _ _
             (equiv_ap' f North South)
             (@conn_map_homotopic _ _ _ _ _ _
               (blakers_massey n n (fun (u v:Unit) => X) tt tt))).
  intros x.
  refine (_ @ (equiv_pushout_pglue
                 (equiv_contr_sigma (fun _ : Unit * Unit => X))^-1
                 (equiv_idmap Unit) (equiv_idmap Unit)
                 (fun x : X => idpath) (fun x : X => idpath) x)^).
  exact ((concat_p1 _ @ concat_1p _)^).
Defined.


Require Export Arith.
Require Export ArithRing.
Require Export Wf_nat.
Require Export fib_ind fib_positive.

(* The preliminary theorems are already in the exercise fib_positive. *)

Theorem div2_rec:
 forall (P : nat ->  Set),
 P 0 -> P 1 -> (forall n, P n ->  P (S (S n))) -> forall (n : nat),  P n.
Proof.
intros P H0 H1 Hrec n; assert (P n * P (S n))%type.
- elim n; intuition.
- intuition.
Qed.

Theorem div2_spec:
 forall n,  ({x : nat | 2 * x = n}) + ({x : nat | 2 * x + 1 = n}).
Proof.
  intros n; induction n as  [| | n IHn]  using div2_rec.
  - left; now exists 0.
  - right; now exists 0.
  - destruct IHn as  [[x Heq]|[x Heq]].
    + left; exists (S x); rewrite <- Heq; ring.
    + right; exists (S x); rewrite <- Heq; ring.
Qed.

Theorem half_smaller0: forall n x, 2 * x = S n ->  (x < S n).
Proof.
intros; omega.
Qed.

Theorem half_smaller1: forall n x, 2 * x + 1 = n ->  (x < n).
Proof.
intros; omega.
Qed.

Definition fib_log_F:
 forall (x : nat),
 (forall (y : nat),
  y < x ->  ({u : nat & {v : nat | u = fib y /\ v = fib (S y)}})) ->
  ({u : nat & {v : nat | u = fib x /\ v = fib (S x)}}).
intros [|x'].
- intros _; exists 1, 1; auto.
- destruct (div2_spec (S x')) as [[half_sx' Heq]|[half_x' Heq]]; intros fib_log.
  + destruct (fib_log half_sx' (half_smaller0 _ _ Heq)) as [u [v [Heq1 Heq2]]].
    rewrite <- Heq;exists (u * u + (v - u) * (v - u)),
                          ((2 * u) * v - u * u).
    rewrite Heq1; rewrite Heq2; split.
    *  replace (S half_sx') with (half_sx' + 1) by ring.
    now rewrite <- fib_2n.
    *  replace (S half_sx') with (half_sx' + 1) by ring.
       rewrite <- fib_2n_plus_1;
         replace (2 * half_sx' + 1) with (S (2 * half_sx')) by ring.
       trivial.
  + destruct (fib_log half_x' (half_smaller1 _ _ Heq)) as [u [v [Heq1 Heq2]]].
   rewrite <- Heq.
   exists ((2 * u) * v - u * u), (v * v + u * u).
   rewrite Heq1; rewrite Heq2; split.
   * replace (S half_x') with (half_x' + 1) by ring.
     now rewrite <- fib_2n_plus_1.
   * replace (S half_x') with (half_x' + 1) by ring.
     now rewrite <- fib_2n_plus_2.
Qed.

Definition fib_log :
  forall (x : nat),  ({u : nat & {v : nat | u = fib x /\ v = fib (S x)}}) :=
   well_founded_induction
    lt_wf (fun x => {u : nat & {v : nat | u = fib x /\ v = fib (S x)}})
    fib_log_F.

(** Test :
Recursive Extraction fib_log.

*)