From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   rewrite append_nil.
   reflexivity.
Qed.


From Undecidability.TM.Code Require Import ProgrammingTools.
From Undecidability Require Import TM.Code.CaseNat.

(* * Machines that compte natural functions *)

(* Don't simplify [skipn (S n) xs]; only, if the number and the lists are constructors *)
Local Arguments skipn { A } !n !l.

Local Arguments Encode_nat : simpl never.

(*
Lemma nat_encode_length (n : nat) :
| encode n : list bool | = S n.
Proof. induction n; cbn; auto. Qed.

Lemma max_plus_minus_le (m n : nat) :
  n + (m - n) <= max m n.
Proof.
  assert (m <= n \/ n <= m) as [H|H] by lia.
  - rewrite <- Nat.le_max_r. lia.
  - rewrite <- Nat.le_max_l. lia.
Qed.

Lemma max_max_le (m n : nat) :
  max (max m n) n = max m n.
Proof.
  assert (m <= n \/ n <= m) as [H|H] by lia.
  - erewrite Nat.max_r.
    + symmetry. now eapply max_r.
    + eapply Nat.eq_le_incl. now eapply max_r.
  - erewrite Nat.max_l.
    + reflexivity.
    + apply Nat.le_max_r.
Qed.
*)

(* ** Addition *)

(*
 * Step machine
 *
 * if (b--) {
 *   a++;
 *   continue;
 * } else {
 *   break;
 * }
 *
 * Tapes:
 * t0: a
 * t1: b
 *)
Definition Add_Step : pTM sigNat^+ (option unit) 2 :=
  If (LiftTapes CaseNat [|Fin1|])
     (Return (LiftTapes Constr_S [|Fin0|]) None)
     (Return Nop (Some tt)).

Definition Add_Loop : pTM sigNat^+ unit 2 := While Add_Step.

(*
 * Full machine in pseudocode:
 * a := n
 * b := m
 * while (b--) { // Loop
 *   a++;
 * }
 * reset b;
 * return a;
 *
 * Tapes:
 * INP t0: m
 * INP t1: n
 * OUT t2: a
 * INT t3: b
 *)
(* Everything, but not reset *)
Definition Add_Main : pTM sigNat^+ unit 4 :=
  LiftTapes (CopyValue _) [|Fin1; Fin2|];; (* copy n to a *)
  LiftTapes (CopyValue _) [|Fin0; Fin3|];; (* copy m to b *)
  LiftTapes Add_Loop [|Fin2; Fin3|]. (* Main loop *)

(*
 * Finally, reset tape b.
 * For technical reasons, it is convienient to define the machine for this last step seperately,
 * because it makes prooving the termination easier.
 *)
Definition Add :=
  Add_Main;; (* Initialisation and main loop *)
  LiftTapes (Reset _) [|Fin3|]. (* Reset b *)

(* *** Correctness of [Add] *)

Definition Add_Step_Rel : pRel sigNat^+ (option unit) 2 :=
  fun tin '(yout, tout) =>
    forall a b sa sb,
      tin [@Fin0] ≃(;sa) a ->
      tin [@Fin1] ≃(;sb) b ->
      match yout, b with
      | Some tt, O => (* break *)
        tout[@Fin0] ≃(;sa) a /\
        tout[@Fin1] ≃(;sb) b
      | None, S b' =>
        tout[@Fin0] ≃(;pred sa) S a /\
        tout[@Fin1] ≃(;S sb) b'
      | _, _ => False
      end.

Lemma Add_Step_Sem : Add_Step ⊨c(9) Add_Step_Rel.
Proof.
  eapply RealiseIn_monotone.
  {
    unfold Add_Step. TM_Correct.
  }
  { cbn. reflexivity. }
  {
    intros tin (yout, tout) H. cbn. intros a b sa sb HEncA HEncB. cbn in *.
    destruct H; TMSimp; clear_trivial_eqs.
    - modpon H. destruct b; auto.
    - modpon H. destruct b; auto.
  }
Qed.

Definition Add_Loop_Rel : pRel sigNat^+ unit 2 :=
  ignoreParam (
      fun tin tout =>
        forall a b sa sb,
          tin [@Fin0] ≃(;sa) a ->
          tin [@Fin1] ≃(;sb) b ->
          tout[@Fin0] ≃(;sa-b) b + a /\
          tout[@Fin1] ≃(;sb+b) 0
    ).

Lemma Add_Loop_Realise : Add_Loop ⊨ Add_Loop_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Add_Loop. TM_Correct. eapply RealiseIn_Realise. apply Add_Step_Sem. }
  {
    apply WhileInduction; intros; intros a b sa sb HEncA HEncB; cbn in *; destruct_unit.
    - modpon HLastStep. destruct b; auto; modpon HLastStep. auto.
    - modpon HStar. destruct b; auto. destruct HStar as (HStar1&HStar2).
      modpon HLastStep. split; auto. contains_ext. f_equal. lia.
  }
Qed.

(* Everything, but reset *)
Definition Add_Main_Rel : pRel sigNat^+ unit 4 :=
  ignoreParam (
      fun tin tout =>
        forall m n sm sn s2 s3,
          tin [@Fin0] ≃(;sm) m ->
          tin [@Fin1] ≃(;sn) n ->
          isVoid_size tin[@Fin2] s2 ->
          isVoid_size tin[@Fin3] s3 ->
          tout[@Fin0] ≃(;sm) m /\
          tout[@Fin1] ≃(;sn) n /\
          tout[@Fin2] ≃(; s2 - (S (size n)) - m) m + n /\
          tout[@Fin3] ≃(; s3 - (2 + m) + m) 0
    ).

Lemma Add_Main_Realise : Add_Main ⊨ Add_Main_Rel.
Proof.
  eapply Realise_monotone.
  {
    unfold Add_Main. TM_Correct.
    - apply Add_Loop_Realise.
  }
  {
    intros tin ((), tout) H. cbn. intros m n sm sn s2 s3 HEncM HEncN HOut HInt.
    TMSimp.
    modpon H. modpon H0. modpon H2.
    repeat split; auto.
    { contains_ext. unfold CopyValue_size. rewrite Encode_nat_hasSize. lia. }
  }
Qed.

Goal forall (x m : nat), x - m + m >= x. Proof. intros. lia. Qed.

Definition Add_space2 (m n : nat) (so : nat) := so + m - n - 2.
Definition Add_space3 (m : nat) (s3 : nat) := 2 + (s3 - (2 + m) + m).

Definition Add_Rel : pRel sigNat^+ unit 4 :=
  ignoreParam
    (fun tin tout =>
       forall (m : nat) (n : nat) (sx sy so s3 : nat),
         tin[@Fin0] ≃(;sx) m ->
         tin[@Fin1] ≃(;sy) n ->
         isVoid_size tin[@Fin2] so ->
         isVoid_size tin[@Fin3] s3 ->
         tout[@Fin0] ≃(;sx) m /\ (* First input value stayes unchanged *)
         tout[@Fin1] ≃(;sy) n /\ (* Second input value stayes unchanged *)
         tout[@Fin2] ≃(;Add_space2 m n so) (m + n) /\
         isVoid_size tout[@Fin3] (Add_space3 m s3)
    ).

Lemma Add_Computes : Add ⊨ Add_Rel.
Proof.
  eapply Realise_monotone.
  {
    unfold Add. TM_Correct.
    - apply Add_Main_Realise.
  }
  {
    intros tin ((), tout) H. intros m n sx sy so s3 HEncM HEncN HOut HRight3. TMSimp.
    unfold Add_space2, Add_space3.
    rename H into HMain, H0 into HReset.
    modpon HMain. modpon HReset.
    repeat split; eauto.
    contains_ext. rewrite Encode_nat_hasSize. lia.
  }
Qed.

(* *** Termination of [Add] *)

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

Definition Add_Loop_steps b := 9 + 10 * b.

Lemma Add_Loop_Terminates :
  projT1 Add_Loop ↓
         (fun tin i => exists (a b:nat),
              tin[@Fin0] ≃ a /\
              tin[@Fin1] ≃ b /\
              Add_Loop_steps b <= i).
Proof.
  eapply TerminatesIn_monotone.
  { unfold Add_Loop. TM_Correct.
    - eapply RealiseIn_Realise. apply Add_Step_Sem.
    - eapply RealiseIn_TerminatesIn. apply Add_Step_Sem. }
  {
    unfold Add_Loop_steps. apply WhileCoInduction. intros tin i (a&b&HEncA&HEncB&Hi).
    destruct b.
    (* (* In case I want to use the [WhileInduction] principle without [match] *)
    - exists 11. repeat split.
      + lia.
      + intros () ? _. lia.
      + intros tmid H. cbn in *. specialize (H _ _ HEncA HEncB). cbn in *. auto.
    - exists 11. repeat split.
      + lia.
      + intros () tmid H. cbn in H. specialize (H _ _ HEncA HEncB). now cbn in *.
      + intros tmid H. cbn in H. specialize (H _ _ HEncA HEncB). cbn in *. destruct H as (H1&H2).
        exists (11 + b * 12). repeat split.
        * exists (S a), b. repeat split; eauto. lia.
        * lia.
        *)
    - exists 9. repeat split.
      + lia.
      + intros o tmid H. cbn in H. modpon H;[]. destruct o; auto.
    - exists 9. repeat split.
      + lia.
      + intros o tmid H. cbn in H. modpon H. cbn -[plus mult] in *.
        destruct o as [ () | ]; auto. destruct H.
        exists (9 + b * 10). repeat split.
        * do 2 eexists. repeat split; eauto. lia.
        * lia.
  }
Qed.

Definition Add_Main_steps m n := 85 + 12 * n + 22 * m.
(* [37 + 12 * n] for [CopyValue] (n) *)
(* [37 + 12 * m] for [CopyValue] (m) *)
(* [9 + 10 * m] for [Add_Loop] *)

Definition Add_Main_T : tRel sigNat^+ 4 := fun tin k => exists m n, tin[@Fin0] ≃ m /\ tin[@Fin1] ≃ n /\ isVoid tin[@Fin2] /\ isVoid tin[@Fin3] /\ Add_Main_steps m n <= k.

Lemma Add_Main_Terminates :
  projT1 Add_Main ↓ Add_Main_T.
Proof.
  unfold Add_Main, Add_Main_steps. eapply TerminatesIn_monotone.
  {
    TM_Correct.
    - apply Add_Loop_Terminates.
  }
  {
    intros tin k (m&n&HEncM&HEncN&HOut&HRight3&Hk).
    unfold Add_Main_steps in *.
    exists (37 + 12 * n), (47 + 22 * m). repeat split; cbn.
    - cbn. exists n. split; eauto. unfold CopyValue_steps. rewrite Encode_nat_hasSize. lia.
    - lia.
    - intros tmid ymid. intros (H1&H2). TMSimp.
      modpon H1.
      exists (37 + 12 * m), (Add_Loop_steps m). repeat split.
      + exists m. split. eauto. unfold CopyValue_steps. rewrite Encode_nat_hasSize. lia.
      + unfold Add_Loop_steps. lia.
      + intros tmid2_ () (HComp & HInj). TMSimp.
        modpon HComp.
        do 2 eexists; repeat split; eauto; do 2 eexists; eassumption.
  }
Qed.

Definition Add_steps m n := 98 + 12 * n + 22 * m.
(* Additional [12] steps for [Reset], and [1] for [Seq] *)

