Require Export SfLib_J.

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

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

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

  Example test_aeval1: aeval(APlus (ANum 2) (ANum 2)) = 4.
  Proof. reflexivity. Qed.

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

  Fixpoint optimize_0plus (e:aexp) : aexp :=
    match e 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 e,
                                  aeval (optimize_0plus e) = aeval e.
    Proof.
      intros e. induction e.
      + reflexivity.
      + destruct e1.
      - destruct n.
        apply IHe2.
        simpl. rewrite IHe2. reflexivity.
      - simpl. simpl in IHe1. rewrite IHe1. rewrite IHe2. reflexivity.
      - simpl. simpl in IHe1. rewrite IHe1. rewrite IHe2. reflexivity.
      - simpl. simpl in IHe1. rewrite IHe1. rewrite IHe2. reflexivity.
        + simpl. rewrite IHe1. rewrite IHe2. reflexivity.
        + simpl. rewrite IHe1. rewrite IHe2. reflexivity.
    Qed.

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

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

    Theorem optimize_0plus_sound': forall e,
                                     aeval (optimize_0plus e) = aeval e.
    Proof.
      intros e.
      induction e;
        try (simpl; rewrite IHe1; rewrite IHe2; reflexivity).
      Case "ANum". reflexivity.
      Case "APlus".
      destruct e1; try (simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; reflexivity).
      SCase "e1 = ANum n". destruct n; simpl; rewrite IHe2; reflexivity. Qed.

    Theorem optimize_0plus_sound'': forall e,
                                      aeval (optimize_0plus e) = aeval e.
    Proof.
      intros e.
      induction e;
        try (simpl; rewrite IHe1; rewrite IHe2; reflexivity);
        try reflexivity.
      Case "APlus".
      destruct e1; try (simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; reflexivity).
      SCase "e1 = ANum n". destruct n; simpl; rewrite IHe2; reflexivity. Qed.

    Tactic Notation "simpl_and_try" tactic(c) := simpl; try c.

    Tactic Notation "aexp_cases" tactic(first) ident(c) :=
      first;
      [Case_aux c "ANum" | Case_aux c "APlus"
       | Case_aux c "AMinus" | Case_aux c "AMult"].

    Theorem optimize_0plus_sound''': forall e,
                                       aeval (optimize_0plus e) = aeval e.
    Proof.
      intros e.
      aexp_cases (induction e) Case;
        try (simpl; rewrite IHe1; rewrite IHe2; reflexivity);
        try reflexivity.
      Case "APlus".
      aexp_cases (destruct e1) SCase;
        try (simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; reflexivity).
      SCase "ANum". destruct n;
        simpl; rewrite IHe2; reflexivity. Qed.

    Fixpoint optimize_0plus_b (e: bexp) : bexp :=
      match e with
        | BTrue => BTrue
        | BFalse => BFalse
        | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
        | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
        | BNot b1 => BNot (optimize_0plus_b b1)
        | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
      end.

    Theorem optimize_0plus_b_sound: forall e, beval (optimize_0plus_b e) = beval e.
    Proof.
      intros e.
      induction e;
        simpl;
        try (rewrite optimize_0plus_sound;
                     rewrite optimize_0plus_sound;
                     reflexivity);
        try reflexivity.
      rewrite IHe. reflexivity.
      rewrite IHe1. rewrite IHe2. reflexivity.
    Qed.

    Example silly_presburger_example: forall n m 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) : 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.

    Tactic Notation "aevalR_cases" tactic(first) ident(c) :=
      first;
      [ Case_aux c "E_ANum" | Case_aux c "E_APlus" | Case_aux c "E_AMinus" | Case_aux c "E_AMult"].

    Theorem aeval_iff_aevalR: forall a n,
                                (a || n) <-> aeval a = n.
    Proof.
      split.
      Case "->".
      intros H; induction H; subst; reflexivity.
      Case "<-".
      generalize dependent n.
      induction a; simpl; intros; subst; constructor;
      try apply IHa1; try apply IHa2; reflexivity.
    Qed.

End AExp.

Theorem beq_id_refl: forall X,
                       true = beq_id X X.
Proof.
  intros. destruct X.
  apply beq_nat_refl.
Qed.

Theorem beq_id_eq: forall i1 i2,
                     true = beq_id i1 i2 -> i1 = i2.
Proof.
  intros i1 i2.
  destruct i1.
  destruct i2.
  unfold beq_id.
  intros H.
  apply beq_nat_eq in H.
  subst.
  reflexivity.
Qed.

Definition state := id -> nat.
Definition empty_state: state :=
  fun _ => 0.
Definition update (st: state) (X: id) (n: nat) : state :=
  fun X' => if beq_id X X' then n else st X'.

Theorem update_eq: forall n X st,
                     (update st X n) X = n.
Proof.
  intros n X st.
  unfold update. replace (beq_id X X) with true.
  reflexivity.
  apply beq_id_refl.
Qed.

Theorem update_neq:forall V2 V1 n st,
                     beq_id V2 V1 = false ->
                     (update st V2 n) V1 = (st V1).
Proof.
  intros V2 V1 n st H.
  unfold update.
  rewrite H.
  reflexivity.
Qed.

Theorem update_example: forall (n: nat),
                          (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intros n.
  unfold update. simpl. unfold empty_state. reflexivity.
Qed.

Theorem update_shadow: forall x1 x2 k1 k2 (f: state),
                         (update (update f k2 x1) k2 x2) k1 = (update f k2 x2) k1.
Proof.
  intros x1 x2 k1 k2 f.
  unfold update.
  case (beq_id k2 k1).
  + reflexivity.
  + reflexivity.
Qed.

Theorem update_some: forall x1 k1 k2 (f: state),
                       f k1 = x1 -> (update f k1 x1) k2 = f k2.
Proof.
  intros x1 k1 k2 f H.
  unfold update.
  subst.
  remember (beq_id k1 k2) as H.
  destruct H.
  replace k1 with k2. reflexivity.
  apply beq_id_eq. rewrite beq_id_sym.
  apply HeqH. reflexivity.
Qed.

Theorem update_permute: forall x1 x2 k1 k2 k3 f,
                          beq_id k2 k1 = false ->
                          (update (update f k2 x1) k1 x2) k3 = (update (update f k1 x2) k2 x1) k3.
Proof.
  intros x1 x2 k1 k2 k3 f H.
  unfold update.
  remember (beq_id k1 k3) as A.
  remember (beq_id k2 k3) as B.
  destruct A.
  replace k3 with k1 in HeqB.
  rewrite H in HeqB.
  subst. reflexivity.
  apply beq_id_eq. apply HeqA.
  reflexivity.
Qed.

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

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [Case_aux c "ANum" | Case_aux c "AId" | Case_aux c "APlus"
   |Case_aux c "AMinus" | Case_aux c "AMult"].

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

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

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" | Case_aux c "BEq"
    | Case_aux c "BLe" | Case_aux c "BNot" | Case_aux c "BAnd" ].

Fixpoint aeval (st: state) (e: aexp): nat :=
  match e 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)  (e: bexp) : bool :=
  match e with
    | BTrue => true
    | BFalse => false
    | BEq a1 a2 => beq_nat (aeval st a1) (aeval st a2)
    | BLe a1 a2 => ble_nat (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 (update empty_state X 5)
        (APlus (ANum 3) (AMult (AId X) (ANum 2)))
        = 13.
Proof. reflexivity. Qed.

Example bexp1: beval (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.

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"].

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' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (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.

Definition plus2: com :=
  X ::= (APlus (AId X) (ANum 2)).

Definition XtimesYinZ: com :=
  Z ::= (AMult (AId X) (AId Y)).

Definition substract_slowly_body : com :=
  Z ::= AMinus (AId Z) (ANum 1);
  X ::= AMinus (AId X) (ANum 1).

Definition substract_slowly: com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
        substract_slowly_body
  END.

Definition substract_3_from_5_slowly: com :=
  X ::= ANum 3;
  Z ::= ANum 5;
  substract_slowly.

Definition loop : com :=
  WHILE BTrue DO
        SKIP
  END.

Definition fact_body: com :=
  Y ::= AMult (AId Y) (AId Z);
  Z ::= AMinus (AId Z) (ANum 1).

Definition fact_loop: com :=
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
        fact_body
  END.

Definition fact_com : com :=
  Z ::= AId X;
  Y ::= ANum 1;
  fact_loop.

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

Fixpoint ceval_step2 (st: state) (c: com) (i: nat) : state :=
  match i with
    | O => empty_state
    | S i' =>
      match c with
        | SKIP =>
          st
        | l ::= a1 =>
          update st l (aeval st a1)
        | c1 ; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step1 st' c2
        | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
          then ceval_step2 st c1 i'
          else ceval_step2 st c2 i'
        | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
      end
  end.

Fixpoint ceval_step3 (st: state) (c: com) (i: nat)
: option state :=
  match i with
    | O => None
    | S i' =>
      match c with
        | SKIP =>
          Some st
        | l ::= a1 =>
          Some (update st l (aeval st a1))
        | c1 ; c2 =>
          match (ceval_step3 st c1 i') with
            | Some st' => ceval_step3 st' c2 i'
            | None => None
          end
        | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
          then ceval_step3 st c1 i'
          else ceval_step3 st c2 i'
        | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
                 | Some st' => ceval_step3 st' c i'
                 | None => None
               end
          else Some st
      end
  end.

Notation "'LETOPT' x <== e1 'IN' e2"
  := (match e1 with
        | Some x => e2
        | None => None
      end)
       (right associativity, at level 60).

Fixpoint ceval_step (st: state) (c: com) (i: nat)
: option state :=
  match i with
    | O => None
    | S i' =>
      match c with
        | SKIP =>
          Some st
        | l ::= a1 =>
          Some (update st l (aeval st a1))
        | c1 ; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
                 ceval_step st' c2 i'
        | IFB b THEN c1 ELSE c2 FI =>
              if (beval st b)
              then ceval_step st c1 i'
              else ceval_step st c2 i'
        | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
                      ceval_step st' c i'
          else Some st
      end
  end.

Definition test_ceval (st: state) (c: com) :=
  match ceval_step st c 500 with
    | None => None
    | Some st => Some (st X, st Y, st Z)
  end.

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

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

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

  where "c1 '/' st '||' st'" := (ceval c1 st 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" ].

Example ceval_example1:
  (X ::= ANum 2;
   IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
    FI)
    / empty_state
    || (update (update empty_state X 2) Z 4).
Proof.
  apply E_Seq with (update empty_state X 2).
  apply E_Ass. reflexivity.
  apply E_IfFalse. reflexivity.
  apply E_Ass. reflexivity.
Qed.

Theorem ceval_step__ceval: forall c st st',
                             (exists i, ceval_step st c i = Some st') ->
                             c / st || st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i'].

  Case "i = 0 -- contradictory".
  intros c st st' H. inversion H.
  Case "i = S i'".
  intros c st st' H.
  com_cases (destruct c) SCase;
    simpl in H; inversion H; subst; clear H.
  SCase "SKIP". apply E_Skip.
  SCase "::=". apply E_Ass. reflexivity.
  SCase ";".
  remember (ceval_step st c1 i') as r1. destruct r1.
  SSCase "Evaluation of r1 terminates normally".
  apply E_Seq with s.
  apply IHi'. rewrite Heqr1. reflexivity.
  apply IHi'. assumption.
  SSCase "Othervise --contradiction".
  inversion H1.
  SCase "IFB".
  remember (beval st b) as r. destruct r.
  SSCase "r = true".
  apply E_IfTrue. rewrite Heqr. reflexivity.
  apply IHi'. assumption.
  SSCase "r = false".
  apply E_IfFalse. rewrite Heqr. reflexivity.
  apply IHi'. assumption.
  SCase "WHILE". remember (beval st b) as r. destruct r.
  SSCase "r = true".
  remember (ceval_step st c i') as r1. destruct r1.
  SSSCase "r1 = Some s".
  apply E_WhileLoop with s. rewrite Heqr. reflexivity.
  apply IHi'. rewrite Heqr1. reflexivity.
  apply IHi'. assumption.
  SSSCase "r1 = None".
  inversion H1.
  SSCase "r = false".
  inversion H1.
  apply E_WhileEnd. rewrite Heqr. subst.
  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.
  ceval_cases (induction E1) Case; intros st2 E2; inversion E2; subst.
  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 "b1 evaluates to true".
  apply IHE1. assumption.
  SCase "b1 evaluates to false (contradiction)".
  rewrite H in H5. inversion H5.
  Case "E_IfFalse".
  SCase "b1 evaluates to true (contradiction)".
  rewrite H in H5. inversion H5.
  SCase "b1 evaluates to false".
  apply IHE1. assumption.
  Case "E_WhileEnd".
  SCase "b1 evaluates to true".
  reflexivity.
  SCase "b1 evaluates to false (contradiction)".
  rewrite H in H2. inversion H2.
  Case "E_WhileLoop".
  SCase "b1 evaluates to true (contradiction)".
  rewrite H4 in H. inversion H.
  SCase "b1 evaluates to false".
  assert (st' = st'0) as EQ1.
  SSCase "Proof of assertion". apply IHE1_1; assumption.
  subst st'0. apply IHE1_2. assumption.
Qed.

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.
  apply update_eq.
Qed.

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.
  rewrite Heqloopdef in contra. inversion contra.
  subst. inversion H3.
  subst. inversion H2. subst.
Admitted.

Fixpoint no_whiles (c: com): bool :=
  match c with
    | SKIP => true
    | _ ::= _ => true
    | c1 ; c2 => andb (no_whiles c1) (no_whiles c2)
    | IFB _ THEN ct ELSE cf FI => andb (no_whiles ct) (no_whiles cf)
    | WHILE _ DO _ END => false
  end.
Theorem no_whiles_termnating: forall com st,
                                no_whiles com = true ->  exists st', com / st || st'.
Proof.
  intros com st H.
  generalize dependent st.
  induction com; intros st.
  + exists st. apply E_Skip.
  + exists (update st i (aeval st a)).
    apply E_Ass. reflexivity.
  + inversion H. remember (no_whiles com1) as r.
    destruct r. simpl in H1. rewrite H1 in IHcom2.
    destruct IHcom1 with st. reflexivity.
    destruct IHcom2 with x. reflexivity.
    exists x0.
    apply E_Seq with x.
    assumption. assumption. inversion H1.
  + destruct b.
    destruct IHcom1 with st. inversion H.
    rewrite H1. unfold andb in H1. remember (no_whiles com1) as r.
    destruct r. reflexivity. inversion H1.
    exists x. apply E_IfTrue. reflexivity. assumption.
    destruct IHcom2 with st. inversion H.
    rewrite H1. unfold andb in H1. remember (no_whiles com1) as r.
    destruct r. assumption. inversion H1.
    exists x. apply E_IfFalse. reflexivity. assumption.
    remember (BEq a a0). destruct b.
Admitted.

Print fact_body.
Print fact_loop.
Print fact_com.

Fixpoint real_fact (n: nat): nat :=
  match n with
    | O => 1
    | S n' => n * (real_fact n')
  end.

Definition fact_invariant (x: nat) (st: state) :=
  (st Y) * (real_fact (st Z)) = real_fact x.

Theorem fact_body_preserves_invariant: forall st st' x,
                                         fact_invariant x st ->
                                         st Z <> 0 ->
                                         fact_body / st || st' ->
                                         fact_invariant x st'.
Proof.
  unfold fact_invariant, fact_body.
  intros st st' x Hm HZnz He.
  inversion He; subst; clear He.
  inversion H1; subst; clear H1.
  inversion H4; subst; clear H4.
  unfold update. simpl.
  destruct (st Z) as [| z'].
  apply ex_falso_quodlibet. apply HZnz. reflexivity.
  rewrite <- Hm. rewrite <- mult_assoc.
  replace (S z' - 1) with z' by omega.
  reflexivity.
Qed.

Theorem fact_loop_preserves_invariant: forall st st' x,
                                         fact_invariant x st ->
                                         fact_loop / st || st' ->
                                         fact_invariant x st'.
Proof.
  intros st st' x H Hce.
  remember fact_loop as c.
  ceval_cases (induction Hce) Case;
    inversion Heqc; subst; clear Heqc.
  Case "E_WhileEnd".
  assumption.
  Case "E_WhileLoop".
  apply IHHce2.
  apply fact_body_preserves_invariant with st;
    try assumption.
  intros contra. simpl in H0; subst.
  rewrite contra in H0. inversion H0.
  reflexivity.
Qed.

Theorem guard_false_after_loop: forall b c st st',
                                  (WHILE b DO c END) / st || st' ->
                                  beval st' b = false.
Proof.
  intros b c st st' Hce.
  remember (WHILE b DO c END) as cloop.
  ceval_cases(induction Hce) Case;
    inversion Heqcloop; subst; clear Heqcloop.
  Case "E_WhileEnd".
  assumption.
  Case "E_WhileLoop".
  apply IHHce2. reflexivity.
Qed.

Theorem fact_com_correct: forall st st' x,
                            st X = x ->
                            fact_com / st || st' ->
                            st' Y = real_fact x.
Proof.
  intros st st' x HX Hce.
  inversion Hce; subst; clear Hce.
  inversion H1; subst; clear H1.
  inversion H4; subst; clear H4.
  inversion H1; subst; clear H1.
  rename st' into st''. simpl in H5.
  remember (update (update st Z (st X)) Y 1) as st'.
  assert (fact_invariant (st X) st').
  subst. unfold fact_invariant, update. simpl. omega.
  assert (fact_invariant (st X) st'').
  apply fact_loop_preserves_invariant with st'; assumption.
  unfold fact_invariant in H0.
  apply guard_false_after_loop in H5. simpl in H5.
  destruct (st'' Z).
  Case "st'' Z = 0". simpl in H0. omega.
  Case "st'' Z > 0 (impossible)". inversion H5.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Import Coq.Lists.List.ListNotations.

Require Import BWT.Sorting.Ord.
Require Import BWT.Sorting.Sorted.
Require Import BWT.Sorting.StablePerm.
Require Import BWT.Sorting.Sort.
Require Import BWT.Lib.Sumbool.
Require Import BWT.Lib.Permutation.

Section InsertionSort.
  Context {A : Type} {O : Preord A}.

  Fixpoint insert (x : A) (l : list A) :=
    match l with
    | [] => [x]
    | h :: t =>
      if le_dec x h then x :: h :: t else h :: insert x t
    end.

  Fixpoint sort (l : list A) : list A :=
    match l with
    | [] => []
    | h :: t => insert h (sort t)
    end.

  Remark sort_fold_right : forall l,
      sort l = fold_right insert [] l.
  Proof. reflexivity. Qed.

  Lemma insert_perm: forall x l,
      Permutation (x :: l) (insert x l).
  Proof.
    intros; revert x; induction l as [|h t IH]; intros x;
      [reflexivity|].
    cbn. destruct (le_dec x h); [reflexivity|].
    rewrite perm_swap.
    apply Permutation_cons; [easy|apply IH].
  Qed.

  Theorem sort_perm: forall l, Permutation l (sort l).
  Proof.
    induction l as [|h t IH]; [reflexivity|].
    cbn.
    transitivity (h :: sort t); [apply perm_skip; easy|].
    apply insert_perm.
  Qed.

  Lemma insert_forall_le : forall x l,
      Forall (le x) l -> insert x l = x :: l.
  Proof.
    intros x l HF.
    destruct l as [|h t]; [easy|].
    cbn. rewrite if_true by (eapply Forall_inv; apply HF).
    reflexivity.
  Qed.

  Lemma insert_sorted: forall x l,
      Sorted l -> Sorted (insert x l).
  Proof.
    intros x l Sl; revert x.
    induction Sl as [|h t HF HS IH]; intros x; [apply Sorted_1|].
    cbn; destruct (le_dec x h).
    - revert IH; setoid_rewrite SortedLocal_iff; intros IH.
      apply SortedLocal_cons; [|easy].
      rewrite <- insert_forall_le by easy.
      apply IH.
    - apply Sorted_cons; [|easy].
      apply Permutation_forall with (l := x :: t);
        [apply insert_perm|].
      constructor; [apply lt_le; easy|easy].
  Qed.

  Theorem sort_sorted: forall l, Sorted (sort l).
  Proof.
    induction l as [|h t IH]; [apply Sorted_nil|].
    cbn. apply insert_sorted. apply IH.
  Qed.

  Lemma insert_stable : forall x l,
      @StablePerm A eqv _ _ (x :: l) (insert x l).
  Proof.
    induction l as [|h t]; [apply StablePerm_skip; reflexivity|].
    cbn. destruct (le_dec x h); [reflexivity|].
    transitivity (h :: x :: t).
    apply StablePerm_swap.
    intros []; contradiction.
    apply StablePerm_skip. easy.
  Qed.

  Theorem sort_stable : forall l, @StablePerm A eqv _ _ l (sort l).
  Proof.
    induction l; [reflexivity|].
    cbn. transitivity (a :: sort l).
    apply StablePerm_skip. apply IHl.
    apply insert_stable.
  Qed.

  Theorem sort_StableSort : StableSort sort.
  Proof. split; [apply sort_sorted|symmetry; apply sort_stable]. Qed.

  Lemma Sorted_insert_cons : forall h t,
      Sorted (h :: t) -> insert h t = h :: t.
  Proof.
    intros h [|x t] HS; [easy|].
    cbn.
    rewrite if_true; [easy|].
    apply Sorted_cons_inv in HS.
    apply Forall_inv with (l := t).
    apply HS.
  Qed.

  Lemma Sorted_sort_cons : forall t h,
      Sorted (h :: t) -> sort (h :: t) = h :: t.
  Proof.
    induction t as [|x t IH]; intros h HS; [easy|].
    replace (sort (h :: x :: t)) with (insert h (sort (x :: t))) by easy.
    rewrite IH by (eapply Sorted_cons_inv; apply HS).
    apply Sorted_insert_cons; easy.
  Qed.

  Theorem insert_app : forall x l1 l2,
      insert x (l1 ++ l2) = insert x l1 ++ l2 \/ insert x (l1 ++ l2) = l1 ++ insert x l2.
  Proof.
    intros x; induction l1; intros l2.
    right; easy.
    cbn. destruct (le_dec x a).
    left; easy.
    cbn.
    destruct (IHl1 l2).
    left; f_equal; easy.
    right; f_equal; easy.
  Qed.

  Theorem insert_destr : forall x l,
      Sorted l ->
      exists l1 l2,
        insert x l = l1 ++ x :: l2 /\
        l = l1 ++ l2 /\
        Forall (gt x) l1 /\
        Forall (le x) l2.
  Proof.
    induction l; intros HS; [exists [], []; split; [|split]; easy|].
    destruct IHl as [l1 [l2 [HLI [HL [HL1 Hl2]]]]];
      [eapply Sorted_cons_inv; apply HS|].
    cbn.
    destruct (le_dec x a).
    - exists [], (a :: l).
      repeat try split; [constructor|].
      constructor; [easy|].
      apply Forall_impl with (P := le a); [|apply Sorted_cons_inv; apply HS].
      intros y; transitivity a; easy.
    - rewrite HL.
      exists (a :: l1), l2.
      repeat try split.
      + rewrite <- HL, HLI; easy.
      + constructor; easy.
      + easy.
  Qed.
End InsertionSort.


Require Import Arith List.
Import ListNotations.

Inductive sorted  : list nat -> Prop
  :=
  | sorted0 : sorted []
  | sorted1 (n : nat) : sorted [n]
  | sorted_n (n0 n1 : nat) (ns : list nat) :
      n0 <= n1
      -> sorted (n1 :: ns)
      -> sorted (n0 :: n1 :: ns).

#[export] Hint Constructors sorted :  sort.

Example sorted_ex : sorted [1; 3; 7].
Proof.
  auto with sort arith.
Qed.

Theorem sorted_inv (n : nat) (ns : list nat) : sorted (n :: ns) -> sorted ns.
Proof.
  intros H. inversion H; auto with sort.
Qed.

Theorem sorted_order (n0 n1 : nat) (ns : list nat)
  : sorted (n0 :: n1 :: ns) -> n0 <= n1.
Proof.
  intros H. inversion H. assumption.
Qed.

Fixpoint nb_occ (m : nat) (ns : list nat) : nat
  := match ns with
     | [] => 0
     | n :: ns' => Nat.b2n (m =? n) + nb_occ m ns'
     end.

Example nb_occ_ex : nb_occ 3 [1; 3; 2; 3] = 2.
Proof. reflexivity. Qed.

Theorem nb_occ_cons (n m : nat) (ns : list nat)
  : nb_occ n (m :: ns) = Nat.b2n (n =? m) + nb_occ n ns.
Proof.
  simpl. case (Nat.eq_dec n m); auto.
Qed.

Theorem nb_occ_cons_same (n : nat) (ns : list nat)
  : nb_occ n (n :: ns) = S (nb_occ n ns).
Proof.
  simpl. rewrite Nat.eqb_refl. simpl. ring.
Qed.

Theorem nb_occ_cons_other (n m : nat) (ns : list nat)
  : n <> m -> nb_occ n (m :: ns) = nb_occ n ns.
Proof.
  simpl. intros neq. apply Nat.eqb_neq in neq.
  rewrite neq. reflexivity.
Qed.

Definition permutation (ns ms : list nat) : Prop
  := forall n : nat, nb_occ n ns = nb_occ n ms.

Theorem permutation_is_sym (ns ms : list nat)
  : permutation ns ms -> permutation ms ns.
Proof.
  unfold permutation. intros H n. auto.
Qed.

Theorem permutation_is_refl (ns : list nat) : permutation ns ns.
Proof. easy. Qed.

Theorem permutation_is_trans (ns ms ks : list nat)
  : permutation ns ms -> permutation ms ks -> permutation ns ks.
Proof.
  unfold permutation. intros Hnm Hmk n.
  now rewrite Hnm.
Qed.

Theorem permutation_cons (k : nat) (ns ms : list nat)
  : permutation ns ms -> permutation (k :: ns) (k :: ms).
Proof.
  unfold permutation. intros H n.
  repeat rewrite nb_occ_cons.
  now rewrite H.
Qed.

Theorem permutation_perm (k1 k2 : nat) (ns ms : list nat)
  : permutation ns ms -> permutation (k1 :: k2 :: ns) (k2 :: k1 :: ms).
Proof.
  unfold permutation. intros H n.
  repeat rewrite nb_occ_cons. rewrite H.
  ring.
Qed.

#[export] Hint Resolve permutation_cons permutation_is_refl permutation_perm : sort.

Fixpoint insert (m : nat) (ns : list nat)
  := match ns with
     | [] => [m]
     | n :: ns' => if m <=? n then m :: ns
                   else n :: (insert m ns')
     end.

Theorem insert_sorted (m : nat) (ns : list nat)
  : sorted ns -> sorted (insert m ns).
Proof.
  induction ns as [| n1 ns1 IH]; intros H.
  - (*[ ns = [] ]*) simpl. constructor.
  - (*[ ns = n1 :: ns1 ]*)
    simpl. destruct (m <=? n1) eqn:neq.
    + (*[ m <= n1 ]*) apply sorted_n.
      { apply Nat.leb_le, neq. }
      assumption.
    + (*[ m > n1 ]*)
      apply Nat.leb_gt in neq as neq'.
      apply sorted_inv in H as H1.
      apply IH in H1 as H2.
      remember (insert m ns1) as ms eqn:eq_ms.
      destruct ms as [| m1 ms1].
      * (*[ ms = [] ]*) constructor.
      * (*[ ms = m1 :: ms1 ]*)
        apply sorted_n; try assumption.
        { (* proof that [n1 <= m1] *)
          destruct ns1 as [| n2 ns2].
          - (*[ ns1 = [] ]*) simpl in eq_ms.
            inversion eq_ms. apply Nat.lt_le_incl. assumption.
          - (*[ ns1 = n2 :: ns2 ]*)
            simpl in eq_ms.
            destruct (m <=? n2) eqn:neq1.
            + (*[ m <= n2 ]*) inversion eq_ms.
              apply Nat.lt_le_incl. assumption.
            + (*[ m > n2 ]*) inversion eq_ms.
              apply sorted_order in H. assumption.
        }
Qed.

Theorem insert_ob_occ (n m : nat) (ks : list nat)
  : nb_occ m (insert n ks) = Nat.b2n (m =? n) + nb_occ m ks.
Proof.
  induction ks as [| k ks' IH].
  - (* ks = [] *) reflexivity.
  - (* ks = k :: ks' *) simpl.
    destruct (n <=? k) eqn:neq.
    + (* n <= k *) repeat rewrite nb_occ_cons. reflexivity.
    + (* n > k *) rewrite nb_occ_cons, IH. ring.
Qed.

Theorem insert_is_permutaion (k : nat) (ns ms : list nat)
  : permutation ns ms -> permutation (k :: ns) (insert k ms).
Proof.
  unfold permutation. intros H n.
  rewrite nb_occ_cons, insert_ob_occ, (H n).
  reflexivity.
Qed.

(* modified theorem from book *)
Lemma insert_permutation : forall (ns : list nat) (m : nat),
    permutation (m :: ns) (insert m ns).
Proof.
  induction ns as [| n ns' IH]; simpl; auto with sort.
  intros m.
  destruct (m <=? n) eqn:neq;
    try apply permutation_is_trans with (n :: m :: ns');
    auto with sort.
Qed.

Fixpoint insertion_sort (ns : list nat)
  := match ns with
     | [] => []
     | n :: ns' => insert n (insertion_sort ns')
     end.

Example insertion_sort_ex : insertion_sort [4; 2; 3; 1; 3] = [1; 2; 3; 3; 4].
Proof. reflexivity. Qed.

Theorem insertion_sort_sorts (ns : list nat) : sorted (insertion_sort ns).
Proof.
  induction ns as [| n ns' IH].
  - (*[ ns = [] ]*) simpl. constructor.
  - (*[ ns = n :: ns' ]*)
    simpl. apply insert_sorted, IH.
Qed.

Theorem insertion_sort_save_elements (ns : list nat)
  : permutation ns (insertion_sort ns).
Proof.
  induction ns as [| n ns' IH].
  - (*[ ns = [] ]*) simpl. apply permutation_is_refl.
  - (*[ ns = n :: ns' ]*)
    simpl. apply insert_is_permutaion, IH.
Qed.

Definition nat_sort : (list nat -> list nat) -> Prop
  := fun fn => forall ns : list nat,
         sorted (fn ns) /\ permutation ns (fn ns).

Theorem insertion_sort_is_nat_sort : nat_sort insertion_sort.
Proof.
  intros ns. split.
  - apply insertion_sort_sorts.
  - apply insertion_sort_save_elements.
Qed.


Require Export TopologicalSpaces.
Require Export OpenBases.
Require Export FiniteTypes.
Require Export EnsemblesSpec.

Section Subbasis.

Variable X:TopologicalSpace.
Variable SB:Family (point_set X).

Record subbasis : Prop := {
  subbasis_elements: forall U:Ensemble (point_set X),
    In SB U -> open U;
  subbasis_cover: forall (U:Ensemble (point_set X)) (x:point_set X),
    In U x -> open U ->
    exists A:Type, FiniteT A /\
    exists V:A->Ensemble (point_set X),
      (forall a:A, In SB (V a)) /\
      In (IndexedIntersection V) x /\
      Included (IndexedIntersection V) U
}.

Lemma open_basis_is_subbasis: open_basis SB -> subbasis.
Proof.
intros.
destruct H.
constructor.
exact open_basis_elements.
intros.
destruct (open_basis_cover x U); trivial.
destruct H1 as [? [? ?]].
exists True.
split.
apply True_finite.
exists (True_rect x0).
repeat split; intros.
destruct a.
simpl.
assumption.
destruct a.
simpl.
assumption.
red; intros.
destruct H4.
apply H2.
exact (H4 I).
Qed.

Lemma finite_intersections_of_subbasis_form_open_basis:
  subbasis ->
  open_basis [ U:Ensemble (point_set X) |
              exists A:Type, FiniteT A /\
              exists V:A->Ensemble (point_set X),
              (forall a:A, In SB (V a)) /\
              U = IndexedIntersection V ].
Proof.
constructor.
intros.
destruct H0.
destruct H0 as [A [? [V' [? ?]]]].
rewrite H2.
apply open_finite_indexed_intersection; trivial.
intros.
apply H; trivial.

intros.
pose proof (subbasis_cover H U x).
destruct H2 as [A [? [V [? [? ?]]]]]; trivial.
exists (IndexedIntersection V).
repeat split; trivial.
exists A; split; trivial.
exists V; trivial.
split; trivial.
destruct H4.
exact H4.
Qed.

End Subbasis.

Implicit Arguments subbasis [[X]].

Section build_from_subbasis.

Variable X:Type.
Variable S:Family X.

Require Import FiniteIntersections.

Definition Build_TopologicalSpace_from_subbasis : TopologicalSpace.
refine (Build_TopologicalSpace_from_open_basis
  (finite_intersections S) _ _).
red; intros.
exists (Intersection U V); repeat split; trivial.
apply intro_intersection; trivial.
destruct H1; assumption.
destruct H1; assumption.
destruct H2; assumption.
destruct H2; assumption.

red; intro.
exists Full_set.
split; constructor.
Defined.

Lemma Build_TopologicalSpace_from_subbasis_subbasis:
  @subbasis Build_TopologicalSpace_from_subbasis S.
Proof.
assert (@open_basis Build_TopologicalSpace_from_subbasis
  (finite_intersections S)).
apply Build_TopologicalSpace_from_open_basis_basis.
constructor.
intros.
simpl in U.
apply open_basis_elements with (finite_intersections S); trivial.
constructor; trivial.

intros.
destruct (@open_basis_cover _ _ H x U) as [V]; trivial.
destruct H2 as [? [? ?]].
simpl.

pose proof (finite_intersection_is_finite_indexed_intersection
  _ _ H2).
destruct H5 as [A [? [W [? ?]]]].
exists A; split; trivial.
exists W; repeat split; trivial.

rewrite H7 in H4; destruct H4; apply H4.
rewrite H7 in H3; assumption.
Qed.

End build_from_subbasis.


Require Import Bool Arith List.
Require Import CpdtTactics.

Set Implicit Arguments.

(* 2.1 - Arithmetic Expressions Over Natural Numbers *)

(* Source Language *)
Inductive binop : Set :=
| Plus
| Times.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

Example exp_1 : expDenote (Const 42) = 42.
Proof. reflexivity. Qed.

Example exp_2 : expDenote (Binop Plus (Const 2) (Const 2)) = 4.
Proof. reflexivity. Qed.

Example exp_3 :
  expDenote (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)) = 28.
Proof. reflexivity. Qed.

(* Target Language *)
Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.

(* An instruction either pushes a constant onto the stack or pops two
   arguments, applies a binary operator to them, and then pushes the
   result onto the stack.
*)

(* Give instructions meanings as functions from stacks to optional
   stacks to handle stack underflows.
*)
Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
  | iConst n => Some (n :: s)
  | iBinop b =>
    match s with
    | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2 :: s')
    | _ => None
    end
  end.

(* Function which iterates application of instrDenote through a whole
   program.
*)
Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
  | nil => Some s
  | i :: p' =>
    match (instrDenote i s) with
    | None => None
    | Some s' => progDenote p' s'
    end
  end.

(* Translation *)
Fixpoint compile (e : exp) : prog :=
  match e with
  | Const n => iConst n :: nil
  | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

Example compile_1 :
  compile (Const 42) = iConst 42 :: nil.
Proof. reflexivity. Qed.

Example compile_2 :
  compile (Binop Plus (Const 2) (Const 2))
  = iConst 2 :: iConst 2 :: iBinop Plus :: nil.
Proof. reflexivity. Qed.

Example compile_3 :
  compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))
  = iConst 7 :: iConst 2 :: iConst 2 :: iBinop Plus :: iBinop Times :: nil.
Proof. reflexivity. Qed.

Example progDenote_1 :
  progDenote (compile (Const 42)) nil = Some (42 :: nil).
Proof. reflexivity. Qed.

Example progDenote_2 :
  progDenote (
    compile (Binop Plus (Const 2) (Const 2)))
    nil = Some (4 :: nil).
Proof. reflexivity. Qed.

Example progDenote_3 :
  progDenote (
    compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)))
    nil = Some (28 :: nil).
Proof. reflexivity. Qed.

(* Translation Correctness *)
Theorem compile_correct :
  forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.
  (* Prove auxiliary lemma that strengthens the induction hypothesis on e *)
Abort.

(* Manual proof *)
Lemma compile_correct'' :
  forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e as [n | b e1 IHe1 e2 IHe2].
  - (* e = Const n *)
    simpl; intros; reflexivity.
  - (* e = Binop b e1 e2 *)
    intros.
    unfold compile.
    fold compile.
    unfold expDenote.
    fold expDenote.
    rewrite app_assoc_reverse.
    rewrite IHe2.
    rewrite app_assoc_reverse.
    rewrite IHe1.
    unfold progDenote at 1.
    simpl.
    fold progDenote.
    reflexivity.
Qed.

(* Automated proof *)
Lemma compile_correct' :
  forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e; crush.
Qed.

Theorem compile_correct :
  forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.
  intros;
  rewrite (app_nil_end (compile e));
  rewrite compile_correct';
  reflexivity.
Qed.

(* 2.2 - Typed Expressions *)

(* Source Language *)

(* Trivial language of types to classify expressions *)
Inductive type : Set :=
| Nat
| Bool.

(* Expanded set of binary operators *)
Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool
| TLt : tbinop Nat Nat Bool.

(* Type family for typed expressions *)
Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

(* Map types of our 'object' language into Coq types *)
Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
  | TPlus => plus
  | TTimes => mult
  | TEq Nat => beq_nat
  | TEq Bool => eqb
  | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.


Require Import PeanoNat.

(* Strong induction on Natural numbers with properties sending to Type. *)

Theorem strong_induction:
forall P : nat -> Prop,
(forall n : nat, (forall k : nat, (k < n -> P k)) -> P n) ->
forall n : nat, P n.
Proof.
intros P H. assert (Lem : forall n, (forall m, m <= n -> P m)).
{ induction n. intros.
  - assert (E: m = 0). inversion H0.  reflexivity. rewrite E. apply H.
    intros. exfalso. inversion H1.
  - intros. apply H. intros. apply IHn. inversion H0.
    * rewrite H2 in H1. apply Nat.lt_succ_r. apply H1.
    * assert (E: k <= m). apply Nat.lt_le_incl. apply H1.
      apply Nat.le_trans with (m:=m). apply E. apply H3. }
intro n. apply H. intros. apply Lem with (n:=n) (m:=k).
apply Nat.lt_le_incl. apply H0.
Qed.