Definition Add_T : tRel sigNat^+ 4 := fun tin k => exists m n, tin[@Fin0] ≃ m /\ tin[@Fin1] ≃ n /\ isVoid tin[@Fin2] /\ isVoid tin[@Fin3] /\ Add_steps m n <= k.

Lemma Add_Terminates :
  projT1 Add ↓ Add_T.
Proof.
  unfold Add, Add_steps. eapply TerminatesIn_monotone.
  {
    TM_Correct.
    - apply Add_Main_Realise.
    - apply Add_Main_Terminates.
  }
  {
    intros tin k (m&n&HEncM&HEncN&HOut&HInt&Hk).
    exists (Add_Main_steps m n), 12. repeat split.
    - cbn. exists m, n. repeat split; eauto.
    - unfold Add_Main_steps. unfold Add_steps in *. lia.
    - intros tmid () HComp. cbn in *.
      modpon HComp.
      exists 0. split. eauto. unfold MoveRight_steps. cbn. auto.
  }
Qed.

(* ** Multiplication *)

(*
 * Complete Machine:
 *
 * INP t0: m
 * INP t1: n  (for Add: INP t0)
 * OUT t2: c  (for Add: INP t1)
 * INT t3: c' (for Add: OUT t2)
 * INT t4:    (for Add: INT t3)
 * INT t5: m' (copy of m)
 *
 * Pseudocode:
 * c := 0
 * while (m--) {
 *   ADD(n, c, c')
 *   Reset c
 *   c := c'
 *   Reset c'
 * }
 * Reset m'
 *)

(*
 * Step-Machine:
 * (Note that it only accesses the copy of m)
 *
 * t0: m' (counter)
 * t1: n  (for Add: INP t0)
 * t2: c  (for Add: INP t1)
 * t3: c' (for Add: OUT t2)
 * t4:    (for Add: INT t3)
 *
 * if (m'--) {
 *   Add(n, c, c')
 *   c := c
 *   reset c'
 *   continue
 * } else {
 *   break
 * }
 *)
Definition Mult_Step : pTM sigNat^+ (option unit) 5 :=
  If (LiftTapes CaseNat [|Fin0|])
     (Return (
          LiftTapes Add [|Fin1; Fin2; Fin3; Fin4|];; (* Add(n, c, c') *)
          LiftTapes (MoveValue _) [|Fin3; Fin2|]
        ) (None)) (* continue *)
     (Return Nop (Some tt)). (* break *)

Definition Mult_Loop := While Mult_Step.

(*
 * INP t0: m
 * INP t1: n  (for Mult_Loop: t1)
 * OUT t2: c  (for Mult_Loop: t2)
 * INT t3: c' (for Mult_Loop: t3)
 * INT t4:    (for Mult_Loop: t4)
 * INT t5: m' (for Mult_Loop: t0)
 *)
Definition Mult_Main : pTM sigNat^+ unit 6 :=
  LiftTapes (CopyValue _) [|Fin0; Fin5|];; (* m' := m *)
  LiftTapes (Constr_O) [|Fin2|];; (* c := 0 *)
  LiftTapes Mult_Loop [|Fin5; Fin1; Fin2; Fin3; Fin4|]. (* Main loop *)

Definition Mult : pTM sigNat^+ unit 6 :=
  Mult_Main;;
  LiftTapes (Reset _) [|Fin5|]. (* Reset m' *)

(* *** Correctness of [Mult] *)

Definition Mult_Step_Rel : pRel sigNat^+ (option unit) 5 :=
  fun tin '(yout, tout) =>
    forall (c m' n : nat) (sm sn sc s3 s4 : nat),
      tin[@Fin0] ≃(;sm) m' ->
      tin[@Fin1] ≃(;sn) n ->
      tin[@Fin2] ≃(;sc) c ->
      isVoid_size tin[@Fin3] s3 ->
      isVoid_size tin[@Fin4] s4 ->
      match yout, m' with
      | (Some tt), O => (* return *)
        tout[@Fin0] ≃(;sm) m' /\
        tout[@Fin1] ≃(;sn) n /\
        tout[@Fin2] ≃(;sc) c /\
        isVoid_size tout[@Fin3] s3 /\
        isVoid_size tout[@Fin4] s4
      | None, S m'' => (* continue *)
        tout[@Fin0] ≃(;S sm) m'' /\
        tout[@Fin1] ≃(;sn) n /\
        tout[@Fin2] ≃(;sc-n) n + c /\
        isVoid_size tout[@Fin3] (2 + n + c + Add_space2 n c s3)  /\
        isVoid_size tout[@Fin4] (Add_space3 n s4)
      | _, _ => False
      end.

Lemma Mult_Step_Realise : Mult_Step ⊨ Mult_Step_Rel.
Proof.
  eapply Realise_monotone.
  {
    unfold Mult_Step. TM_Correct.
    - apply Add_Computes.
  }
  {
    intros tin (yout, tout) H. intros c m' n sm sn sc s3 s4 HEncM' HEncN HEncC HInt3 HInt4. TMSimp.
    destruct H; TMSimp.
    - rename H into HCaseNat, H1 into HAdd, H3 into HMove.
      modpon HCaseNat.
      destruct m' as [ | m']; auto.
      modpon HAdd. modpon HMove.
      repeat split; auto.
      + contains_ext. unfold MoveValue_size_y. rewrite !Encode_nat_hasSize. lia.
      + isVoid_mono. unfold Add_space2. unfold MoveValue_size_x. rewrite Encode_nat_hasSize. lia.
    - modpon H. destruct m' as [ | m']; auto.
  }
Qed.

Fixpoint Mult_Loop_space34 (m' n c : nat) (s3 s4 : nat) { struct m' } : Vector.t nat 2 :=
  match m' with
  | 0 => [| s3; s4 |]
  | S m'' => Mult_Loop_space34 m'' n (n + c) (2 + n + c + Add_space2 n c s3) (Add_space3 n s4)
  end.

Definition Mult_Loop_Rel : pRel sigNat^+ unit 5 :=
  ignoreParam (
      fun tin tout =>
        forall c m' n sm sn sc s3 s4,
          tin[@Fin0] ≃(;sm) m' ->
          tin[@Fin1] ≃(;sn) n ->
          tin[@Fin2] ≃(;sc) c ->
          isVoid_size tin[@Fin3] s3 ->
          isVoid_size tin[@Fin4] s4 ->
          tout[@Fin0] ≃(;sm+m') 0 /\
          tout[@Fin1] ≃(;sn) n /\
          tout[@Fin2] ≃(;sc-m'*n) m' * n + c /\
          isVoid_size tout[@Fin3] (Mult_Loop_space34 m' n c s3 s4)[@Fin0] /\
          isVoid_size tout[@Fin4] (Mult_Loop_space34 m' n c s3 s4)[@Fin1]
    ).

Lemma Mult_Loop_Realise :
  Mult_Loop ⊨ Mult_Loop_Rel.
Proof.
  eapply Realise_monotone.
  {
    unfold Mult_Loop. TM_Correct. eapply Mult_Step_Realise.
  }
  {
    eapply WhileInduction; intros; intros c m' n sm sn sc s3 s4 HEncM' HEncN HEncC HInt3 HInt4; TMSimp.
    - modpon HLastStep. destruct m' as [ | m']; auto. modpon HLastStep. auto.
    - modpon HStar.
      destruct m' as [ | m']; auto. destruct HStar as (HStar1&HStar2&HStar3&HStar4&HStar5).
      modpon HLastStep.
      rewrite Nat.add_assoc in *. replace (n + m' * n + c) with (m' * n + n + c) by lia.
      repeat split; auto. contains_ext. f_equal. now rewrite Nat.mul_succ_l.
  }
Qed.

(*
 * Complete Machine:
 *
 * INP t0: m
 * INP t1: n  (from Add: INP t0)
 * OUT t2: c  (from Add: INP t1)
 * INT t3: c' (from Add: OUT t2)
 * INT t4:    (from Add: INT t3)
 * INT t5: m' (copy of m)
 *
 * Pseudocode:
 * c := 0
 * m' := m
 * while (m--) {
 *   ADD(n, c, c')
 *   c := c'
 *   reset c'
 * }
 * reset m'
 *)

Definition Mult_Main_Rel : pRel sigNat^+ unit 6 :=
  ignoreParam (
      fun tin tout =>
        forall (m n : nat) (sm sn so s3 s4 s5 : nat),
          tin[@Fin0] ≃(;sm) m ->
          tin[@Fin1] ≃(;sn) n ->
          isVoid_size tin[@Fin2] so ->
          isVoid_size tin[@Fin3] s3 ->
          isVoid_size tin[@Fin4] s4 ->
          isVoid_size tin[@Fin5] s5 ->
          tout[@Fin0] ≃(;sm) m /\
          tout[@Fin1] ≃(;sn) n /\
          tout[@Fin2] ≃(;so-m*n) m * n /\
          isVoid_size tout[@Fin3] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin0]) /\
          isVoid_size tout[@Fin4] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin1]) /\
          tout[@Fin5] ≃(;s5+m) 0
    ).

Lemma Mult_Main_Realise :
  Mult_Main ⊨ Mult_Main_Rel.
Proof.
  eapply Realise_monotone.
  {
    unfold Mult_Main. TM_Correct.
    - apply Mult_Loop_Realise.
  }
  {
    intros tin ((), tout) H. intros m n sm sn s0 s3 s4 s5 HEncM HEncN Hout HInt3 HInt4 HInt5.
    TMSimp.
    modpon H. modpon H0. modpon H2. rewrite Nat.add_0_r in H4.
    repeat split; eauto.
    { contains_ext. unfold CopyValue_size, Constr_O_size. cbn. lia. }
    { contains_ext. unfold CopyValue_size, Constr_O_size. cbn. lia. }
  }
Qed.

Definition Mult_Rel : pRel sigNat^+ unit 6 :=
  ignoreParam
    (fun tin tout =>
       forall (m : nat) (n : nat) (sm sn so s3 s4 s5 : nat),
         tin[@Fin0] ≃(;sm) m ->
         tin[@Fin1] ≃(;sn) n ->
         isVoid_size tin[@Fin2] so ->
         isVoid_size tin[@Fin3] s3 ->
         isVoid_size tin[@Fin4] s4 ->
         isVoid_size tin[@Fin5] s5 ->
         tout[@Fin0] ≃(;sm) m /\
         tout[@Fin1] ≃(;sn) n /\
         tout[@Fin2] ≃(;so-m*n) m * n /\
         isVoid_size tout[@Fin3] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin0]) /\
         isVoid_size tout[@Fin4] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin1]) /\
         isVoid_size tout[@Fin5] (S (S (m + s5)))
    ).

Lemma Mult_Computes :
  Mult ⊨ Mult_Rel.
Proof.
  eapply Realise_monotone.
  {
    unfold Mult. TM_Correct.
    - eapply Mult_Main_Realise.
  }
  {
    intros tin ((), tout) H. cbn. intros m n sm sn so s3 s4 s5 HEncM HEncN HOut HInt3 HInt4 HInt5. TMSimp.
    rename H into HMain, H0 into HReset.
    modpon HMain. modpon HReset.
    repeat split; auto.
    {  isVoid_mono. unfold Reset_size. rewrite !Encode_nat_hasSize. cbn. lia. }
  }
Qed.

(* *** Termination of Mult *)

Definition Mult_Step_steps m' n c :=
  match m' with
  | O => 6
  | _ => 168 + 33 * c + 39 * n
  end.
(* [5] for [If] and [1] for [CaseNat] *)
(* [98+12*n+22*c] for [Add] *)
(* [12+c] for [Reset] (c) *)
(* [36+12*(c+n)] for [CopyValue] (c' = c + n) *)
(* [12 + (c+n)] for [Reset] (c' = c + n) *)

Lemma Mult_Step_Terminates :
  projT1 Mult_Step ↓
         (fun tin k => exists m' n c,
              tin[@Fin0] ≃ m' /\
              tin[@Fin1] ≃ n /\
              tin[@Fin2] ≃ c /\
              isVoid tin[@Fin3] /\
              isVoid tin[@Fin4] /\
              Mult_Step_steps m' n c <= k).
Proof.
  eapply TerminatesIn_monotone.
  {
    unfold Mult_Step. TM_Correct.
    - apply Add_Computes.
    - apply Add_Terminates.
  }
  {
    intros tin k. intros (m'&n&c&HEncM'&HEncN&HEncC&HInt3&HInt4&Hk).
    destruct m' as [ | m']; cbn.
    - exists 5, 0. cbn in *; repeat split; eauto.
      intros tmid y (HComp&HInj). TMSimp.
      modpon HComp. destruct y; auto.
    - exists 5, (162 + 33 * c + 39 * n); cbn in *; repeat split; eauto.
      intros tmid y (HComp&HInj). TMSimp.
      modpon HComp. cbn in *. destruct y; auto.
      exists (Add_steps n c), (63 + 21 * c + 17 * n); cbn in *; repeat split.
      do 2 eexists. repeat split; eauto.
      unfold Add_steps. lia.
      intros tmid0_ () (HComp2&HInj). TMSimp.
      modpon HComp2.
      do 2 eexists. repeat split; eauto. unfold MoveValue_steps. rewrite !Encode_nat_hasSize. lia.
  }
Qed.

Fixpoint Mult_Loop_steps m' n c :=
  match m' with
  | O => S (Mult_Step_steps m' n c)
  | S m'' => S (Mult_Step_steps m' n c) + Mult_Loop_steps m'' n (n + c)
  end.

Lemma Mult_Loop_Terminates :
  projT1 Mult_Loop ↓
         (fun tin i => exists m' n c,
              tin[@Fin0] ≃ m' /\
              tin[@Fin1] ≃ n /\
              tin[@Fin2] ≃ c /\
              isVoid tin[@Fin3] /\
              isVoid tin[@Fin4] /\
              Mult_Loop_steps m' n c <= i).
Proof.
  eapply TerminatesIn_monotone.
  { unfold Mult_Loop. TM_Correct.
    - apply Mult_Step_Realise.
    - apply Mult_Step_Terminates. }
  {
    apply WhileCoInduction. intros tin k (m'&n&c&HEncM'&HEncN&HEncC&HRight3&HRight4&Hk).
    destruct m' as [ | m''] eqn:E; cbn in *; exists (Mult_Step_steps m' n c).
    {
      repeat split.
      - do 3 eexists. repeat split; eauto. cbn. unfold Mult_Step_steps. destruct m'; lia.
      - intros o tmid H1.
        modpon H1.
        destruct o as [ () | ]; auto. destruct H1 as (HComp1&HComp2&HComp3&HComp4&HComp5).
        subst. cbn. lia.
    }
    {
      repeat split.
      - do 3 eexists. repeat split; eauto. cbn. unfold Mult_Step_steps. destruct m'; lia.
      - intros o tmid H1.
        modpon H1.
        destruct o as [ () | ]; auto. destruct H1 as (HComp1&HComp2&HComp3&HComp4&HComp5).
        cbn. eexists. repeat split.
        + do 3 eexists. repeat split; eauto.
        + cbn. rewrite <- Hk. subst. clear_all. unfold Mult_Step_steps. lia.
    }
  }
Qed.

Definition Mult_Main_steps m n := 44 + 12 * m + Mult_Loop_steps m n 0.
(* [2] steps for [Seq], in total *)
(* [37+12*m] for [CopyValue] (m) *)
(* [Mult_Loop_steps m n 0] for [Mult_Loop] *)

Definition Mult_Main_T : tRel sigNat^+ 6 := fun tin k => exists m n, tin[@Fin0] ≃ m /\ tin[@Fin1] ≃ n /\ isVoid tin[@Fin2] /\ (forall i : Fin.t 3, isVoid tin[@FinR 3 i]) /\ Mult_Main_steps m n <= k.

Lemma Mult_Main_Terminates : projT1 Mult_Main ↓ Mult_Main_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold Mult_Main. TM_Correct.
    - apply Mult_Loop_Terminates.
  }
  {
    intros tin k (m&n&HEncM&HEncN&HOut&HInt&Hk). cbn in *. unfold Mult_Main_steps in Hk.
    specializeFin HInt; clear HInt.
    exists (37 + 12 * m), (6 + Mult_Loop_steps m n 0). repeat split; try lia.
    { eexists. repeat split; eauto. unfold CopyValue_steps. rewrite Encode_nat_hasSize; cbn. lia. }
    intros tmid () (H1&H2); TMSimp. modpon H1.
    exists 5, (Mult_Loop_steps m n 0). repeat split; try lia.
    { unfold Constr_O_steps. lia. }
    intros tmid2 () (H2&HInj2); TMSimp. modpon H2.
    do 3 eexists. repeat split; eauto.
  }
Qed.

Definition Mult_steps m n := 13 + Mult_Main_steps m n.

Definition Mult_T : tRel sigNat^+ 6 := fun tin k => exists m n, tin[@Fin0] ≃ m /\ tin[@Fin1] ≃ n /\ isVoid tin[@Fin2] /\ (forall i : Fin.t 3, isVoid tin[@FinR 3 i]) /\ Mult_steps m n <= k.

Lemma Mult_Terminates : projT1 Mult ↓ Mult_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold Mult. TM_Correct.
    - apply Mult_Main_Realise.
    - apply Mult_Main_Terminates.
  }
  {
    intros tin k (m&n&HEncM&HEncN&HOut&HInt&Hk). cbn in *. unfold Mult_steps in Hk.
    exists (Mult_Main_steps m n), 12. repeat split; try lia.
    do 2 eexists; repeat split; eauto.
    intros tmid () H1; TMSimp.
    specialize (HInt Fin0) as HInt0. specialize (HInt Fin1) as HInt4. specialize (HInt Fin2) as HInt5.
    modpon H1.
    exists 0. split; auto.
  }
Qed.


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "ex5_4_IFMORPH".
(** * [andB] properties *)

(** This library defines some of the properties of [andB]. *)

(** [FAlse] if one of them is [FAlse]. *)
Lemma andB_FAlse_intro1 : forall b1 b2 : Bool, b1 ## FAlse -> b1 & b2 ## FAlse.
Proof.
intros.
unfold andB .
rewrite H.
apply IFFALSE_B.
Qed.

Lemma andB_FAlse_intro2 : forall b1 b2:Bool, b2 ## FAlse -> b1 & b2 ## FAlse.
Proof. intros. unfold andB. rewrite H. apply IFSAME_B. Qed.

Lemma andB_FAlse_r :  forall b:Bool, b & FAlse ## FAlse.
Proof. intros.  unfold andB. apply IFSAME_B. Qed.

Lemma andB_FAlse_l : forall b: Bool, FAlse & b ## FAlse.
Proof. intros. unfold andB. apply IFFALSE_B. Qed.

Lemma andB_diag : forall n, (Bvar n) & (Bvar n) ## (Bvar n).
Proof.  intros. unfold andB. rewrite IFEVAL_B. simpl.
rewrite <- beq_nat_refl.
 rewrite IFTF.
reflexivity.
Qed.

(** Invariant under [TRue]. *)

Lemma andB_TRue_r : forall b:Bool, b & TRue ## b.

Proof.  intros. unfold andB.
pose proof (IFTF 1).
apply Forall_ELM_EVAL_B with (n :=1)(b:=b) in H.
simpl in H.
apply H.  Qed.

Lemma andB_TRue_l : forall b:Bool,  TRue & b ## b.

Proof.  intros. unfold andB.
apply IFTRUE_B.
   Qed.

Lemma andB_notb_r : forall n, (Bvar n) & (notb (Bvar n)) ## FAlse.

Proof. intros. unfold andB .  unfold notb.  rewrite IFEVAL_B. simpl. rewrite <- beq_nat_refl.
rewrite IFTRUE_B. rewrite IFSAME_B. reflexivity. Qed.

(** [andB] is commutative. *)

Lemma andB_comm1: forall n1 n2 , ( (Bvar n1) & (Bvar n2))  ## ( (Bvar n2) & (Bvar n1)).

Proof. intros. unfold andB.  rewrite <- IFTF with (n:= n2) at 1 .

rewrite IFMORPH_B1 with (n1:= n2) (n2:=n1). rewrite IFTF with (n:= n1). rewrite IFSAME_B. reflexivity. Qed.

Axiom andB_comm: forall (b1 b2: Bool), (b1 & b2) ## (b2 & b1).

(** [andB] is associative *)

Lemma andB_assoc1 : forall n1 n2 n3, (Bvar n1) & ((Bvar n2) & (Bvar n3)) ##( ((Bvar n1) & (Bvar n2)) & (Bvar n3)).

Proof. intros. unfold andB.
pose proof(andB_comm1).
unfold andB in H.
pose proof (IFMORPH_B1).
 rewrite IFMORPH_B1 with (n1:= n2) (n2:= n1).
rewrite H with (n1:=n1) (n2:= n2).
rewrite IFMORPH_B2.
rewrite IFSAME_B.
rewrite IFFALSE_B.
reflexivity.
Qed.

Axiom andB_assoc: forall (b1 b2 b3: Bool), (b1 & b2) & b3 ## b1 & (b2 & b3).
Axiom andB_prop : forall a b:Bool, (andB a b) ## TRue -> (a ## TRue) /\ (b ## TRue).

Lemma andB_TRue_intro : forall b1 b2:Bool, b1 ## TRue /\ b2 ## TRue -> (andB b1 b2) ## TRue.
Proof. intros.
inversion H.
unfold andB.
rewrite H0.
rewrite IFTRUE_B.
assumption.
Qed.

Lemma andB_TRue_iff :  forall n1 n2, (Bvar n1) & (Bvar n2) ## TRue <-> (Bvar n1) ## TRue /\ (Bvar n2) ## TRue.
Proof. split.
apply andB_prop.
apply andB_TRue_intro.
Qed.

(** [notb] properties *)

Lemma notB_involutive : forall n, (notb (notb (Bvar n))) ## (Bvar n).

Proof. intros. unfold notb.

 rewrite IFMORPH_B2. rewrite IFFALSE_B. rewrite IFTRUE_B.
rewrite IFTF. reflexivity. Qed.

Lemma notB_TRue_iff : forall n, ( notb (Bvar n)) ## TRue <-> (Bvar n) ## FAlse.
Proof.
intros. split.
intros.
rewrite <- notB_involutive.
rewrite H.
unfold notb .
rewrite IFTRUE_B.
reflexivity.
intros.
rewrite H.
unfold notb.
rewrite IFFALSE_B.
reflexivity.
Qed.

Lemma notb_FAlse_iff : forall n, (notb (Bvar n)) ## FAlse <-> (Bvar n) ## TRue.

Proof. intros. split.

intros.  rewrite <- notB_involutive. rewrite H. unfold notb. rewrite IFFALSE_B.  reflexivity.

intros. rewrite H. unfold notb.

rewrite IFTRUE_B. reflexivity. Qed.

(** [andB] complement *)

Lemma and_notB_r : forall n, (Bvar n) & (notb (Bvar n)) ## FAlse.
Proof. intros. unfold  andB.
unfold notb. rewrite IFMORPH_B1.
rewrite IFIDEMP_B. rewrite IFSAME_B. reflexivity. Qed.

Lemma and_notB_l : forall n, (notb (Bvar n)) & (Bvar n) ## FAlse.
Proof. intros. unfold  andB.
unfold notb. rewrite IFMORPH_B2.
rewrite IFFALSE_B, IFTRUE_B.
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFSAME_B.
reflexivity. Qed.

Theorem b1_notb2 : forall (n1 : nat) , (Bvar n1) &(notb (Bvar (n1+1))) ##
(ifb (Bvar (n1+1)) FAlse (Bvar n1)) .

Proof.
 intros.
unfold notb, andB.
rewrite <- IFSAME_B with (b:= (Bvar (n1+1))) (b1:= (ifb (Bvar n1) (ifb (Bvar (n1 + 1)) FAlse TRue) FAlse)).
rewrite IFEVAL_B with (n := (n1+1)).
 simpl.
rewrite <- beq_nat_refl.
rewrite IFFALSE_B.
rewrite IFTRUE_B.
rewrite IFSAME_B.
(*************)
assert(H: beq_nat n1 (n1 + 1) = false).
induction n1.
reflexivity.
simpl.
assumption.
(************)
rewrite H.
rewrite IFTF.
reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Import PeanoNat.

Local Open Scope nat_scope.

Notation le_refl := Nat.le_refl (compat "8.4").
Notation le_trans := Nat.le_trans (compat "8.4").
Notation le_antisym := Nat.le_antisymm (compat "8.4").

Hint Resolve le_trans: arith.
Hint Immediate le_antisym: arith.

Notation le_0_n := Nat.le_0_l (compat "8.4").
Notation le_Sn_0 := Nat.nle_succ_0 (compat "8.4").

Lemma le_n_0_eq n : n <= 0 -> 0 = n.
Proof. hammer_hook "Le" "Le.le_n_0_eq".
intros. symmetry. now apply Nat.le_0_r.
Qed.

Theorem le_n_S : forall n m, n <= m -> S n <= S m.
Proof. hammer_hook "Le" "Le.le_n_S".  exact (Peano.le_n_S). Qed.

Theorem le_S_n : forall n m, S n <= S m -> n <= m.
Proof. hammer_hook "Le" "Le.le_S_n".  exact (Peano.le_S_n). Qed.

Notation le_n_Sn := Nat.le_succ_diag_r (compat "8.4").
Notation le_Sn_n := Nat.nle_succ_diag_l (compat "8.4").

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof. hammer_hook "Le" "Le.le_Sn_le".  exact (Nat.lt_le_incl). Qed.

Hint Resolve le_0_n le_Sn_0: arith.
Hint Resolve le_n_S le_n_Sn le_Sn_n : arith.
Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith.

Notation le_pred_n := Nat.le_pred_l (compat "8.4").
Notation le_pred := Nat.pred_le_mono (compat "8.4").

Hint Resolve le_pred_n: arith.

Lemma le_elim_rel :
forall P:nat -> nat -> Prop,
(forall p, P 0 p) ->
(forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) ->
forall n m, n <= m -> P n m.
Proof. hammer_hook "Le" "Le.le_elim_rel".
intros P H0 HS.
induction n; trivial.
intros m Le. elim Le; auto with arith.
Qed.

Notation le_O_n := le_0_n (only parsing).
Notation le_Sn_O := le_Sn_0 (only parsing).
Notation le_n_O_eq := le_n_0_eq (only parsing).


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

Require Import PL.Imp3 PL.ImpExt4 PL.ImpExt5.

(* ################################################################# *)
(** * Task 1: Understanding Steps *)

(** Prove the following step relations. *)

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

Module Task1.
Import Abstract_Pretty_Printing.

Example step_sample1: forall (X: var) (st: state),
  st X = 5 ->
  astep st ((1 + X) * 2) ((1 + 5) * 2).
Proof.
  intros.
  apply AS_Mult1.
  apply AS_Plus2;[apply AH_num|].
  rewrite <- H.
  apply AS_Id.
Qed.
(** [] *)

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

Example step_sample2: forall (X: var) (st: state),
  cstep (If (0 <= (1 + 5) * 2) Then X ::= X - 1 Else Skip EndIf, st)%imp
        (If (0 <= 6 * 2) Then X ::= X - 1 Else Skip EndIf, st)%imp.
Proof.
  intros.
  apply CS_IfStep.
  apply BS_Le2;[apply AH_num|].
  apply AS_Mult1.
  apply AS_Plus.
Qed.

End Task1.

(* ################################################################# *)
(** * Task 2: Alternative Small Step Semantics *)

Module Task2.
Import Abstract_Pretty_Printing.
Local Open Scope imp.

(** Alice wrote an alternative definition of [cstep] as follows. Her purpose
    is to avoid administrative steps, i.e. the step from [Skip;; c] to [c]. *)

Inductive cstep' : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep' : forall st X a a',
      astep st a a' ->
      cstep' (CAss X a, st) (CAss X a', st)
  | CS_Ass' : forall st1 st2 X n,
      st2 X = n ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      cstep' (CAss X (ANum n), st1) (Skip, st2)
  | CS_SeqStep' : forall st c1 c1' st' c2,
      cstep' (c1, st) (c1', st') ->
      cstep' (c1 ;; c2 , st) (c1' ;; c2, st')
  | CS_Seq' : forall st c2 st' c2',
      cstep' (c2, st) (c2', st') ->
      cstep' (Skip ;; c2, st) (c2', st')   (* <- This is different. *)
  | CS_IfStep' : forall st b b' c1 c2,
      bstep st b b' ->
      cstep'
        (If b  Then c1 Else c2 EndIf, st)
        (If b'  Then c1 Else c2 EndIf, st)
  | CS_IfTrue' : forall st c1 c2,
      cstep' (If BTrue Then c1 Else c2 EndIf, st) (c1, st)
  | CS_IfFalse' : forall st c1 c2,
      cstep' (If BFalse Then c1 Else c2 EndIf, st) (c2, st)
  | CS_While' : forall st b c,
      cstep'
        (While b Do c EndWhile, st)
        (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).

(** But she is not sure, on what extent this [cstep'] is a well-defined
    semantics. Your task is to give her an answer using the following
    examples. *)

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

Definition claim1: Prop := forall (st: state) (X Y: var),
  st X = 1 ->
  cstep' (Skip;; Y ::= X, st) (Y ::= 1, st).

Fact claim1_veri : claim1.
Proof. hnf.
  intros.
  apply CS_Seq'.
  apply CS_AssStep'.
  rewrite <- H.
  apply AS_Id.
Qed.

(** Does [cstep'] satisfy this claim? 1: Yes. 2: No. *)

Definition my_choice1: Z := 1.
(** [] *)

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

Definition claim2: Prop := forall (st: state) (X: var),
  st X = 0 ->
  cstep' ((Skip;; Skip);; X ::= 0, st) (Skip, st).

(** Does [cstep'] satisfy this claim? 1: Yes. 2: No. *)

Definition my_choice2: Z := 2.
(** [] *)

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

Definition claim3: Prop := forall (st: state) (X: var),
  st X = 0 ->
  cstep' (Skip;; Skip;; X ::= 0, st) (Skip, st).

Fact claim3_veri : claim3.
Proof.
  hnf. intros.
  apply CS_Seq'.
  apply CS_Seq'.
  apply CS_Ass';[apply H|].
  intros. reflexivity.
Qed.
(** Does [cstep'] satisfy this claim? 1: Yes. 2: No. *)

Definition my_choice3: Z := 1.
(** [] *)

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

Definition claim4: Prop := forall (st: state),
  cstep' (Skip;; Skip;; Skip, st) (Skip, st).

(** Does [cstep'] satisfy this claim? 1: Yes. 2: No. *)

Definition my_choice4: Z := 2.
(** [] *)

End Task2.

(* ################################################################# *)
(** * Task 3: Middle Step Relation *)

Module Task3.
Import Abstract_Pretty_Printing.
Local Open Scope imp.

(** Between denotational semantics (also called big step semantics) and small
   step semantics, there could be other choices. The famous certified compiler
   CompCert formalizes the program semantics of C using "middle step semantics".
   Here is a similar version for [IMP]. *)

Inductive mstep : (com * state) -> (com * state) -> Prop :=
  | MS_Ass : forall st1 st2 X E,
      st2 X = aeval E st1 ->
      (forall Y, X <> Y -> st1 Y = st2 Y) ->
      mstep (CAss X E, st1) (Skip, st2)
  | MS_SeqStep : forall st c1 c1' st' c2,
      mstep (c1, st) (c1', st') ->
      mstep (c1 ;; c2 , st) (c1' ;; c2, st')
  | MS_Seq : forall st c2,
      mstep (Skip ;; c2, st) (c2, st)
  | MS_IfTrue : forall st b c1 c2,
      beval b st ->
      mstep (If b Then c1 Else c2 EndIf, st) (c1, st)
  | MS_IfFalse : forall st b c1 c2,
      ~ beval b st ->
      mstep (If b Then c1 Else c2 EndIf, st) (c2, st)
  | MS_WhileTrue : forall st b c,
      beval b st ->
      mstep
        (While b Do c EndWhile, st)
        (c;; While b Do c EndWhile, st)
  | MS_WhileFalse : forall st b c,
      ~ beval b st ->
      mstep (While b Do c EndWhile, st) (Skip, st).

Definition multi_mstep := clos_refl_trans mstep.

(** Your task is to prove half of the semantic equivalence between this
    middle step semantics and small step semantics. Specifically, your
    eventual goal is:

    Theorem Multi_MidStep_To_SmallStep: forall c st1 st2,
      multi_mstep (c, st1) (Skip, st2) ->
      multi_cstep (c, st1) (Skip, st2).

To prove this theorem, the main idea is to discover the relation between middle
steps [mstep] and small steps [cstep]. It is critical to see the following
observation: every middle step can be represented by finite small steps. In your
proof, you can freely use the following theorems, which we have demostrated in
class. *)

Check semantic_equiv_aexp1.

(* semantic_equiv_aexp1: forall st a n,
  aeval a st = n -> multi_astep st a (ANum n). *)

Check semantic_equiv_bexp1.

(* semantic_equiv_bexp1: forall st b,
  (beval b st -> multi_bstep st b BTrue) /\
  (~ beval b st -> multi_bstep st b BFalse). *)

Check multi_congr_CAss.

(* multi_congr_CAss: forall st X a a',
  multi_astep st a a' ->
  multi_cstep (CAss X a, st) (CAss X a', st). *)

Check multi_congr_CSeq.

(* multi_congr_CSeq: forall st1 c1 st1' c1' c2,
  multi_cstep (c1, st1) (c1', st1') ->
  multi_cstep (CSeq c1 c2, st1) (CSeq c1' c2, st1'). *)

Check multi_congr_CIf.

(* multi_congr_CIf: forall st b b' c1 c2,
  multi_bstep st b b' ->
  multi_cstep (CIf b c1 c2, st) (CIf b' c1 c2, st). *)

(** **** Exercise: 4 stars, standard (One_MidStep_To_SmallStep)  *)

(** Hint: In the following lemma, [a] and [b] are pairs of program commands and
    program states. You may use tactics like [ destruct a as [c1 st1] ] so that
    a real pair is demonstrated in the proof goal. But, you are the one to
    choose between destructing them and not destructing them, depending on
    which way is more convenient for building a Coq proof. *)

Lemma One_MidStep_To_SmallStep: forall a b,
  mstep a b -> multi_cstep a b.
Proof.
  intros.
  induction H.
  - symmetry in H. apply semantic_equiv_aexp1 in H.
    apply multi_congr_CAss with (X:=X)  in H.
    transitivity_n1 (X ::= st2 X, st1);auto.
    apply CS_Ass;auto.
  - apply multi_congr_CSeq. auto.
  - transitivity_n1 (Skip;; c2, st);[reflexivity|].
    apply CS_Seq.
  - apply (proj1 (semantic_equiv_bexp1 _ _)) in H.
    transitivity_n1 (If BTrue Then c1 Else c2 EndIf, st).
    + apply multi_congr_CIf. auto.
    + apply CS_IfTrue.
  - apply (proj2 (semantic_equiv_bexp1 _ _)) in H.
    transitivity_n1 (If BFalse Then c1 Else c2 EndIf, st).
    + apply multi_congr_CIf. auto.
    + apply CS_IfFalse.
  - apply (proj1 (semantic_equiv_bexp1 _ _)) in H.
    transitivity_1n (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).
    + apply CS_While.
    + transitivity_n1 (If BTrue Then c;; While b Do c EndWhile Else Skip EndIf, st).
      * apply multi_congr_CIf. auto.
      * apply CS_IfTrue.
  - apply (proj2 (semantic_equiv_bexp1 _ _)) in H.
    transitivity_1n (If b Then (c;; While b Do c EndWhile) Else Skip EndIf, st).
    + apply CS_While.
    + transitivity_n1 (If BFalse Then c;; While b Do c EndWhile Else Skip EndIf, st).
      * apply multi_congr_CIf. auto.
      * apply CS_IfFalse.
Qed.

(** Now, from this conclusion above to our final target, we only need two
    properties about reflexive transitive closures. *)

(** **** Exercise: 2 stars, standard (rt_idempotent)  *)
Theorem rt_idempotent : forall (X: Type) (R: X -> X -> Prop) (x y: X),
  clos_refl_trans (clos_refl_trans R) x y <-> clos_refl_trans R x y.
Proof.
  intros. split;intro.
  - induction H.
    + auto.
    + reflexivity.
    + transitivity y;auto.
  - apply rt_step. auto.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (rt_mono)  *)
Theorem rt_mono : forall (X: Type) (R1 R2: X -> X -> Prop),
  (forall x y, R1 x y -> R2 x y) ->
  (forall x y, clos_refl_trans R1 x y -> clos_refl_trans R2 x y).
Proof.
  intros.
  induction_n1 H0.
  - reflexivity.
  - transitivity_n1 y;auto.
Qed.
(** [] *)

(** Here is our final target! *)

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

Theorem Multi_MidStep_To_SmallStep: forall c st1 st2,
  multi_mstep (c, st1) (Skip, st2) ->
  multi_cstep (c, st1) (Skip, st2).
Proof.
  intros.
  induction H.
  + apply One_MidStep_To_SmallStep in H. auto.
  + reflexivity.
  + apply (rt_mono _ _ _ One_MidStep_To_SmallStep) in H.
    apply (rt_mono _ _ _ One_MidStep_To_SmallStep) in H0.
    apply rt_idempotent.
    transitivity y;auto.
Qed.
(** [] *)

End Task3.

(* Fri Apr 17 00:44:35 CST 2020 *)


Set Implicit Arguments.
Require Import List Lia std axioms.
Import ListNotations.

(** ** Multiplication Motivation  *)
Section Motivation.

  Variable (a b m n p: nat).

  Definition succ '(a, b) := (n + a, 1 + b).
  Definition ith i := (i * n + a, i + b).

  Section Streams.

    Implicit Type (X Y: nat -> (nat * nat)).

    Definition charac {A: Type} (X: nat -> A) (a: A) (Y: nat -> A) :=
      X 0 = a /\ forall n, X (S n) = Y n.

    Notation "X ≈ Y ⟶ Z" := (charac X Y Z) (at level 60).

    Definition Succ X  := X >> succ.

    Let X := ith.

    Lemma X_satisfies:
      X ≈ (a, b) ⟶ Succ X.
    Proof.
      split; unfold X, ith; cbn; intros; f_equal; lia.
    Qed.

    Lemma X_unique Y:
      (Y ≈ (a, b) ⟶ Succ Y) -> forall i, Y i = X i.
    Proof.
      intros H; induction i.
      - destruct H as [H _]. rewrite H. unfold X, ith. now simplify.
      - destruct H as [_ H]. unfold Succ, funcomp in *.
        rewrite H, IHi. unfold X, ith; cbn; f_equal; lia.
    Qed.

  End Streams.

  Section FiniteSequences.
    Implicit Type (X Y: list (nat * nat)).

    Notation succ' X := (map succ X).

    Lemma forward: p = m * n -> exists X, (a,b) :: succ' X = X ++ [(p + a, m + b)].
    Proof.
      intros ->. exists (tab ith m).
      rewrite tab_map. change (tab _ _ ++ _) with (tab ith (S m)).
      rewrite tab_S. unfold ith, succ. cbn. rewrite !tab_map_nats.
      f_equal. eapply map_ext. intros i. f_equal; lia.
    Qed.

    Lemma backward' X x:
      (a, b) :: succ' X = X ++ [x] -> x = ith (length X).
    Proof.
      unfold ith. induction X as [|[l r] X IH] in a, b, x |-*; eauto.
      - cbn; simplify. intuition congruence.
      - simplify. intros [= -> -> H]. eapply IH in H; subst.
        cbn; simplify; f_equal; lia.
    Qed.

    Lemma backward X:
      (a,b) :: succ' X = X ++ [(p + a, m + b)] -> m * n = p.
    Proof.
      intros H % backward'. injection H.
      intros; assert (m = |X|) as -> by lia. lia.
    Qed.
  End FiniteSequences.

End Motivation.


(** * 6.822 Formal Reasoning About Programs, Spring 2021 - Pset 3 *)

Require Import Frap.Frap.

(* three-way comparisions, and [cases] support for them *)
Notation Lt := (inleft (left _)) (only parsing).
Notation Eq := (inleft (right _)) (only parsing).
Notation Gt := (inright _) (only parsing).
Notation compare := Compare_dec.lt_eq_lt_dec.

Module Type S.
  Inductive tree {A} :=
  | Leaf
  | Node (l : tree) (d : A) (r : tree).
  Arguments tree : clear implicits.

  Fixpoint flatten {A} (t : tree A) : list A :=
    match t with
    | Leaf => []
    | Node l d r => flatten l ++ d :: flatten r
    end.

  Definition either {A} (xo yo : option A) : option A :=
    match xo with
    | None => yo
    | Some x => Some x
    end.

  (* 1a) HOFs: id and compose *)

  Definition id {A : Type} (x : A) : A := x.
  Definition compose {A B C : Type} (g : B -> C) (f : A -> B) (x : A) : C := g (f x).

  (*[0.5%]*)
  Parameter compose_id_l : forall (A B : Type) (f : A -> B), compose id f = f.

  (*[0.5%]*)
  Parameter compose_id_r : forall (A B : Type) (f : A -> B), compose f id = f.

  (*[1%]*)
  Parameter compose_assoc :
    forall (A B C D : Type) (f : A -> B) (g : B -> C) (h : C -> D),
      compose h (compose g f) = compose (compose h g) f.

  Fixpoint selfCompose{A: Type}(f: A -> A)(n: nat): A -> A :=
    match n with
    | O => id
    | S n' => compose f (selfCompose f n')
    end.

  Parameter exp : nat -> nat -> nat.
  (*[0.25%]*)
  Parameter test_exp_3_2 : exp 3 2 = 9.
  (*[0.25%]*)
  Parameter test_exp_4_1 : exp 4 1 = 4.
  (*[0.25%]*)
  Parameter test_exp_5_0 : exp 5 0 = 1.
  (*[0.25%]*)
  Parameter test_exp_1_3 : exp 1 3 = 1.

  (* 1b) HOFs: Left inverses *)

  Definition left_inverse{A B: Type}(f: A -> B)(g: B -> A): Prop := compose g f = id.

  (*[1%]*)
  Parameter plus2minus2 : left_inverse (fun x : nat => x + 2) (fun x : nat => x - 2).

  (*[2.5%]*)
  Parameter minus2plus2 : ~ left_inverse (fun x : nat => x - 2) (fun x : nat => x + 2).

  (*[4%]*)
  Parameter left_invertible_injective:
    forall {A} (f g: A -> A),
      left_inverse f g ->
      (forall x y, f x = f y -> x = y).

  (*[0.25%]*)
  Parameter left_inverse_id : forall {A : Type}, left_inverse (@id A) (@id A).

  (*[8%]*)
  Parameter invert_selfCompose :
    forall {A : Type} (f g : A -> A) (n : nat), left_inverse f g -> left_inverse (selfCompose f n) (selfCompose g n).

  (* 2a) Simple containers *)

  (*[0.25%]*)
  Parameter either_None_right : forall {A : Type} (xo : option A), either xo None = xo.

  (*[0.5%]*)
  Parameter either_assoc :
    forall {A : Type} (xo yo zo : option A), either (either xo yo) zo = either xo (either yo zo).

  Parameter head : forall {A : Type}, list A -> option A.

  (*[1%]*)
  Parameter head_example : head (1 :: 2 :: 3 :: nil) = Some 1.

  (*[1%]*)
  Parameter either_app_head :
    forall {A : Type} (xs ys : list A), head (xs ++ ys) = either (head xs) (head ys).

  Parameter leftmost_Node : forall {A : Type}, tree A -> option A.

  (*[1%]*)
  Parameter leftmost_Node_example : leftmost_Node (Node (Node Leaf 2 (Node Leaf 3 Leaf)) 1 Leaf) = Some 2.

  (*[4%]*)
  Parameter leftmost_Node_head : forall {A : Type} (t : tree A), leftmost_Node t = head (flatten t).

  (* 2b) bitwise tries *)

  Definition bitwise_trie A := tree (option A).

  Parameter lookup : forall {A : Type}, list bool -> bitwise_trie A -> option A.

  (*[1%]*)
  Parameter lookup_example1 : lookup nil (Node Leaf (None : option nat) Leaf) = None.

  (*[1%]*)
  Parameter lookup_example2 :
    lookup (false :: true :: nil)
           (Node (Node Leaf (Some 2) Leaf) None (Node (Node Leaf (Some 1) Leaf) (Some 3) Leaf)) =
    Some 1.

  (*[1%]*)
  Parameter lookup_empty : forall {A : Type} (k : list bool), lookup k (Leaf : bitwise_trie A) = None.

  Parameter insert : forall {A : Type}, list bool -> option A -> bitwise_trie A -> bitwise_trie A.

  (*[1%]*)
  Parameter insert_example1 : lookup nil (insert nil None (Node Leaf (Some 0) Leaf)) = None.

  (*[1%]*)
  Parameter insert_example2 :
    lookup nil (insert (true :: nil) (Some 2) (Node Leaf (Some 0) Leaf)) = Some 0.

  (*[8%]*)
  Parameter lookup_insert :
    forall {A : Type} (k : list bool) (v : option A) (t : bitwise_trie A), lookup k (insert k v t) = v.

  (*[2%]*)
  Parameter map_id : forall {A : Type} (xs : list A), List.map id xs = xs.

  (*[3%]*)
  Parameter map_compose :
    forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A),
      List.map (compose g f) xs = List.map g (List.map f xs).

  (*[4%]*)
  Parameter invert_map :
    forall (A B : Type) (f : A -> B) (g : B -> A), left_inverse f g -> left_inverse (List.map f) (List.map g).

  (* 2c) HOFs: tree_map *)

  Parameter tree_map : forall {A B : Type}, (A -> B) -> tree A -> tree B.

  (*[1%]*)
  Parameter tree_map_example :
    tree_map (fun x : nat => x + 1) (Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 (Node Leaf 4 Leaf))) =
    Node (Node Leaf 2 Leaf) 3 (Node Leaf 4 (Node Leaf 5 Leaf)).

  (*[8%]*)
  Parameter tree_map_flatten :
    forall (A B : Type) (f : A -> B) (t : tree A), flatten (tree_map f t) = List.map f (flatten t).

  Fixpoint tree_forall {A} (P: A -> Prop) (tr: tree A) :=
    match tr with
    | Leaf => True
    | Node l d r => tree_forall P l /\ P d /\ tree_forall P r
    end.

  Parameter tree_exists : forall {A: Type}, (A -> Prop) -> tree A -> Prop.

  (*[0.5%]*)
  Parameter tree_exists_Leaf :
    forall (A : Type) (P : A -> Prop), ~ tree_exists P Leaf.
  (*[3%]*)
  Parameter tree_forall_exists :
    forall (A : Type) (P : A -> Prop) (tr : tree A),
      tr <> Leaf -> tree_forall P tr -> tree_exists P tr.

  (*[2%]*)
  (* Explain what tree_forall_sound means *)

  (*[3%]*)
  Parameter tree_forall_sound :
    forall (A : Type) (P : A -> Prop) (tr : tree A),
      tree_forall P tr -> forall d : A, tree_exists (fun d' : A => d' = d) tr -> P d.

  (* 2d) Binary search trees *)

  Fixpoint listset (l: list nat) (s: nat -> Prop) :=
    match l with
    | [] =>
      (* An empty list represents an empty set *)
      forall x, ~ s x
    | hd :: tl =>
      (* Note how we remove an element from the propositional set: *)
      s hd /\ listset tl (fun x => x <> hd /\ s x)
    end.

  Fixpoint list_member (a: nat) (l: list nat) :=
    match l with
    | [] => false
    | hd :: tl =>
      if a ==n hd then true else list_member a tl
    end.

  (*[4%]*)
  Parameter list_member_lset: forall l s a,
      listset l s ->
      list_member a l = true <-> s a.

  (*[3%]*)
  Parameter list_member_lset': forall l s a,
      listset l s ->
      list_member a l = false <-> ~ (s a).

  Definition list_insert (a: nat) (l: list nat) :=
    if list_member a l then l else a :: l.

  (*[8%]*)
  Parameter list_insert_listset : forall l s a,
      listset l s ->
      listset (list_insert a l)
              (fun x => s x \/ x = a).

  Fixpoint bst (tr : tree nat) (s : nat -> Prop) :=
    match tr with
    | Leaf => forall x, not (s x) (* s is empty set *)
    | Node l d r =>
      s d /\
      bst l (fun x => s x /\ x < d) /\
      bst r (fun x => s x /\ d < x)
    end.

  (*[3%]*)
  Parameter bst_implies :
    forall (tr : tree nat) (s : nat -> Prop), bst tr s -> tree_forall s tr.

  (*[1%]*)
  Parameter bst_node_ordered :
    forall (l : tree nat) (d : nat) (r : tree nat) (s : nat -> Prop),
      bst (Node l d r) s ->
      tree_forall (fun x : nat => x < d) l /\ tree_forall (fun x : nat => x > d) r.

  (*[5%]*)
  Parameter bst_iff :
    forall (tr : tree nat) (P Q : nat -> Prop),
      bst tr P -> (forall x : nat, P x <-> Q x) -> bst tr Q.

  Fixpoint bst_member (a: nat) (tr: tree nat) : bool :=
    match tr with
    | Leaf => false
    | Node lt v rt =>
      match compare a v with
      | Lt => bst_member a lt
      | Eq => true
      | Gt => bst_member a rt
      end
    end.

  (*[10%]*)
  Parameter member_bst :
    forall (tr : tree nat) (s : nat -> Prop) (a : nat),
      bst tr s -> bst_member a tr = true <-> s a.
End S.

(* Here's a technical note on why this pset overrides a Frap tactic.
   There's no need to understand this at all.

   The "simplify" tactic provided by the Frap library is not quite suitable for this
   pset, because it does "autorewrite with core in *" (which we commented out below),
   and there's a Hint in Coq.Program.Combinators

        Hint Rewrite <- @compose_assoc : core.

   which causes "autorewrite with core in *." to have the
   same effect as

   rewrite <-? Combinators.compose_assoc.

   and apparently, rewrite does not just syntactic matching,
   but matching modulo unification, so it will replace
   our "compose" by "Basics.compose", and rewrite using
   associativity of "compose" as many times as it can.
   It's confusing to have "Basics.compose" appear in our goals,
   and rewriting with associativity is something we want to teach in this
   pset, so we redefine "simplify" to not use "autorewrite": *)
Ltac simplify ::=
  repeat (unifyTails; pose proof I); repeat match goal with
                                            | H:True |- _ => clear H
                                            end;
   repeat progress (simpl in *; intros(*; try autorewrite with core in * *); simpl_maps);
   repeat normalize_set || doSubtract.

Ltac cases E :=
  (is_var E; destruct E) ||
    match type of E with
    | sumor (sumbool _ _) _ => destruct E as [[]|]
    | {_} + {_} => destruct E
    | _ => let Heq := fresh "Heq" in
           destruct E eqn:Heq
    end;
   repeat
    match goal with
    | H:_ = left _ |- _ => clear H
    | H:_ = right _ |- _ => clear H
    | H:_ = inleft _ |- _ => clear H
    | H:_ = inright _ |- _ => clear H
    end.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Sampling an element from a finite cyclic group *)
Require Import fcf.FCF.
Require Export fcf.GroupTheory.

Local Open Scope group_scope.

Definition RndGrpElem`{FCG : FiniteCyclicGroup}{eqd : EqDec GroupElement} :=
    n <-$ [0 .. order);
    ret (g^n).

Section RndGrpElem.

  Context`{FCG : FiniteCyclicGroup}.
  Hypothesis GroupElement_EqDec : EqDec GroupElement.

  Theorem RndGrpElem_wf : well_formed_comp RndGrpElem.

    unfold RndGrpElem.
    wftac.

  Qed.

  Theorem groupExp_closed : forall k,
    In (g^k) (getSupport RndGrpElem).

    intuition.
    erewrite groupExp_mod.
    simpl.
    eapply in_getUnique.
    eapply in_flatten.
    econstructor.
    split.
    eapply in_map_iff.
    econstructor.
    split.
    eauto.
    eapply filter_In.
    split.
    eapply in_getUnique.
    eapply in_flatten.
    econstructor.
    split.
    eapply in_map_iff.
    econstructor.
    split.
    eapply eq_refl.
    eapply in_getAllBvectors.
    simpl.
    left.
    eapply eq_refl.
    Focus 2.
    rewrite bvToNat_natToBv_inverse.
    simpl.
    left.
    eapply eq_refl.
    eapply lognat_monotonic.
    eapply modNat_lt.
    rewrite bvToNat_natToBv_inverse.
    unfold ltNatBool.
    destruct (lt_dec (modNat k order) order); trivial.
    exfalso.
    eapply n.
    eapply modNat_lt.
    eapply lognat_monotonic.
    eapply modNat_lt.

    apply g_generator.
  Qed.

  Theorem RndGrpElem_uniform : forall x y,
    evalDist RndGrpElem x == evalDist RndGrpElem y.

    intuition.
    unfold RndGrpElem.

    eapply (evalDist_iso
              (fun z => (modNat (z + (modNatAddInverse (groupLog g y) order) + (groupLog g x))) order)
              (fun z => (modNat (z + (groupLog g y) + (modNatAddInverse (groupLog g x) order)) order))); intuition.

    rewrite <- plus_assoc.
    rewrite <- modNat_plus.
    assert ((x0 + groupLog g y + modNatAddInverse (groupLog g x) order +
      (modNatAddInverse (groupLog g y) order + groupLog g x)) =
    ((groupLog g y + modNatAddInverse (groupLog g y) order) +
      (groupLog g x + modNatAddInverse (groupLog g x) order +
      x0)))%nat.
    omega.
    rewrite H0.
    rewrite modNat_plus.
    rewrite modNatAddInverse_correct.
    rewrite plus_0_l.
    rewrite modNat_plus.
    rewrite modNatAddInverse_correct.
    rewrite plus_0_l.
    eapply modNat_eq.
    eapply RndNat_support_lt.
    trivial.

    rewrite <- plus_assoc.
    rewrite <- modNat_plus.
    assert ((x0 + modNatAddInverse (groupLog g y) order + groupLog g x +
      (groupLog g y + modNatAddInverse (groupLog g x) order)) =
    (groupLog g x + modNatAddInverse (groupLog g x) order +
      (groupLog g y + modNatAddInverse (groupLog g y) order + x0)))%nat.
    omega.
    rewrite H0.
    rewrite modNat_plus.
    rewrite modNatAddInverse_correct.
    rewrite plus_0_l.
    rewrite modNat_plus.
    rewrite modNatAddInverse_correct.
    rewrite plus_0_l.
    eapply modNat_eq.
    eapply RndNat_support_lt.
    trivial.

    eapply in_getSupport_RndNat.
    eapply modNat_lt.

    eapply RndNat_uniform.
    eapply modNat_lt.

    eapply RndNat_support_lt.
    trivial.

    subst.
    rewrite <- groupExp_mod.
    simpl.
    destruct (EqDec_dec GroupElement_EqDec (groupExp g x0) y); subst.
    rewrite groupExp_mod.
    rewrite modNat_plus.
    rewrite modNatAddInverse_correct_gen.
    rewrite plus_0_l.
    rewrite <- groupExp_mod.
    rewrite group_cyclic.
    destruct (EqDec_dec GroupElement_EqDec x x).
    intuition.
    congruence.
    apply g_generator.
    apply g_generator.

    symmetry.
    eapply groupLog_correct.
    apply g_generator.
    apply g_generator.

    destruct (EqDec_dec GroupElement_EqDec
         (groupExp g (x0 + modNatAddInverse (groupLog g y) order + groupLog g x)) x); intuition.
    exfalso.
    eapply n.
    rewrite groupExp_plus in e.
    rewrite group_cyclic in e.
    eapply ident_l_unique in e.
    rewrite <- (@groupIdent _ _ _ _ _ _ _ _ FCG g) in e.
    eapply groupExp_eq in e.
    rewrite (@modNat_eq order 0) in e.
    eapply modNatAddInverse_sum_0 in e.
    rewrite groupExp_mod.
    rewrite e.
    rewrite <- groupExp_mod.
    rewrite group_cyclic.
    trivial.
    apply g_generator.
    apply g_generator.
    apply g_generator.

    eapply posnat_pos.

    apply g_generator.
    apply g_generator.
    apply g_generator.
    apply g_generator.
  Qed.

  Theorem RndGrpElem_spec :
    forall x y,
      comp_spec (fun a b => a = x <-> b = y) RndGrpElem RndGrpElem.

    intuition.
    eapply eq_impl_comp_spec; eauto using RndGrpElem_wf.
    eapply RndGrpElem_uniform.

  Qed.

End RndGrpElem.

Notation "'RndG'" := (RndGrpElem)
  (right associativity, at level 75) : comp_scope.


Inductive day : Type :=
    | mon
    | tue
    | wed
    | thu
    | fri
    | sat
    | sun.

Definition nextday (d: day) : day :=
    match d with
    | mon => tue
    | tue => wed
    | wed => thu
    | thu => fri
    | fri => sat
    | sat => sun
    | sun => mon
    end.

Compute (nextday fri).
Compute (nextday (nextday sun)).

Example testnext:
    (nextday (nextday sat)) = mon.

Proof. simpl. reflexivity. Qed.

Inductive bool: Type :=
    | true
    | false.

Definition negb (b: bool) : bool :=
    match b with
    | true => false
    | false => true
    end.

Definition andb (b1: bool) (b2: bool) : bool :=
    match b1 with
    | true => b2
    | false => false
    end.

Definition orb (b1: bool) (b2: bool) : bool :=
    match b1 with
    | true => true
    | false => b2
    end.

Definition  nandb (b1: bool) (b2: bool) : bool :=
    negb (andb b1 b2).

Example test1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.

(* Example test2: (andb true false) = true.
Proof. simpl. reflexivity. Qed. *)

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Compute (true && false).

Example test3: false || true || false = true.
Proof. simpl. reflexivity. Qed.

Example test4: nandb true true = false.
Proof. simpl. reflexivity. Qed.

Check true.
Check negb.

Inductive rgb: Type :=
    | red
    | green
    | blue.

Inductive color: Type :=
    | black
    | white
    | primary (p: rgb).

Definition monochrome (c: color) : bool :=
    match c with
    | black => true
    | white => true
    | primary q => false
    end.

Definition isred (c: color) : bool :=
    match c with
    | black => false
    | white => false
    | primary red => true
    | primary _ => false
    end.

Compute (monochrome (primary red)).
Compute (isred (primary red)).

Check primary.

Inductive bit: Type :=
    | B0
    | B1.

Inductive nybble: Type :=
    | bits (b0 b1 b2 b3 : bit).

Check (bits B1 B0 B1 B0).

Definition allzero (nb: nybble) : bool :=
    match nb with
    | (bits B0 B0 B0 B0) => true
    | _ => false
    end.

Compute (allzero (bits B1 B0 B1 B0)).
Compute (allzero (bits B0 B0 B0 B0)).


(* week-06_soundness-and-completeness-of-equality-predicates.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 20 Sep 2020 *)

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

(* Paraphernalia: *)

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Require Import Arith Bool.

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

Check Bool.eqb. (* : bool -> bool -> bool *)

Check eqb. (* : bool -> bool -> bool *)

Search (eqb _ _ = true -> _ = _).
(* eqb_prop: forall a b : bool, eqb a b = true -> a = b *)

Search (eqb _ _ = true).
(* eqb_reflx: forall b : bool, eqb b b = true *)

Theorem soundness_of_equality_over_booleans :
  forall b1 b2 : bool,
    eqb b1 b2 = true -> b1 = b2.
Proof.
  exact eqb_prop.

  Restart.

  intros [ | ] [ | ].
  - intros _.
    reflexivity.
  - unfold eqb.
    intro H_absurd.
    discriminate H_absurd.
  - unfold eqb.
    intro H_absurd.
    exact H_absurd.
  - intros _.
    reflexivity.
Qed.

Theorem completeness_of_equality_over_booleans :
  forall b1 b2 : bool,
    b1 = b2 -> eqb b1 b2 = true.
Proof.
  intros b1 b2 H_b1_b2.
  rewrite <- H_b1_b2.
  Search (eqb _ _ = true).
  Check (eqb_reflx b1).
  exact (eqb_reflx b1).

  Restart.

  intros [ | ] [ | ].
  - intros _.
    unfold eqb.
    reflexivity.
  - intros H_absurd.
    discriminate H_absurd.
  - intros H_absurd.
    discriminate H_absurd.
  - intros _.
    unfold eqb.
    reflexivity.
Qed.

Corollary soundness_of_equality_over_booleans_the_remaining_case :
  forall b1 b2 : bool,
    eqb b1 b2 = false -> b1 <> b2.
Proof.
  intros b1 b2 H_eqb_b1_b2.
  unfold not.
  intros H_eq_b1_b2.
  Check (completeness_of_equality_over_booleans b1 b2 H_eq_b1_b2).
  rewrite -> (completeness_of_equality_over_booleans b1 b2 H_eq_b1_b2) in H_eqb_b1_b2.
  discriminate H_eqb_b1_b2.
Qed.

Corollary completeness_of_equality_over_booleans_the_remaining_case :
  forall b1 b2 : bool,
    b1 <> b2 -> eqb b1 b2 = false.
Proof.
  intros b1 b2 H_neq_b1_b2.
  unfold not in H_neq_b1_b2.
  Search (not (_ = true) -> _ = false).
  Check (not_true_is_false (eqb b1 b2)).
  apply (not_true_is_false (eqb b1 b2)).
  unfold not.
  intro H_eqb_b1_b2.
  Check (soundness_of_equality_over_booleans b1 b2 H_eqb_b1_b2).
  Check (H_neq_b1_b2 (soundness_of_equality_over_booleans b1 b2 H_eqb_b1_b2)).
  contradiction (H_neq_b1_b2 (soundness_of_equality_over_booleans b1 b2 H_eqb_b1_b2)).
(* Or alternatively:
  exact (H_neq_b1_b2 (soundness_of_equality_over_booleans b1 b2 H_eqb_b1_b2)).
*)
Qed.

Check Bool.eqb_eq.
(* eqb_eq : forall x y : bool, Is_true (eqb x y) -> x = y *)

Search (eqb _ _ = true).
(* eqb_true_iff: forall a b : bool, eqb a b = true <-> a = b *)

Theorem soundness_and_completeness_of_equality_over_booleans :
  forall b1 b2 : bool,
    eqb b1 b2 = true <-> b1 = b2.
Proof.
  exact eqb_true_iff.

  Restart.

  intros b1 b2.
  split.
  - exact (soundness_of_equality_over_booleans b1 b2).
  - exact (completeness_of_equality_over_booleans b1 b2).
Qed.

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

Check Nat.eqb. (* : nat -> nat -> bool *)

Check beq_nat. (* : nat -> nat -> bool *)

Search (beq_nat _ _ = true -> _ = _).
(* beq_nat_true: forall n m : nat, (n =? m) = true -> n = m *)

Search (beq_nat _ _ = true).

(* Nat.eqb_eq: forall n m : nat, (n =? m) = true <-> n = m *)

Theorem soundness_and_completeness_of_equality_over_natural_numbers :
  forall n1 n2 : nat,
    n1 =? n2 = true <-> n1 = n2.
Proof.
  exact Nat.eqb_eq.
Qed.

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

Theorem soundness_and_completeness_of_equality_over_natural_numbers_the_remaining_case :
  forall n1 n2 : nat,
    n1 =? n2 = false <-> n1 <> n2.
Proof.
  intros n1 n2.
  unfold not.
  split.
  - intros H_eqb H_eq.
    Check (soundness_and_completeness_of_equality_over_natural_numbers n1 n2).
    destruct (soundness_and_completeness_of_equality_over_natural_numbers n1 n2) as [_ C_eqb_nat].
    rewrite -> (C_eqb_nat H_eq) in H_eqb.
    discriminate H_eqb.
  - intros H_eq.
    Search (_ <> true -> _ = false).
    apply (not_true_is_false (n1 =? n2)).
    unfold not.
    intro H_eqb.
    destruct (soundness_and_completeness_of_equality_over_natural_numbers n1 n2) as [C_eqb_nat _].
    contradiction (H_eq (C_eqb_nat H_eqb)).
Qed.

Lemma from_one_equivalence_to_two_implications :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true <-> v1 = v2) ->
    (forall v1 v2 : V,
        eqb_V v1 v2 = true -> v1 = v2)
    /\
    (forall v1 v2 : V,
        v1 = v2 -> eqb_V v1 v2 = true).
Proof.
  intros V eqb_V H_eqv.
  split.
  - intros v1 v2 H_eqb.
    destruct (H_eqv v1 v2) as [H_key _].
    exact (H_key H_eqb).
  - intros v1 v2 H_eq.
    destruct (H_eqv v1 v2) as [_ H_key].
    exact (H_key H_eq).
Qed.

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

Definition eqb_option (V : Type) (eqb_V : V -> V -> bool) (ov1 ov2 : option V) : bool :=
  match ov1 with
  | Some v1 =>
    match ov2 with
    | Some v2 =>
      eqb_V v1 v2
    | None =>
      false
    end
  | None =>
    match ov2 with
    | Some v2 =>
      false
    | None =>
      true
    end
  end.

Theorem soundness_of_equality_over_optional_values :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true -> v1 = v2) ->
    forall ov1 ov2 : option V,
      eqb_option V eqb_V ov1 ov2 = true ->
      ov1 = ov2.
Proof.
  intros V eqb_V S_eqb_V [v1 | ] [v2 | ] H_eqb.
  - unfold eqb_option in H_eqb.
    Check (S_eqb_V v1 v2 H_eqb).
    rewrite -> (S_eqb_V v1 v2 H_eqb).
    reflexivity.
  - unfold eqb_option in H_eqb.
    discriminate H_eqb.
  - unfold eqb_option in H_eqb.
    discriminate H_eqb.
  - reflexivity.
Qed.

Theorem completeness_of_equality_over_optional_values :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        v1 = v2 -> eqb_V v1 v2 = true) ->
    forall ov1 ov2 : option V,
      ov1 = ov2 ->
      eqb_option V eqb_V ov1 ov2 = true.
Proof.
  intros V eqb_V C_eqb_V ov1 ov2 H_eq.
  rewrite -> H_eq.
  case ov1 as [v1 | ].
  - case ov2 as [v2 | ].
    -- unfold eqb_option.
       Check (eq_refl v2).
       Check (C_eqb_V v2 v2 (eq_refl v2)).
       exact (C_eqb_V v2 v2 (eq_refl v2)).
    -- discriminate H_eq.
  - case ov2 as [v2 | ].
    -- discriminate H_eq.
    -- unfold eqb_option.
       reflexivity.
Qed.

Theorem soundness_and_completeness_of_equality_over_optional_values :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true <-> v1 = v2) ->
    forall ov1 ov2 : option V,
      eqb_option V eqb_V ov1 ov2 = true <-> ov1 = ov2.
Proof.
  intros V eqb_V SC_eqb_V.
  Check (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V).
  destruct (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V) as [S_eqb_V C_eqb_V].
  intros ov1 ov2.
  split.
  - exact (soundness_of_equality_over_optional_values V eqb_V S_eqb_V ov1 ov2).
  - exact (completeness_of_equality_over_optional_values V eqb_V C_eqb_V ov1 ov2).
Qed.

(*** Exercise 7 *)
(* ... *)

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

Definition eqb_pair (V : Type) (eqb_V : V -> V -> bool) (W : Type) (eqb_W : W -> W -> bool) (p1 p2 : V * W) : bool :=
  let (v1, w1) := p1 in
  let (v2, w2) := p2 in
  eqb_V v1 v2 && eqb_W w1 w2.

Theorem soundness_of_equality_over_pairs :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true -> v1 = v2) ->
    forall (W : Type)
           (eqb_W : W -> W -> bool),
      (forall w1 w2 : W,
          eqb_W w1 w2 = true -> w1 = w2) ->
      forall p1 p2 : V * W,
        eqb_pair V eqb_V W eqb_W p1 p2 = true ->
        p1 = p2.
Proof.
  intros V eqb_V S_eqb_V W eqb_W S_eqb_W [v1 w1] [v2 w2] H_eqb.
  unfold eqb_pair in H_eqb.
  Search (_ && _ = true -> _ /\ _).
  Check (andb_prop (eqb_V v1 v2) (eqb_W w1 w2)).
  Check (andb_prop (eqb_V v1 v2) (eqb_W w1 w2) H_eqb).
  destruct (andb_prop (eqb_V v1 v2) (eqb_W w1 w2) H_eqb) as [H_eqb_V H_eqb_W].
  Check (S_eqb_V v1 v2 H_eqb_V).
  rewrite -> (S_eqb_V v1 v2 H_eqb_V).
  rewrite -> (S_eqb_W w1 w2 H_eqb_W).
  reflexivity.
Qed.

Theorem completeness_of_equality_over_pairs :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        v1 = v2 -> eqb_V v1 v2 = true) ->
    forall (W : Type)
           (eqb_W : W -> W -> bool),
      (forall w1 w2 : W,
          w1 = w2 -> eqb_W w1 w2 = true) ->
      forall p1 p2 : V * W,
        p1 = p2 ->
        eqb_pair V eqb_V W eqb_W p1 p2 = true.
Proof.
  intros V eqb_V S_eqb_V W eqb_W S_eqb_W [v1 w1] [v2 w2] H_eq.
  unfold eqb_pair.
  injection H_eq as H_eq_V H_eq_W.
  Check (S_eqb_V v1 v2 H_eq_V).
  rewrite -> (S_eqb_V v1 v2 H_eq_V).
  rewrite -> (S_eqb_W w1 w2 H_eq_W).
  unfold andb.
  reflexivity.
Qed.

Theorem soundness_and_completeness_of_equality_over_pairs :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true <-> v1 = v2) ->
    forall (W : Type)
           (eqb_W : W -> W -> bool),
      (forall w1 w2 : W,
          eqb_W w1 w2 = true <-> w1 = w2) ->
      forall p1 p2 : V * W,
        eqb_pair V eqb_V W eqb_W p1 p2 = true <-> p1 = p2.
Proof.
  intros V eqb_V SC_eqb_V.
  Check (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V).
  destruct (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V) as [S_eqb_V C_eqb_V].
  intros W eqb_W SC_eqb_W.
  Check (from_one_equivalence_to_two_implications W eqb_W SC_eqb_W).
  destruct (from_one_equivalence_to_two_implications W eqb_W SC_eqb_W) as [S_eqb_W C_eqb_W].
  intros p1 p2.
  split.
  - exact (soundness_of_equality_over_pairs V eqb_V S_eqb_V W eqb_W S_eqb_W p1 p2).
  - exact (completeness_of_equality_over_pairs V eqb_V C_eqb_V W eqb_W C_eqb_W p1 p2).
Qed.

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

Inductive binary_tree (V : Type) : Type :=
| Leaf : V -> binary_tree V
| Node : binary_tree V -> binary_tree V -> binary_tree V.

Fixpoint eqb_binary_tree (V : Type) (eqb_V : V -> V -> bool) (t1 t2 : binary_tree V) : bool :=
  match t1 with
  | Leaf _ v1 =>
    match t2 with
    | Leaf _ v2 =>
      eqb_V v1 v2
    | Node _ t11 t12 =>
      false
    end
  | Node _ t11 t12 =>
    match t2 with
    | Leaf _ v2 =>
      false
    | Node _ t21 t22 =>
      eqb_binary_tree V eqb_V t11 t21
      &&
      eqb_binary_tree V eqb_V t12 t22
    end
  end.

Lemma fold_unfold_eqb_binary_tree_Leaf :
  forall (V : Type)
         (eqb_V : V -> V -> bool)
         (v1 : V)
         (t2 : binary_tree V),
    eqb_binary_tree V eqb_V (Leaf V v1) t2 =
    match t2 with
    | Leaf _ v2 =>
      eqb_V v1 v2
    | Node _ t11 t12 =>
      false
    end.
Proof.
  fold_unfold_tactic eqb_binary_tree.
Qed.

Lemma fold_unfold_eqb_binary_tree_Node :
  forall (V : Type)
         (eqb_V : V -> V -> bool)
         (t11 t12 t2 : binary_tree V),
    eqb_binary_tree V eqb_V (Node V t11 t12) t2 =
    match t2 with
    | Leaf _ v2 =>
      false
    | Node _ t21 t22 =>
      eqb_binary_tree V eqb_V t11 t21
      &&
      eqb_binary_tree V eqb_V t12 t22
    end.
Proof.
  fold_unfold_tactic eqb_binary_tree.
Qed.

Theorem soundness_of_equality_over_binary_trees :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true -> v1 = v2) ->
    forall t1 t2 : binary_tree V,
      eqb_binary_tree V eqb_V t1 t2 = true ->
      t1 = t2.
Proof.
  intros V eqb_V C_eqb_V t1.
  induction t1 as [v1 | t11 IHt11 t12 IHt12].
  - intros [v2 | t21 t22] H_eqb.
    -- rewrite -> (fold_unfold_eqb_binary_tree_Leaf V eqb_V v1 (Leaf V v2)) in H_eqb.
       Check (C_eqb_V v1 v2 H_eqb).
       rewrite -> (C_eqb_V v1 v2 H_eqb).
       reflexivity.
    -- rewrite -> (fold_unfold_eqb_binary_tree_Leaf V eqb_V v1 (Node V t21 t22)) in H_eqb.
       discriminate H_eqb.
  - intros [v2 | t21 t22] H_eqb.
    -- rewrite -> (fold_unfold_eqb_binary_tree_Node V eqb_V t11 t12 (Leaf V v2)) in H_eqb.
       discriminate H_eqb.
    -- rewrite -> (fold_unfold_eqb_binary_tree_Node V eqb_V t11 t12 (Node V t21 t22)) in H_eqb.
       Search (_ && _ = true -> _ /\ _).
       Check (andb_prop (eqb_binary_tree V eqb_V t11 t21) (eqb_binary_tree V eqb_V t12 t22)).
       Check (andb_prop (eqb_binary_tree V eqb_V t11 t21) (eqb_binary_tree V eqb_V t12 t22) H_eqb).
       destruct (andb_prop (eqb_binary_tree V eqb_V t11 t21) (eqb_binary_tree V eqb_V t12 t22) H_eqb) as [H_eqb_1 H_eqb_2].
       Check (IHt11 t21 H_eqb_1).
       rewrite -> (IHt11 t21 H_eqb_1).
       rewrite -> (IHt12 t22 H_eqb_2).
       reflexivity.
Qed.

Theorem completeness_of_equality_over_binary_trees :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        v1 = v2 -> eqb_V v1 v2 = true) ->
    forall t1 t2 : binary_tree V,
      t1 = t2 ->
      eqb_binary_tree V eqb_V t1 t2 = true.
Proof.
  intros V eqb_V C_eqb_V t1.
  induction t1 as [v1 | t11 IHt11 t12 IHt12].
  - intros [v2 | t21 t22] H_eq.
    -- rewrite -> (fold_unfold_eqb_binary_tree_Leaf V eqb_V v1 (Leaf V v2)).
       injection H_eq as H_eq_V.
       Check (C_eqb_V v1 v2).
       Check (C_eqb_V v1 v2 H_eq_V).
       exact (C_eqb_V v1 v2 H_eq_V).
    -- discriminate H_eq.
  - intros [v2 | t21 t22] H_eq.
    -- discriminate H_eq.
    -- rewrite -> (fold_unfold_eqb_binary_tree_Node V eqb_V t11 t12 (Node V t21 t22)).
       injection H_eq as H_eq_1 H_eq_2.
       Check (IHt11 t21 H_eq_1).
       rewrite -> (IHt11 t21 H_eq_1).
       rewrite -> (IHt12 t22 H_eq_2).
       unfold andb.
       reflexivity.
Qed.

Theorem soundness_and_completeness_of_equality_over_binary_trees :
  forall (V : Type)
         (eqb_V : V -> V -> bool),
    (forall v1 v2 : V,
        eqb_V v1 v2 = true <-> v1 = v2) ->
    forall t1 t2 : binary_tree V,
      eqb_binary_tree V eqb_V t1 t2 = true <-> t1 = t2.
Proof.
  intros V eqb_V SC_eqb_V t1 t2.
  Check (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V).
  destruct (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V) as [S_eqb_V C_eqb_V].
  split.
  - exact (soundness_of_equality_over_binary_trees V eqb_V S_eqb_V t1 t2).
  - exact (completeness_of_equality_over_binary_trees V eqb_V C_eqb_V t1 t2).

  Restart.

  intros V eqb_V SC_eqb_V t1.
  induction t1 as [v1 | t11 IHt11 t12 IHt12].
  - intros [v2 | t21 t22].
    + rewrite -> (fold_unfold_eqb_binary_tree_Leaf V eqb_V v1 (Leaf V v2)).
      split.
      * intro H_eqb_V.
        destruct (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V) as [S_eqb_V _].
        rewrite -> (S_eqb_V v1 v2 H_eqb_V).
        reflexivity.
      * intro H_eq.
        injection H_eq as H_eq.
        destruct (from_one_equivalence_to_two_implications V eqb_V SC_eqb_V) as [_ C_eqb_V].
        exact (C_eqb_V v1 v2 H_eq).
    + rewrite -> (fold_unfold_eqb_binary_tree_Leaf V eqb_V v1 (Node V t21 t22)).
      split.
      * intro H_absurd.
        discriminate H_absurd.
      * intro H_absurd.
        discriminate H_absurd.
  - intros [v2 | t21 t22].
    + rewrite -> (fold_unfold_eqb_binary_tree_Node V eqb_V t11 t12 (Leaf V v2)).
      split.
      * intro H_absurd.
        discriminate H_absurd.
      * intro H_absurd.
        discriminate H_absurd.
    + rewrite -> (fold_unfold_eqb_binary_tree_Node V eqb_V t11 t12 (Node V t21 t22)).
      split.
      * intro H_eqb.
        destruct (andb_prop (eqb_binary_tree V eqb_V t11 t21) (eqb_binary_tree V eqb_V t12 t22) H_eqb) as [H_eqb_1 H_eqb_2].
        destruct (IHt11 t21) as [H_key1 _].
        destruct (IHt12 t22) as [H_key2 _].
        rewrite -> (H_key1 H_eqb_1).
        rewrite -> (H_key2 H_eqb_2).
        reflexivity.
      * intro H_eq.
        injection H_eq as H_eq_1 H_eq_2.
        destruct (IHt11 t21) as [_ H_key1].
        destruct (IHt12 t22) as [_ H_key2].
        rewrite -> (H_key1 H_eq_1).
        rewrite -> (H_key2 H_eq_2).
        unfold andb.
        reflexivity.
Qed.

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

(* end of week-06_soundness-and-completeness-of-equality-predicates.v *)