Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.Znumtheory.

Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Circom.Tuple.
Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import BabyJubjub.
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Crypto.Algebra.Ring Crypto.Algebra.Field.

Require Import Circom.Circom Circom.DSL Circom.Tuple.

(* Circuit:
* https://github.com/iden3/circomlib/blob/master/circuits/multiplexer.circom
*)

Local Open Scope list_scope.
Local Open Scope F_scope.

Module Multiplexer.

Module D := DSL.

Local Open Scope list_scope.
Local Open Scope F_scope.
Local Open Scope tuple_scope.

(* template EscalarProduct(w) {
    signal input in1[w];
    signal input in2[w];
    signal output out;
    signal aux[w];
    var lc = 0;
    for (var i=0; i<w; i++) {
        aux[i] <== in1[i]*in2[i];
        lc = lc + aux[i];
    }
    out <== lc;
} *)

Definition EscalarProduct w (in1 in2: tuple F w) out : Prop :=
  exists (aux: tuple F w),
  let lc := 0 in
  let '(lc, _C) := (D.iter (fun i '(lc, _C) =>
      (lc + aux[i],
      (aux[i] = in1[i] * in2[i]) /\ _C))
    w
    (lc, True)) in
  (lc = out) /\ _C.

Definition EscalarProductSpec n w (in1 in2 : tuple F w) out :=
  out = List.fold_right (fun a b : F => a + b) 0
         (firstn n (to_list w (map2 (fun a b : F => a * b) in1 in2))).

Theorem EscalarProductSoundness:
  forall w in1 in2 out,
  EscalarProduct w in1 in2 out -> EscalarProductSpec w w in1 in2 out.
Proof.
  unfold EscalarProduct. unfold EscalarProductSpec.
  (* iter initialization *)
  remember (0, True) as a0.
  intros. destruct H as [aux].
  (* iter Invariant *)
  pose (Inv := fun i '((lc1, _C): (F.F q * Prop)) =>
       (_C -> EscalarProductSpec i w in1 in2 out)).
  (* iter function *)
  match goal with
  | [ H: context[match ?it ?f ?n ?init with _ => _ end] |- _ ] =>
    let x := fresh "f" in remember f as x
  end.
  (* invariant holds *)
  assert (Hinv: forall i, Inv i (D.iter f i a0)). {
  intros. apply D.iter_inv; unfold Inv.
  - (* base case *)
    subst. intros. unfold EscalarProductSpec in *. admit.
  - (* inductive case *)
    intros j res Hprev.
    destruct res.
    rewrite Heqf.
    intros.
    destruct H1 as [Hstep HP].
    specialize  (Hprev HP).
    assert (H_j0_leq: (j < S j)%nat) by lia.
    admit.
   }
  unfold Inv in Hinv.
  specialize (Hinv O).
  destruct (D.iter f O a0).
  intuition.
Abort.

(* template Decoder(w) {
    signal input inp;
    signal output out[w];
    signal output success;
    var lc=0;

    for (var i=0; i<w; i++) {
        out[i] <-- (inp == i) ? 1 : 0;
        out[i] * (inp-i) === 0;
        lc = lc + out[i];
    }

    lc ==> success;
    success * (success -1) === 0;
} *)

Definition ite {T:Type}{T1:Prop} (e: Decidable T1) (a b: T) := if e then a else b.

Definition Decoder w inp (out: tuple F w) success : Prop :=
  let lc := 0 in
  let '(lc, _C) := (D.iter (fun i '(lc, _C) =>
      (lc + out[i],
        (out[i] = ite (F.eq_dec inp (F.of_nat q i)) 1 0) /\
        (out[i] * (inp - (F.of_nat q i)) = 0) /\ _C))
    w
    (lc, True)) in
  (lc = success) /\ (success * (success -1) = 0) /\ _C.

Definition get_n_m {wIn nIn}(t: tuple (tuple F wIn) (S nIn)) p m :=
  let ins := (nth_default (hd t) p t) in
  nth_default 0 m ins.

(* template Multiplexer(wIn, nIn) {
    signal input inp[nIn][wIn];
    signal input sel;
    signal output out[wIn];
    component dec = Decoder(nIn);
    component ep[wIn];

    for (var k=0; k<wIn; k++) {
        ep[k] = EscalarProduct(nIn);
    }

    sel ==> dec.inp;
    for (var j=0; j<wIn; j++) {
        for (var k=0; k<nIn; k++) {
            inp[k][j] ==> ep[j].in1[k];
            dec.out[k] ==> ep[j].in2[k];
        }
        ep[j].out ==> out[j];
    }
    dec.success === 1;
} *)

(* require: nIn > 0 *)
Definition Multiplexer
  wIn nIn sel (inp: tuple (tuple F wIn) (S (nIn - 1)))
  (out: tuple F wIn) : Prop :=
exists (ep_in1 ep_in2: tuple (tuple F nIn) (S (wIn - 1))) (ep_out: tuple F nIn) dec_out,
  let '_C2 := (D.iter  (fun j '_C =>
      (let '_C3 := (D.iter (fun k '_C =>
          (get_n_m inp k j = get_n_m ep_in1 j k /\
           dec_out[k] = get_n_m ep_in2 j k /\ _C))
           nIn True) in
              ep_out[j] = out[j] /\
              EscalarProduct nIn (nth_default (hd ep_in1) j ep_in1) (nth_default (hd ep_in2) j ep_in2) (ep_out[j]) /\ _C3
        ))
    wIn True) in
  (Decoder nIn sel dec_out 1) /\ _C2.

End Multiplexer.


(* Add Rec LoadPath "/Users/dpereira/Source/Containers/theories" as Containers. *)
(* Add ML Path "/Users/dpereira/Source/Containers/src". *)

Require Import Wellfounded Wf_nat Lexicographic_Product Relation_Operators.
Require Export Sets SetProperties Generate SetConstructs.
Require Import (*base*) generic_finite_sets.
Require Import NArith NArith.Nnat.

Section LIM_CARD.

  Variable A:Type.
  Context `{AOrd : OrderedType A}.

  Inductive lim_card (z:nat) : set A -> set A -> Prop :=
  | in_re_set : forall x y:set A,
    z - (cardinal x) < z - (cardinal y) -> lim_card z x y.

  Definition lim_cardN (z:N) : relation (set A) :=
  fun x y:set A => nat_of_N z - (cardinal x) < nat_of_N z - (cardinal y).

  Theorem le_trans1 : forall n m p, n <= m -> m <= p -> n <= p.
  Proof.
    induction 2; auto.
  Defined.

  Theorem le_S_n1 : forall n m, S n <= S m -> n <= m.
  Proof.
    intros n m H; change (pred (S n) <= pred (S m)) in |- *.
    destruct H; simpl.
    constructor.
    apply (le_trans1 _ (S n) _).
    constructor.
    constructor.
    exact H.
  Defined.

  Lemma lim_card_wf : forall z,  well_founded (lim_card z).
  Proof.
    unfold well_founded.
    intros.
    cut(forall n a, lt (z - (cardinal a)) n -> Acc (lim_card z) a).
    intros.
    eapply H with (S (z - (cardinal a))).
    unfold lt.
    constructor.

    induction n;intros.
    inversion H.
    constructor;intros.
    inversion_clear H0.
    apply IHn.
    unfold lt in H, H1.
    unfold lt.
    apply (@le_trans1 _ _ _ H1).
    apply le_S_n1 in H.
    exact H.
  Defined.

  Lemma lim_card_lim_cardN_inclusion :
    forall z, inclusion (set A) (lim_cardN z) (lim_card (nat_of_N z)).
  Proof.
    repeat red.
    intros.
    unfold lim_cardN in H.
    constructor.
    assumption.
  Qed.

  Lemma lim_cardN_wf : forall z, well_founded (lim_cardN z).
  Proof.
    intro z.
    red.
    eapply wf_incl.
    eapply lim_card_lim_cardN_inclusion.
    apply lim_card_wf.
  Qed.

  (* Definition dec_H (x y:set A) := *)
  (*   cardinal x < cardinal y. *)

  (* Lemma dec_H_wf : well_founded dec_H. *)
  (* Proof. *)
  (*   red. *)
  (*   intros. *)
  (*   apply Acc_inverse_image. *)
  (*   apply Wf_nat.lt_wf. *)
  (* Defined. *)

  Open Scope N_scope.

  Fixpoint pow2N(n:nat):N :=
    match n with
      | O => 1
      | S m => 2 * pow2N m
    end.

  Lemma pow2N_S : forall n,
    pow2N (S n) = 2*pow2N n.
  Proof.
    induction n.
    reflexivity.
    destruct n;auto with arith.
  Qed.

  Close  Scope N_scope.

  Lemma pow2N_S_nat : forall n,
    nat_of_N (pow2N (S n)) = 2*nat_of_N (pow2N n).
  Proof.
    induction n.
    reflexivity.
    rewrite pow2N_S.
    rewrite nat_of_Nmult.
    rewrite IHn.
    reflexivity.
  Qed.

  Fixpoint pow2(n:nat):nat :=
    match n with
      | O => 1
      | S m => 2 * pow2 m
    end.

  Lemma pow2_pow2N_equiv : forall n,
    nat_of_N (pow2N n) = pow2 n.
  Proof.
    induction n.
    simpl.
    reflexivity.
    rewrite pow2N_S_nat.
    rewrite IHn.
    simpl.
    omega.
  Qed.

  Lemma pow2_S : forall n,
    pow2 (S n) = 2*pow2 n.
  Proof.
    induction n;simpl;omega.
  Qed.

  Lemma pow2_le : forall n m,
    n <= m -> pow2 n <= pow2 m.
  Proof.
    induction 1;simpl;try omega.
  Qed.

  Lemma add_plus_nat :
    forall x y,
      (S x)* y = y + x*y.
  Proof.
    induction x;simpl;intros.
    reflexivity.
    omega.
  Qed.

  (*Transparent cart_prod.*)

  Lemma cart_prod_add_right :
    forall x x1 s,
    cart_prod {x} {x1; s} === cart_prod {x} {x1} ++ cart_prod {x} s.
  Proof.
    split;intros.
    apply cart_prod_spec in H.
    destruct H.
    apply add_iff in H0.
    destruct H0.
    apply union_2.
    apply cart_prod_spec.
    split;auto with typeclass_instances.
    rewrite H0.
    apply singleton_2;auto.
    apply union_3.
    apply cart_prod_spec.
    split;auto.
    apply union_1 in H.
    destruct H;apply cart_prod_spec in H;apply cart_prod_spec;destruct H;split;auto.
    apply add_1.
    apply singleton_1 in H0.
    assumption.
    apply add_2;auto.
  Qed.

  Corollary map_singleton :
    forall x0 x,
      cart_prod {x0} {x} === singleton (pair x0 x).
  Proof.
    split;intros.
    apply cart_prod_spec in H;destruct H as [H1 H2];
    apply singleton_1 in H1;apply singleton_1 in H2.
    apply singleton_2.
    destruct a;simpl in *.
    constructor;auto.
    apply singleton_1 in H;destruct a;simpl in *.
    apply cart_prod_spec;simpl;split;apply singleton_2;
    inversion H;normalize_notations;auto.
  Qed.

  Lemma cardinal_cart_prod_singleton :
    forall s2 x,
      cardinal (cart_prod {x} s2) = cardinal s2.
  Proof.
    induction s2 using set_induction;intros.
    cut(cart_prod {x} s2 === {}).
    abstract(intros;rewrite (@Equal_cardinal _ _ _ _ _ _ H0);symmetry;rewrite cardinal_fold;
             rewrite fold_1b;eauto).
    abstract(
        split;intros;[apply cart_prod_spec in H0;destruct H0;apply H in H1;elim H1|inversion H0]).

    cut(cart_prod {x0} s2_2 === cart_prod {x0} {x;s2_1}).
    intro;
    rewrite (@Equal_cardinal _ _ _ _ _ _ H1);
    pose proof cart_prod_add_right x0 x s2_1;
    rewrite (@Equal_cardinal _ _ _ _ _ _ H2);
    rewrite map_singleton;
    apply Add_Equal in H0;
    rewrite H0;
    apply Add_Equal in H0;
    rewrite union_cardinal_inter.
    assert(inter {(x0, x)} (cart_prod {x0} s2_1) === {}) by
    abstract(split;intros;try (now (inversion H3));
    apply inter_iff in H3;destruct H3;apply cart_prod_spec in H4;
    destruct H4;
    apply singleton_1 in H3;
    apply singleton_1 in H4;
    destruct a ;simpl in *;inversion H3;subst;rewrite <- H11 in H5;
    contradiction).
    rewrite H3, singleton_cardinal,empty_cardinal.
    simpl.
    rewrite add_cardinal_2;eauto.
    apply Add_Equal in H0;apply cart_prod_m;eauto.
  Qed.

  Lemma cart_prod_add :
    forall x s1 s2,
      cart_prod {x;s1} s2 === cart_prod {x} s2 ++ cart_prod s1 s2.
  Proof.
    split;intros.
    apply cart_prod_spec in H.
    destruct H.
    apply add_iff in H.
    destruct H.
    apply union_2.
    apply cart_prod_spec.
    split;auto.
    apply singleton_2.
    assumption.
    apply union_3.
    apply cart_prod_spec.
    split;auto.
    apply union_iff in H;destruct H.
    apply cart_prod_spec in H.
    apply cart_prod_spec.
    destruct H.
    split;auto.
    apply add_1.
    apply singleton_1 in H.
    assumption.
    apply cart_prod_spec in H.
    apply cart_prod_spec.
    destruct H.
    split;eauto.
    apply add_2;eauto.
  Qed.

  Lemma cart_prod_empty :
    forall s1 s2, s1 === {} -> cart_prod s1 s2 === {}.
  Proof.
    split;intros.
    apply cart_prod_spec in H0.
    destruct H0.
    apply H in H0.
    abstract(inversion H0).
    abstract(inversion H0).
  Qed.

  Lemma cart_prod_card : forall s1 s2,
    cardinal (cart_prod s1 s2) = cardinal s1 * cardinal s2.
  Proof.
    induction s1 using set_induction.
    intros.
    symmetry.
    rewrite cardinal_fold.
    rewrite fold_1b;auto.
    simpl.
    apply empty_is_empty_1 in H.
    pose proof cart_prod_empty s1 s2 H.
    symmetry.
    apply empty_is_empty_2 in H0.
    rewrite cardinal_fold.
    rewrite fold_1b;auto.
    intros.
    specialize IHs1_1 with s2.
    cut(cart_prod s1_2 s2 === cart_prod {x;s1_1} s2).
    intro.
    pose proof @Equal_cardinal _ _ _ _ _ _ H1.
    rewrite H2.
    rewrite cart_prod_add.
    pose proof H0.
    apply Add_Equal in H3.
    rewrite H3.
    pose proof @add_cardinal_2 _ _ _ _ s1_1 x H.
    rewrite H4.
    rewrite add_plus_nat.
    rewrite <- IHs1_1.
    assert((inter (cart_prod {x} s2) (cart_prod s1_1 s2)) === {}).
    split;intros.
    apply inter_iff in H5.
    destruct H5.
    apply cart_prod_spec in H5.
    destruct H5.
    apply singleton_1 in H5.
    apply cart_prod_spec in H6.
    destruct H6.
    rewrite <- H5 in H6.
    contradiction.
    inversion H5.
    rewrite union_cardinal_inter.
    rewrite H5.
    rewrite empty_cardinal.
    rewrite IHs1_1.
    rewrite cardinal_cart_prod_singleton.
    rewrite <- Minus.minus_n_O;reflexivity.
    apply Add_Equal in H0.
    apply cart_prod_m;auto.
  Qed.

  Lemma powerset_empty :
    (powerset {}) === singleton (empty).
  Proof.
    split;intros.
    apply powerset_spec in H.
    apply singleton_2.
    split;intros.
    inversion H0.
    apply H;auto.
    apply singleton_1 in H.
    apply powerset_spec.
    red;intros.
    apply H in H0.
    assumption.
  Qed.

  Lemma powerset_Empty :
    forall s,
      s === {} -> powerset s === singleton empty.
  Proof.
    intros.
    split;intros.
    apply powerset_spec in H0.
    rewrite H in H0.
    apply singleton_2.
    split;intros.
    inversion H1.
    apply H0 in H1.
    assumption.

    apply singleton_1 in H0.
    apply powerset_spec.
    red;intros.
    apply H.
    rewrite <- H0 in H1.
    assumption.
  Qed.

  Transparent powerset.

  Instance add_vals_m :
    forall x, Proper (_eq ==> Equal ==> Equal) (fun y : set A => add {x; y}).
  Proof.
    repeat red.
    split;intros.
    apply add_iff in H1;destruct H1.
    rewrite <- H1.
    rewrite H.
    apply add_1;auto.
    rewrite H0 in H1.
    apply add_2;auto.
    apply add_iff in H1;destruct H1.
    rewrite <- H1.
    rewrite H.
    apply add_1;auto.
    rewrite H0.
    apply add_2;auto.
  Qed.

  Lemma add_vals_transp :
    forall x, transpose Equal (fun y : set A => add {x; y}).
  Proof.
    repeat red.
    split;intros.
    apply add_iff in H;destruct H.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    apply add_1;auto.
    do 2 apply add_2;auto.
    apply add_iff in H;destruct H.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    rewrite <- H.
    apply add_1;auto.
    do 2 apply add_2;auto.
  Qed.

  Property subset_empty :
  forall s,
    s[<=]{} -> s === {}.
  Proof.
    induction s using set_induction;intros.
    split;intros.
    apply H0;auto.
    inversion H1.
    split;intros.
    apply H0 in H2.
    destruct H2.
    apply H1.
    apply H0.
    left;auto.
    assert(a \In s2).
    apply H0.
    right;auto.
    apply H1 in H3.
    assumption.
    inversion H2.
  Qed.

  Lemma empty_in_powerset :
    forall s,
      {} \In powerset s.
  Proof.
    intros.
    apply powerset_spec.
    red;intros.
    inversion H.
  Qed.

  Lemma add_not_empty :
    forall x s,
      {} =/= {x;s}.
  Proof.
    intros;intro.
    destruct(H x).
    assert(x \In {x;s}).
    apply add_1;auto.
    apply H1 in H2.
    inversion H2.
  Qed.

  Instance powerset_add_m : forall x,
    Proper (_eq ==> _eq) (fun y : set A => {x; y}).
  Proof.
    repeat red;split;intros;apply add_iff in H0;destruct H0.
    rewrite <- H0;apply add_1;auto.
    apply H in H0;apply add_2;auto.
    rewrite H0;apply add_1;auto.
    rewrite H;apply add_2;auto.
  Qed.

  Instance add_one_m : Proper (_eq ==> _eq ==> _eq) add_one.
  Proof.
    repeat red.
    intros.
    split;intros.
    apply add_one_spec in H1.
    apply add_one_spec.
    rewrite H0 in H1.
    destruct H1;auto.
    right.
    destruct H1.
    exists x1.
    rewrite H0 in H1.
    rewrite H in H1.
    assumption.
    apply add_one_spec in H1.
    apply add_one_spec.
    rewrite H0.
    destruct H1;auto.
    right.
    destruct H1.
    exists x1.
    rewrite H;auto.
    rewrite H0.
    assumption.
  Qed.

  Lemma transpose_add_one : transpose equiv add_one.
  Proof.
    red;intros.
    split;intros.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec.
    left;apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    apply add_one_spec.
    right.
    exists a';split;auto.
    apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    eapply add_one_spec in H1.
    destruct H1.
    apply add_one_spec.
    left.
    apply add_one_spec.
    right;exists a';auto.
    destruct H as [a'' [H3 H4]].
    assert(a[=]{y;{x;a''}}).
    split;intros.
    apply H2 in H.
    rewrite H4 in H.
    apply add_iff in H.
    destruct H.
    rewrite H.
    apply add_2;apply add_1;auto.
    apply add_iff in H.
    destruct H.
    rewrite H;apply add_1;auto.
    apply add_2;apply add_2;auto.
    apply add_iff in H;destruct H.
    rewrite H2,H4.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    rewrite H2.
    rewrite <- H.
    apply add_1;auto.
    rewrite H2,H4.
    apply add_2;apply add_2;auto.
    apply add_one_spec.
    right.
    exists {x;a''}.
    split;auto.
    apply add_one_spec.
    right.
    exists a'';split;auto.
    reflexivity.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec.
    left;apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    apply add_one_spec.
    right.
    exists a';split;auto.
    apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    eapply add_one_spec in H1.
    destruct H1.
    apply add_one_spec.
    left.
    apply add_one_spec.
    right;exists a';auto.
    destruct H as [a'' [H3 H4]].
    assert(a[=]{x;{y;a''}}).
    split;intros.
    apply H2 in H.
    rewrite H4 in H.
    apply add_iff in H.
    destruct H.
    rewrite H.
    apply add_2;apply add_1;auto.
    apply add_iff in H.
    destruct H.
    rewrite H;apply add_1;auto.
    apply add_2;apply add_2;auto.
    apply add_iff in H;destruct H.
    rewrite H2,H4.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    rewrite H2.
    rewrite <- H.
    apply add_1;auto.
    rewrite H2,H4.
    apply add_2;apply add_2;auto.
    apply add_one_spec.
    right.
    exists {y;a''}.
    split;auto.
    apply add_one_spec.
    right.
    exists a'';split;auto.
    reflexivity.
  Qed.

  Lemma powerset_step :
    forall s2 s1 x,
      ~x \In s1 ->
      Add x s1 s2 ->
      powerset s2 === powerset s1 ++ map (fun y => add x y) (powerset s1).
  Proof.
    intros.
    unfold powerset.
    rewrite (@fold_2 A AOrd _ _ s1 s2 x);auto with typeclass_instances.
    split;intros.
    apply add_one_spec in H1.
    destruct H1.
    apply union_2;auto.
    apply union_3.
    apply map_spec;auto with typeclass_instances.
    apply union_iff in H1;destruct H1.
    apply add_one_spec.
    left;auto.
    apply add_one_spec.
    apply map_iff in H1;auto with typeclass_instances.
    unfold equiv;auto with typeclass_instances.
    apply transpose_add_one.
  Qed.

  Lemma map_add : forall s s' x,
                    s' \In (map (fun y : set A => {x; y}) s) <->
                      x \In s' /\ (s' \In s \/ (remove x s') \In  s).
  Proof.
    intros.
    split;intros.
    apply map_iff in H;auto with typeclass_instances.
    destruct H.
    destruct H.
    split.
    rewrite H0.
    apply add_1;auto.
    destruct(In_dec x x0).
    rewrite add_equal in H0;auto.
    left.
    rewrite H0.
    assumption.
    right.
    rewrite H0.
    pose proof @remove_add _ _ _ _ x0 x n.
    rewrite H1.
    assumption.

    destruct H.
    destruct H0.
    apply map_iff;auto with typeclass_instances.
    exists s'.
    split.
    assumption.
    rewrite add_equal;auto.
    apply map_iff;auto with typeclass_instances.
    exists (remove x s').
    split;auto.
    split;intros.
    destruct(eq_dec x a).
    rewrite <- H2.
    apply add_1;auto.
    apply add_2.
    apply remove_iff.
    split;auto.
    apply add_iff in H1.
    destruct H1.
    rewrite <- H1;auto.
    apply remove_iff in H1.
    destruct H1;auto.
  Qed.

  Transparent map.

  Lemma powerset_cardinal : forall s,
    cardinal (powerset s) = pow2 (cardinal s).
  Proof.
    induction s using set_induction;intros.

    symmetry ; rewrite cardinal_fold.
    rewrite fold_1b;auto.
    simpl.
    pose proof powerset_empty.
    apply Equal_cardinal in H0.
    assert(powerset s === powerset {}).
    apply empty_is_empty_1 in H.
    split;intros.
    apply powerset_spec.
    apply powerset_spec in H1.
    red;intros.
    apply H1 in H2.
    apply H in H2.
    assumption.
    apply powerset_spec in H1.
    apply powerset_spec.
    rewrite <- H in H1.
    assumption.
    apply Equal_cardinal in H1.
    rewrite H1.
    rewrite H0.
    vm_compute.
    reflexivity.

    pose proof powerset_step _ _ _ H H0.
    rewrite H1.
    rewrite union_cardinal.
    rewrite map_cardinal;auto with typeclass_instances.
    rewrite IHs1.
    rewrite (cardinal_2 H H0).
    simpl;auto with arith.
    intros u v.
    rewrite 2 powerset_spec.
    red;red;intros.
    simpl.
    red.
    intro.
    red.
    generalize (H4 a) (H2 a) (H3 a).
    set_iff.
    clear H2 H3 H4.
    intuition;auto with sets.
    rewrite <- H7 in H9;apply H in H9;elim H9.
    rewrite <- H7 in H9;apply H in H9;elim H9.
    rewrite <- H8 in H9;apply H in H9;elim H9.
    rewrite <- H8 in H9;apply H in H9;elim H9.
    intros u (X,Y).
    apply powerset_spec in X.
    rewrite map_add in Y.
    destruct Y as (Y,_).
    apply X in Y.
    contradiction.
  Qed.

  (* Definition of the well_founded relation *)
  (*Definition lex (MAX:nat) := (lexprod (set A) (fun _:set A => set A)
    (lim_card MAX) (fun _:set A => dec_H)).

  Lemma lex_wf : forall M:nat, well_founded (lex M).
  Proof.
    intro.
    apply wf_lexprod.
    apply lim_card_wf.
    intro.
    apply dec_H_wf.
  Defined.*)

End LIM_CARD.


Require Import List Arith Omega.
Import ListNotations.

Require Import Permutation Sorting.

Module Type WithType.
  Variable A : Type.
End WithType.

Module PairOrder (T : WithType) <: Orders.TotalLeBool.
  Definition t := (nat * T.A)%type.
  Definition leb (x y : t) := Nat.leb (fst x) (fst y).
  Lemma leb_total : forall a b, is_true (leb a b) \/ is_true (leb b a).
  Proof.
    intros.
    destruct a, b; unfold leb; simpl.
    destruct (n <=? n0) eqn:?; [now left | right].
    destruct (n0 <=? n) eqn:?; auto.
    apply Nat.leb_gt in Heqb.
    apply Nat.leb_gt in Heqb0.
    omega.
  Qed.
End PairOrder.

Module PermutationSolve (T : WithType).
  Include T.

  Inductive rlist : Type :=
  | Nil : rlist
  | Var : nat -> list A -> rlist
  | Cons : nat -> A -> rlist -> rlist
  | App : rlist -> rlist -> rlist.

  Fixpoint rlistDenote (r : rlist) : list A :=
  match r with
  | Nil => []
  | Var _ l => l
  | Cons _ x r => x :: rlistDenote r
  | App r1 r2 => rlistDenote r1 ++ rlistDenote r2
  end.

  Fixpoint normalize_aux (r : rlist) : list (nat * A) * list (nat * list A) :=
  match r with
  | Nil => ([], [])
  | Var i l => ([], [(i, l)])
  | Cons i x r => let (a, b) := normalize_aux r in ((i, x) :: a, b)
  | App r1 r2 => let (a1, b1) := normalize_aux r1 in
                 let (a2, b2) := normalize_aux r2 in
                   (a1 ++ a2, b1 ++ b2)
  end.

  Module PO := PairOrder T.
  Module AS := Sort PO.

  Module TL <: WithType.
    Definition A := list A.
  End TL.

  Module POL := PairOrder TL.
  Module ASL := Sort POL.

  Definition normalize (r : rlist) : list A :=
    let (a, b) := normalize_aux r in
    let a := AS.sort a in
    let a := map snd a in
    let b := ASL.sort b in
    let b := map snd b in
    let b := concat b in
      a ++ b.

  Ltac remove_fun f t :=
    match t with
    | context C[f ?l] =>
      let t := context C[l] in remove_fun f t
    | _ => t
    end.

  Ltac remove_funs fs t :=
    match fs with
    | True => t
    | (?f, ?fs) =>
      let t := remove_fun f t in
        remove_funs fs t
    end.

  Ltac trans_funs fs :=
    match goal with
    |- Permutation ?l1 ?l2 =>
        let l1' := remove_funs fs l1 in
        let l2' := remove_funs fs l2 in
          apply perm_trans with l1';[|apply perm_trans with l2']
    end.

  Lemma Permutation_concat {A : Type} (l1 l2 : list (list A)) :
    Permutation l1 l2 -> Permutation (concat l1) (concat l2).
  Proof.
    induction 1; simpl in *.
    - constructor.
    - now apply Permutation_app_head.
    - rewrite !app_assoc. apply Permutation_app_tail.
      apply Permutation_app_comm.
    - eapply perm_trans; eassumption.
  Qed.

  Ltac trans_sorts :=
     let finish :=
       repeat (apply perm_skip || apply Permutation_app ||
               apply Permutation_map || apply Permutation_concat ||
               apply AS.Permuted_sort || apply ASL.Permuted_sort ||
               (apply Permutation_sym;
               (apply AS.Permuted_sort || apply ASL.Permuted_sort))) in
     trans_funs constr:((AS.sort, (ASL.sort, True)));
     [finish| | finish].

  Theorem normalize_correct : forall (r : rlist),
    Permutation (rlistDenote r) (normalize r).
  Proof.
    induction r; unfold normalize in *; simpl in *.
    - constructor.
    - rewrite app_nil_r. apply Permutation_refl.
    - destruct (normalize_aux r).
      apply perm_trans with (a :: map snd (AS.sort l) ++ concat (map snd (ASL.sort l0)));
      [now apply perm_skip|clear].
      trans_sorts.
      apply Permutation_refl.
    - destruct (normalize_aux r1). destruct (normalize_aux r2).
      apply perm_trans with ((map snd (AS.sort l) ++ concat (map snd (ASL.sort l0))) ++
        (map snd (AS.sort l1) ++ concat (map snd (ASL.sort l2))));
      [now apply Permutation_app|clear].
      trans_sorts.
      rewrite !map_app, !concat_app, !app_assoc_reverse.
      apply Permutation_app_head.
      rewrite !app_assoc. apply Permutation_app_tail.
      apply Permutation_app_comm.
  Qed.

  Ltac get_idx_aux l x k :=
  match l with
  | True => constr:(((x, True), k))
  | (x, _) => constr:((l, k))
  | (?h, ?l) =>
      match get_idx_aux l x constr:(S k) with
      | (?l, ?k) => constr:(((h, l), k))
      end
  end.
  Ltac get_idx l x := get_idx_aux l x O.

  Ltac reify l vars :=
    match l with
    | [] => constr:((vars, Nil))
    | ?x :: ?l =>
        match reify l vars with
        | (?vars, ?r) =>
        match get_idx vars x with
        | (?vars, ?i) => constr:((vars, (Cons i x r)))
        end end
    | ?l1 ++ ?l2 =>
        match reify l1 vars with
        | (?vars, ?r1) =>
        match reify l2 vars with
        | (?vars, ?r2) =>
          constr:((vars, App r1 r2))
        end end
    | ?l =>
        match get_idx vars l with
        | (?vars, ?i) => constr:((vars, Var i l))
        end
    end.

  Ltac reify_goal :=
    match goal with
    |- Permutation ?l1 ?l2 =>
        let vars := constr:(True) in
        match reify l1 vars with
        | (?vars, ?r1) =>
        match reify l2 vars with
        | (?vars, ?r2) =>
          let vr1 := fresh "r1" in
          let vr2 := fresh "r2" in
          set (vr1 := r1); set (vr2 := r2);
          change (Permutation (rlistDenote vr1) (rlistDenote vr2))
        end end
    end.

  Ltac solve_perm := reify_goal;
    match goal with
    | |- Permutation (rlistDenote ?r1) (rlistDenote ?r2) =>
        apply perm_trans with (normalize r1); [apply normalize_correct|
        apply perm_trans with (normalize r2); [apply Permutation_refl|
        apply Permutation_sym; apply normalize_correct]]
    end.
End PermutationSolve.


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

From Coq Require Export Morphisms RelationClasses Setoid Program.Equality.
From Coq Require Export Wellfounded Arith.Wf_nat Arith.Compare_dec Arith.Lt.
From ITree Require Export ITree ITreeFacts Eq.Rutt Props.Finite.
From Paco Require Import paco.
From Coq Require Export Eqdep EqdepFacts.
Require Import Lia.
Require Export Refinement Merge MergePartial Automation.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

Open Scope list_scope.

Variant errorE : Type -> Type :=
  | throw : errorE void.
Locate "-<".

(*need stuff for injection *)

Global Instance ResumSpecEvent {E1 E2} : E1 -< E2 -> E1 -< SpecEvent E2 :=
  fun s _ e => Spec_vis (s _ e).

Definition is_nil {E} `{errorE -< E} (l : list nat) : itree_spec E bool :=
  match l with
  | nil => Ret true
  | _ => Ret false
  end.

Definition head {E} `{errorE -< E} (l : list nat) : itree_spec E nat :=
  match l with
  | nil => trigger throw ;; Ret 0
  | n :: _ => Ret n
  end.

Definition tail {E} `{errorE -< E} (l : list nat) : itree_spec E (list nat) :=
  match l with
  | nil => trigger throw;; Ret nil
  | _ :: t => Ret t
  end.

(** * Definitions *)

Definition halve {E : Type -> Type} `{errorE -< E}: list nat -> itree_spec E (list nat * list nat) :=
  rec_fix_spec (fun rec l1 =>
                 b1 <- is_nil l1;;
                 if b1 : bool
                 then Ret (nil, nil)
                 else l2 <- tail l1;;
                      b2 <- is_nil l2;;
                      if b2 : bool
                      then
                        Ret (l1, nil)
                      else
                        x <- head l1;;
                        y <- head l2;;
                        l3 <- tail l2;;
                        '(l4,l5) <- rec l3;;
                        Ret (x :: l4, y :: l5)

               ).

Definition merge {E : Type -> Type} `{errorE -< E} : (list nat * list nat) -> itree_spec E (list nat) :=
  rec_fix_spec (fun rec '(l1,l2) =>
                  b1 <- is_nil l1;;
                  b2 <- is_nil l2;;
                  if b1 : bool then
                    Ret l2
                  else if b2 : bool then
                    Ret l1
                  else
                    x <- head l1;;
                    tx <- tail l1;;
                    y <- head l2;;
                    ty <- tail l2;;
                    if Nat.leb x y then
                      l <- rec (tx, y :: ty);;
                      Ret (x :: l)
                    else
                      l <- rec (x :: tx, ty);;
                      Ret (y :: l)
               ).

Definition sort {E : Type -> Type} `{errorE -< E} : list nat -> itree_spec E (list nat) :=
  rec_fix_spec (fun rec l =>
                  b1 <- is_nil l;;
                  if b1 : bool then
                    Ret l
                  else
                    t <- tail l;;
                    b2 <- is_nil t;;
                    if b2 : bool then
                      Ret l
                    else
                      '(l1, l2) <- halve l;;
                      l1s <- rec l1;;
                      l2s <- rec l2;;
                      merge (l1s, l2s)
               ).

(** * Halve *)

Definition halve_pre (l : list nat) : Prop := True.
Definition halve_post (l : list nat) (p : list nat * list nat) :=
  let '(l1,l2) := p in
  Permutation l (l1 ++ l2) /\
    (length l1 >= length l2 /\ (length l > length l1 \/ 1 >= length l)).

Definition dec_length (l1 l2 : list nat) :=
  length l1 < length l2.

Lemma halve_refines_total_spec {E} `{errorE -< E} l :
  padded_refines_eq (E:=E) eq (halve l) (total_spec halve_pre halve_post l).
Proof.
  unfold halve, is_nil, head, tail.
  prove_refinement.
  - exact (a = a0).
  - exact (halve_post a r).
  - exact (dec_length a a0).
  - apply well_founded_ltof.
  - unfold halve_pre, halve_post, dec_length.
    prove_refinement_continue.
    all: repeat split; simpl; auto.
    all: destruct H1 as [? []]; try lia.
    + rewrite Permutation_app_comm. cbn.
      rewrite H1. rewrite Permutation_app_comm. reflexivity.
    + rewrite H1. repeat rewrite app_length. lia.
    + rewrite Permutation_app_comm. cbn.
      rewrite H1. rewrite Permutation_app_comm. reflexivity.
    + repeat rewrite H1. repeat rewrite app_length. lia.
Qed.

(** * Merge *)

Definition merge_pre (p : list nat * list nat) :=
  let '(l1,l2) := p in
  sorted l1 /\ sorted l2.
Definition merge_post (p : list nat * list nat) (l : list nat) :=
  let '(l1,l2) := p in
  sorted l /\ Permutation l (l1 ++ l2).

Definition dec_either_length (pr1 pr2 : list nat * list nat) :=
  length (fst pr1) < length (fst pr2) /\ length (snd pr1) = length (snd pr2) \/
  length (fst pr1) = length (fst pr2) /\ length (snd pr1) < length (snd pr2).

Lemma wf_dec_either_length : well_founded dec_either_length.
Proof.
  apply wf_union.
  - intros [z1 z2] [y1 y2] [] [x1 x2] []; simpl in *.
    exists (z1, x2); simpl; split; try easy.
    + rewrite <- H0. exact H2.
    + rewrite H1. exact H.
  - eapply wf_incl; [| apply well_founded_ltof ].
    intros ? ? []. exact H.
  - eapply wf_incl; [| apply well_founded_ltof ].
    intros ? ? []. exact H0.
Qed.

Lemma sorted_cons_all x xs : sorted xs ->
  (forall x', In x' xs -> x <= x') -> sorted (x :: xs).
Proof.
  destruct xs.
  - constructor.
  - constructor; eauto.
    apply H0. left; reflexivity.
Qed.

Lemma sorted_fst_and_tail x y xs :
  sorted (x :: y :: xs) -> sorted (x :: xs).
Proof.
  intro; inversion H; subst.
  destruct xs.
  - constructor.
  - inversion H4; subst.
    constructor; eauto.
    transitivity y; eauto.
Qed.

Lemma sorted_head x xs :
  sorted (x :: xs) -> (forall x', In x' xs -> x <= x').
Proof.
  revert x; induction xs; intros.
  - contradiction H0.
  - destruct H0; subst.
    + inversion H; subst. eauto.
    + apply IHxs; eauto.
      eapply sorted_fst_and_tail; eauto.
Qed.

Lemma sorted_cons_perm_app x xs y ys xys :
  Permutation xys (xs ++ (y :: ys)) -> sorted xys ->
  x <= y -> sorted (x :: xs) -> sorted (y :: ys) -> sorted (x :: xys).
Proof.
  intros. apply sorted_cons_all; eauto; intros.
  eapply Permutation_in in H4; eauto.
  apply in_app_or in H4; destruct H4.
  - eapply sorted_head in H2; eauto.
  - revert x' H4. eapply sorted_head.
    constructor; eauto.
Qed.

Lemma merge_refines_total_spec {E} `{errorE -< E} pr :
  padded_refines_eq (E:=E) eq (merge pr) (total_spec merge_pre merge_post pr).
Proof.
  unfold merge, is_nil, head, tail.
  prove_refinement.
  - exact (a = a0).
  - exact (merge_post a r).
  - exact (dec_either_length a a0).
  - apply wf_dec_either_length.
  - unfold merge_pre, merge_post, dec_either_length.
    prove_refinement_continue.
    all: repeat split; simpl; auto.
    all: destruct e_forall; try easy.
    + eapply sorted_tail; eauto.
    + eapply sorted_cons_perm_app; eauto.
      apply leb_complete; eauto.
    + eapply sorted_cons_perm_app; eauto.
      apply leb_complete; eauto.
    + eapply sorted_tail; eauto.
    + rewrite Permutation_app_comm in H2.
      eapply sorted_cons_perm_app; eauto.
      apply leb_iff_conv in e_if; lia.
    + rewrite H2. rewrite (Permutation_app_comm a2 (a :: a3)).
      cbn. rewrite Permutation_app_comm. constructor.
    + rewrite Permutation_app_comm in H2.
      eapply sorted_cons_perm_app; eauto.
      apply leb_iff_conv in e_if; lia.
    + rewrite H2. rewrite (Permutation_app_comm a2 (a :: a3)).
      cbn. rewrite Permutation_app_comm. constructor.
    + rewrite app_nil_r. reflexivity.
    + rewrite app_nil_r. reflexivity.
Qed.

(** * Sort *)

Definition sort_pre (l : list nat) := True.
Definition sort_post (l1 l2 : list nat) :=
  sorted l2 /\
  Permutation l1 l2.

Lemma padded_refines_rew_l {E1 E2 R1 R2 RPre RPost RR}
      {t1 t2 : itree_spec E1 R1} {t3 : itree_spec E2 R2} :
  padded_refines_eq eq t1 t2 ->
  padded_refines RPre RPost RR t2 t3 ->
  padded_refines RPre RPost RR t1 t3.
Proof. intros. rewrite H; eauto. Qed.

Lemma padded_refines_rew_bind_l {E1 E2 R1 R2 A RPre RPost RR}
      {t1 t2 : itree_spec E1 A} {k : A -> itree_spec E1 R1} {t3 : itree_spec E2 R2} :
  padded_refines_eq eq t1 t2 ->
  padded_refines RPre RPost RR (t2 >>= k) t3 ->
  padded_refines RPre RPost RR (t1 >>= k) t3.
Proof. intros. rewrite H; eauto. Qed.

Hint Extern 101 (padded_refines _ _ _ (halve ?l) _) =>
  apply (padded_refines_rew_l (halve_refines_total_spec l)) : refines.
Hint Extern 101 (padded_refines _ _ _ (halve ?l >>= _) _) =>
  apply (padded_refines_rew_bind_l (halve_refines_total_spec l)) : refines.

Hint Extern 101 (padded_refines _ _ _ (merge ?pr) _) =>
  apply (padded_refines_rew_l (merge_refines_total_spec pr)) : refines.
Hint Extern 101 (padded_refines _ _ _ (merge ?pr >>= _) _) =>
  apply (padded_refines_rew_bind_l (merge_refines_total_spec pr)) : refines.

Lemma sort_refines_total_spec {E} `{errorE -< E} pr :
  padded_refines_eq (E:=E) eq (sort pr) (total_spec sort_pre sort_post pr).
Proof.
  unfold sort, is_nil, head, tail.
  prove_refinement.
  - exact (a = a0).
  - exact (sort_post a r).
  - exact (dec_length a a0).
  - apply well_founded_ltof.
  - unfold sort_pre, sort_post, dec_length.
    prove_refinement_continue.
    all: unfold halve_pre, halve_post, merge_pre, merge_post in *.
    all: try destruct e_exists0 as [? []]; try destruct e_exists1.
    all: split; try easy; try solve [ constructor ].
    + destruct H2; eauto. simpl in H2. lia.
    + destruct H5.
      * eapply le_lt_trans; eauto.
      * simpl in H5. lia.
    + rewrite H6, H10, H2, H5. reflexivity.
    + rewrite H6, H10, H2, H5. reflexivity.
Qed.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Definition var := nat.

Inductive exp : Set :=
| EConst : nat -> exp
| EAdd : exp -> exp -> exp
| EPair : exp -> exp -> exp
| EFst : exp -> exp
| ESnd : exp -> exp
| EVar : var -> exp.

Inductive cmd : Set :=
| CExp : exp -> cmd
| CAssign : var -> exp -> cmd -> cmd.

Inductive val : Set :=
| VConst : nat -> val
| VPair : val -> val -> val.

Definition env (T : Set) := var -> T.

Definition evalAdd (ov1 : option val) (ov2 : option val) : option val :=
  match ov1, ov2 with
  | Some (VConst n1), Some (VConst n2) => Some (VConst (n1 + n2))
  | _, _ => None
  end.

Definition evalPair (ov1 : option val) (ov2 : option val) : option val :=
  match ov1, ov2 with
  | Some v1, Some v2 => Some (VPair v1 v2)
  | _, _ => None
  end.

Definition evalFst (ov : option val) : option val :=
  match ov with
  | Some (VPair v _) => Some v
  | _ => None
  end.

Definition evalSnd (ov : option val) : option val :=
  match ov with
  | Some (VPair _ v) => Some v
  | _ => None
  end.

Fixpoint eval (e : exp) (vs : env val) : option val :=
  match e with
  | EConst n => Some (VConst n)
  | EAdd e1 e2 => evalAdd (eval e1 vs) (eval e2 vs)
  | EPair e1 e2 => evalPair (eval e1 vs) (eval e2 vs)
  | EFst e => evalFst (eval e vs)
  | ESnd e => evalSnd (eval e vs)
  | EVar x => Some (vs x)
  end.

Definition assign (T : Set) (x : var) (t : T) (ts : env T) : env T :=
  fun x' => if eq_nat_dec x x' then t else ts x'.

Definition runAssign (x : var) (ov : option val) (k : env val -> option val) (vs : env val) :=
  match ov with
  | Some v => k (assign x v vs)
  | None => None
  end.

Fixpoint run (c : cmd) (vs : env val) : option val :=
  match c with
  | CExp e => eval e vs
  | CAssign x e c' => runAssign x (eval e vs) (fun vs => run c' vs) vs
  end.

Inductive type : Set :=
| TNat : type
| TPair : type -> type -> type.

Definition addType (ot1 : option type) (ot2 : option type) : option type :=
  match ot1, ot2 with
  | Some TNat, Some TNat => Some TNat
  | _, _ => None
  end.

Definition pairType (ot1 : option type) (ot2 : option type) : option type :=
  match ot1, ot2 with
  | Some t1, Some t2 => Some (TPair t1 t2)
  | _, _ => None
  end.

Definition fstType (ot : option type) : option type :=
  match ot with
  | Some (TPair t _) => Some t
  | _ => None
  end.

Definition sndType (ot : option type) : option type :=
  match ot with
  | Some (TPair _ t) => Some t
  | _ => None
  end.

Fixpoint expType (e : exp) (ts : env type) : option type :=
  match e with
  | EConst _ => Some TNat
  | EAdd e1 e2 => addType (expType e1 ts) (expType e2 ts)
  | EPair e1 e2 => pairType (expType e1 ts) (expType e2 ts)
  | EFst e => fstType (expType e ts)
  | ESnd e => sndType (expType e ts)
  | EVar x => Some (ts x)
  end.

Definition assignType (x : var) (ot : option type) (k : env type -> option type) (ts : env type) :=
  match ot with
  | Some t => k (assign x t ts)
  | None => None
  end.

Fixpoint cmdType (c : cmd) (ts : env type): option type :=
  match c with
  | CExp e => expType e ts
  | CAssign x e c' => assignType x (expType e ts) (fun ts => cmdType c' ts) ts
  end.

Fixpoint valType (v : val) : type :=
  match v with
  | VConst _ => TNat
  | VPair v1 v2 => TPair (valType v1) (valType v2)
  end.

Definition varsType (vs : env val) (ts : env type) :=
  forall x : var, valType (vs x) = ts x.

Lemma vars_type_assign : forall (vs : env val) (ts : env type) (x : var) (v : val) (t : type),
    varsType vs ts /\ valType v = t -> varsType (assign x v vs) (assign x t ts).
  intros. red. intro x'. destruct H as [Hvs_ts Hv_t].
  unfold assign. destruct (eq_nat_dec x x').
  assumption.
  red in Hvs_ts. apply (Hvs_ts x').
Qed.

Lemma add_type_inversion : forall (ot1 ot2 : option type) (t : type),
    addType ot1 ot2 = Some t -> ot1 = Some TNat /\ ot2 = Some TNat /\ t = TNat.
  intros; destruct ot1; destruct ot2;
    match goal with
      | [ H : addType (Some ?T1) (Some ?T2) = _ |- _ ] =>
        destruct T1; destruct T2
      | [ H : addType (Some ?T) None = _ |- _ ] =>
        destruct T
      | [ H : addType None (Some ?T) = _ |- _ ] =>
        destruct T
      | [ H : addType None None = _ |- _ ] =>
        simpl in H
    end; crush.
Qed.

Lemma pair_type_inversion : forall (ot1 ot2 : option type) (t : type),
    pairType ot1 ot2 = Some t ->
    exists t1 t2 : type, ot1 = Some t1 /\ ot2 = Some t2 /\ t = TPair t1 t2.
  intros; destruct ot1 as [t1|]; destruct ot2 as [t2|]; crush.
  exists t1. exists t2. auto.
Qed.

Lemma fst_type_inversion : forall (ot : option type) (t1 : type),
    fstType ot = Some t1 -> exists t2 : type, ot = Some (TPair t1 t2).
  intros. destruct ot as [t|].
  destruct t as [|t1' t2']; crush. exists t2'. auto.
  crush.
Qed.

Lemma snd_type_inversion : forall (ot : option type) (t2 : type),
    sndType ot = Some t2 -> exists t1 : type, ot = Some (TPair t1 t2).
  intros. destruct ot as [t|].
  destruct t as [|t1' t2']; crush. exists t1'. auto.
  crush.
Qed.

Theorem exp_type_sound :
  forall (e : exp) (t : type) (vs : env val) (ts : env type),
    expType e ts = Some t /\ varsType vs ts ->
    exists v : val, eval e vs = Some v /\ valType v = t.
  induction e as [n|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2|e IHe|e IHe|x].
  (* EConst n *)
  intros. exists (VConst n). crush.
  (* EAdd e1 e2 *)
  intros. destruct H as [Hadd_type Hvs]. simpl in Hadd_type.
  destruct (add_type_inversion (expType e1 ts) (expType e2 ts) Hadd_type)
    as [He1_type [He2_type Ht]].
  destruct (IHe1 TNat vs ts (conj He1_type Hvs)) as [v1 [He1_val Hv1]].
  destruct (IHe2 TNat vs ts (conj He2_type Hvs)) as [v2 [He2_val Hv2]].
  destruct v1 as [n1 | v11 v12].
  destruct v2 as [n2 | v21 v22].
  exists (VConst (plus n1 n2)). crush.
  simpl in Hv2. discriminate Hv2.
  simpl in Hv1. discriminate Hv1.
  (* EPair e1 e2 *)
  intros. destruct H as [Hpair_type Hvs]. simpl in Hpair_type.
  destruct (pair_type_inversion (expType e1 ts) (expType e2 ts) Hpair_type)
    as [t1 [t2 [He1_type [He2_type Ht]]]].
  destruct (IHe1 t1 vs ts (conj He1_type Hvs)) as [v1].
  destruct (IHe2 t2 vs ts (conj He2_type Hvs)) as [v2].
  exists (VPair v1 v2). crush.
  (* EFst e *)
  intros t1 vs ts H. destruct H as [Hfst_type Hvs]. simpl in Hfst_type.
  destruct (fst_type_inversion (expType e ts) Hfst_type) as [t2 He_type].
  destruct (IHe (TPair t1 t2) vs ts (conj He_type Hvs)) as [v [He_val Hv]].
  destruct v as [n |v1 v2].
  simpl in Hv. discriminate Hv.
  exists v1. crush.
  (* ESnd e *)
  intros t2 vs ts H. destruct H as [Hsnd_type Hvs]. simpl in Hsnd_type.
  destruct (snd_type_inversion (expType e ts) Hsnd_type) as [t1 He_type].
  destruct (IHe (TPair t1 t2) vs ts (conj He_type Hvs)) as [v [He_val Hv]].
  destruct v as [n |v1 v2].
  simpl in Hv. discriminate Hv.
  exists v2. crush.
  (* EVar v *)
  intros. exists (vs x). crush.
Qed.

Lemma assign_type_inversion :
  forall (x : var) (ot : option type) (k : env type -> option type) (ts : env type) (t : type),
    assignType x ot k ts = Some t ->
    exists t' : type, ot = Some t' /\ k (assign x t' ts) = Some t.
  intros. destruct ot as [t'|]. exists t'. crush.
  simpl in H. discriminate H.
Qed.

Theorem cmd_type_sound :
  forall (c : cmd) (t : type) (vs : env val) (ts : env type),
    cmdType c ts = Some t /\ varsType vs ts ->
    exists v : val, run c vs = Some v /\ valType v = t.
  induction c as [e|x e c].
  (* CExp e *)
  intros. simpl in H. destruct (exp_type_sound e H) as [v]. exists v. crush.
  (* CAssign v e c *)
  intros. destruct H as [Hassign_type Hvs]. simpl in Hassign_type.
  destruct (assign_type_inversion x (expType e ts) (fun ts => cmdType c ts) ts Hassign_type)
    as [t' [He_type Hc_type]].
  destruct (exp_type_sound e (conj He_type Hvs)) as [v' [He_val Hv']].
  set (Hvs' := vars_type_assign x v' (conj Hvs Hv')).
  destruct (IHc t (assign x v' vs) (assign x t' ts) (conj Hc_type Hvs')) as [v''].
  exists v''. crush.
Qed.


Require Export Category.Core.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section SumCategory.
  Variable C : PreCategory.
  Variable D : PreCategory.

  Definition SumCategory_Morphism (s d : C + D) : Type
    := match (s, d) with
         | (inl s, inl d) => C.(Morphism) s d
         | (inr s, inr d) => D.(Morphism) s d
         | _ => Empty
       end.

  Global Arguments SumCategory_Morphism _ _ / .

  Definition SumCategory_Identity (x : C + D) : SumCategory_Morphism x x
    := match x with
         | inl x => Identity x
         | inr x => Identity x
       end.

  Global Arguments SumCategory_Identity _ / .

  Definition SumCategory_Compose (s d d' : C + D) (m1 : SumCategory_Morphism d d') (m2 : SumCategory_Morphism s d)
  : SumCategory_Morphism s d'.
  Proof.
    (* XXX NOTE: try to use typeclasses and work up to existance of morphisms here *)
    case s, d, d'; simpl in *; try destruct_to_empty_set;
    eapply Compose; eassumption.
  Defined.

  Global Arguments SumCategory_Compose [_ _ _] _ _ / .

  Definition SumCategory : PreCategory.
  Proof.
    refine (@Build_PreCategory
              (C + D)%type
              SumCategory_Morphism
              SumCategory_Identity
              SumCategory_Compose
              _
              _
              _
              _);
    abstract (
        repeat (intros [] || intro);
        simpl in *;
          auto with morphism;
        typeclasses eauto
      ).
  Defined.
End SumCategory.

Infix "+" := SumCategory : category_scope.


Require Export P04.

(** **** Exercise: 2 stars (ev_sum)  *)
Theorem ev_sum : forall n m, ev n -> ev m -> ev (n + m).
Proof.
  intros n m Hn Hm.
  induction Hn.
  - simpl. assumption.
  - simpl. constructor. assumption.
Qed.


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/04/12.                                             *)
(* Due: 2021/04/16, 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.Imp PL.RTClosure.

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

Module MiddleStep.
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.

(** Here are some simple examples. Please prove them in Coq. *)

(** **** Exercise: 1 star, standard (mstep_example_1) *)
Example mstep_example_1: forall (st: state) (X Y: var),
  (forall X0, st X0 = 0) ->
  mstep (X ::= Y, st) (Skip, st).
Proof.
  intros.
  apply MS_Ass.
  + unfold aeval, query_var.
    pose proof (H X).
    pose proof (H Y).
    rewrite H0, H1; tauto.
  + intros.
    reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (mstep_example_2) *)
Example mstep_example_2: forall (st1 st0: state) (X: var),
  st1 X = 1 ->
  st0 X = 0 ->
  (forall Y, X <> Y -> st1 Y = 0) ->
  (forall Y, X <> Y -> st0 Y = 0) ->
  mstep (X ::= X - 1, st1) (Skip, st0).
Proof.
  intros.
  apply MS_Ass.
  + unfold aeval, Func.sub.
    unfold query_var, constant_func.
    rewrite H, H0; tauto.
  + intros.
    specialize H1 with Y.
    specialize H2 with Y.
    rewrite H1, H2; tauto.
Qed.
(** [] *)

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

(** In the following example, you are going to prove a multi-step relation.
    Mainly, the program

    [[ While ! (X <= 0) Do X ::= X - 1 EndWhile ]]

    will decrease the value of [X] until it equals to zero. Here we consider a
    specialized case, where [st n] is a sequence of program states, and the
    program variable [X] has value [n] on [st n] for every integer [n].
    Obviously, starting from [st n], the program above will go through the
    following states in order:

    [[ st n, st (n-1), st (n-2), ..., st 1, st 0. ]]

    Your task is to prove this claim for the [n = 2] case. Hint: you can use
    [transitivity], [transitivity_1n], [transitivity_n1], [reflexivity] and
    other tactics for proving a [multi_mstep] relation, since it is defined
    as a reflexive transitive closure of [mstep]. *)

Example mstep_example_3: forall (st: Z -> state) (X: var),
  (forall n: Z, (st n) X = n) ->
  (forall n: Z, forall Y, X <> Y -> (st n) Y = 0) ->
  multi_mstep (While ! (X <= 0) Do X ::= X - 1 EndWhile, st 2) (Skip, st 0).
Proof.
  intros.
  etransitivity_1n.
  {
    apply MS_WhileTrue.
    unfold beval, Sets.complement, Func.test_le.
    unfold aeval, query_var, constant_func.
    pose proof (H 2).
    rewrite H1; eauto.
  }
  etransitivity_1n.
  {
    apply MS_SeqStep, MS_Ass; eauto.
    intros.
    unfold aeval, Func.sub, query_var, constant_func.
    pose proof (H 2).
    pose proof (H0 2 Y).
    rewrite H2, H3; eauto; simpl.
    pose proof (H0 1 Y).
    rewrite H4; eauto.
  }
  etransitivity_1n.
  {
    apply MS_Seq.
  }
  etransitivity_1n.
  {
    apply MS_WhileTrue.
    unfold beval, Sets.complement, Func.test_le.
    unfold aeval, Func.sub, query_var, constant_func.
    pose proof (H 2).
    rewrite H1; eauto; simpl.
    pose proof (H 1).
    rewrite H2; eauto.
  }
  etransitivity_1n.
  {
    apply MS_SeqStep, MS_Ass; eauto.
    intros.
    unfold aeval, Func.sub, query_var, constant_func.
    pose proof (H 2).
    rewrite H2; eauto; simpl.
    pose proof (H 1).
    pose proof (H0 1 Y).
    rewrite H3, H4; eauto; simpl.
    pose proof (H0 0).
    rewrite H5; eauto.
  }
  etransitivity_1n.
  {
    apply MS_Seq.
  }
  etransitivity_1n.
  {
    apply MS_WhileFalse.
    unfold beval, Sets.complement, Func.test_le.
    unfold aeval, Func.sub, query_var, constant_func.
    pose proof (H 2).
    rewrite H1; eauto; simpl.
    pose proof (H 1).
    rewrite H2; eauto; simpl.
    pose proof (H 0).
    rewrite H3; eauto; lia.
  }
  unfold aeval, Func.sub, query_var, constant_func.
  pose proof (H 2).
  rewrite H1; eauto; simpl.
  pose proof (H 1).
  rewrite H2; eauto; simpl.
  reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 2: From Middles Steps to Small Steps *)

(** This task is to prove the first half of the semantic equivalence between
    the middle step semantics defined above and the small step semantics that we
    learnt in class. 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. Specifically, you
    may start you proof by:

    - [intros. induction H.]

    - or [intros. destruct a, b.] *)

Lemma One_MidStep_To_SmallStep: forall a b,
  mstep a b -> multi_cstep a b.
Proof.
  intros.
  induction H.
  + etransitivity_n1.
    - apply multi_congr_CAss, semantic_equiv_aexp1.
      reflexivity.
    - apply CS_Ass; tauto.
  + etransitivity.
    - apply multi_congr_CSeq, IHmstep.
    - reflexivity.
  + etransitivity_1n.
    - apply CS_Seq.
    - reflexivity.
  + pose proof semantic_equiv_bexp1 st b.
    destruct H0.
    etransitivity.
    - apply multi_congr_CIf, H0, H.
    - etransitivity_1n; [apply CS_IfTrue | reflexivity].
  + pose proof semantic_equiv_bexp1 st b.
    destruct H0.
    etransitivity.
    - apply multi_congr_CIf, H1, H.
    - etransitivity_1n; [apply CS_IfFalse | reflexivity].
  + pose proof semantic_equiv_bexp1 st b.
    destruct H0.
    etransitivity_1n; [apply CS_While |].
    etransitivity.
    - apply multi_congr_CIf, H0, H.
    - etransitivity_1n; [apply CS_IfTrue | reflexivity].
  + pose proof semantic_equiv_bexp1 st b.
    destruct H0.
    etransitivity_1n; [apply CS_While |].
    etransitivity.
    - apply multi_congr_CIf, H1, H.
    - etransitivity_1n; [apply CS_IfFalse | reflexivity].
Qed.
(** [] *)

(** Now, from this conclusion above to our final target, we only need two
    properties about reflexive transitive closures. Hint: you may choose
    among [induction_1n], [induction_n1] and/or [induction] for different
    induction strategies. *)

(** **** 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; intros.
  + induction_1n H.
    - reflexivity.
    - rewrite IHrt in H.
      exact H.
  + apply rt_step.
    exact H.
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.
    - exact IHrt.
    - specialize H with y y0.
      apply H, H0.
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.
    exact H.
  + reflexivity.
  + apply (rt_mono _ _ _ One_MidStep_To_SmallStep) in H.
    apply (rt_mono _ _ _ One_MidStep_To_SmallStep) in H0.
    apply rt_idempotent.
    transitivity y.
    - apply H.
    - apply H0.
Qed.
(** [] *)

(* ################################################################# *)
(** * Task 3: From Small Steps to Middle Steps *)

(** Your task here is to prove the second half of the semantic equivalence
    between [mstep] and [cstep]. Specifically, your eventual goal is:

    [[
        Theorem Multi_SmallStep_To_MidStep: forall c st1 st2,
          multi_cstep (c, st1) (Skip, st2) ->
          multi_mstep (c, st1) (Skip, st2).
    ]]

    To prove this theorem, the main idea is to establish a simulation relation
    [match_com], so that we can prove: every small step correspond to zero or
    one middle step. Here is our simulation statement: *)

Definition mstep_or_not (X Y: com * state): Prop :=
  X = Y \/ mstep X Y.

Definition Simulation01_Statement (match_com: state -> com -> com -> Prop): Prop :=
  forall c1 c2 c1' st st',
    match_com st c1 c2 ->
    cstep (c1, st) (c1', st') ->
    exists c2',
      match_com st' c1' c2' /\
      mstep_or_not (c2, st) (c2', st').

(** The main proof skeleton for [Multi_SmallStep_To_MidStep] is to find such a
    [match_com] relation, and at the same time

    - this relation is reflexive, i.e. [match_com st c c] for every [c];

    - only [Skip] can match [Skip] via [match_com], i.e. [c' = Skip] if
      [match_com st Skip c'].

    Why these conditions are enough for proving [Multi_SmallStep_To_MidStep]?
    Consider the following diagram:

    [[

                 match_com
             c ------------- c

      cstep  |               |  mstep_or_not
             v               v

             c1 ----------- c1'

      cstep  |               |  mstep_or_not
             v               v

             c2 ----------- c2'

             |               |
             .               .
             |               |
             .               .
             |               |
             v               v

             c0 ----------- c0'

    ]]

    From the initial command [c], the left side matches the right side via the
    [match_com] relation. Whenever the left side takes one step, zero or one
    step on the right can be taken so that both sides still matches. In the end,
    if [c0 = Skip], [c0'] must be [Skip] according to our assumption, which
    proves [Multi_SmallStep_To_MidStep]. Please formalize this proof strategy
    in Coq. *)

(** **** Exercise: 2 stars, standard (Multi_SmallStep_To_MidStep_strategy) *)
Theorem Multi_SmallStep_To_MidStep_strategy: forall match_com,
  Simulation01_Statement match_com ->
  (forall st c, match_com st c c) ->
  (forall st c', match_com st Skip c' -> c' = Skip) ->
  (forall c st1 st2,
    multi_cstep (c, st1) (Skip, st2) ->
    multi_mstep (c, st1) (Skip, st2)).
Proof.
  intros ? ?.
  assert
    (forall c2,
       (forall st c2', match_com st c2 c2' -> c2' = Skip) ->
       (forall c1 c1' st1 st2,
          match_com st1 c1 c1' ->
          multi_cstep (c1, st1) (c2, st2) ->
          multi_mstep (c1', st1) (Skip, st2))).
  2: {
    intros.
    specialize (H0 Skip H2); clear H2.
    specialize (H0 c c st1 st2 (H1 st1 c)); clear H1.
    tauto.
  }

  intros.
  revert c1' H1.
  induction_1n H2; intros.
  + specialize (H0 _ _ H1).
    rewrite H0.
    reflexivity.
  + unfold Simulation01_Statement in H.
    specialize (H _ _ _ _ _ H3 H1).
    destruct H; destruct H.
    destruct H4.
    - specialize (IHrt _ H).
      injection H4 as ? ?; subst.
      exact IHrt.
    - specialize (IHrt _ H).
      etransitivity_1n; eauto.
Qed.
(** [] *)

(** Let us find such a [match_com] and prove these properties now. This is its
    definition. *)

Inductive match_com (st: state): com -> com -> Prop :=
  | MatSkip: match_com st CSkip CSkip
  | MatAss: forall X a1 a2,
      aeval a1 st = aeval a2 st ->
      match_com st (CAss X a1) (CAss X a2)
  | MatSeq: forall c1 c2 c0,
      match_com st c1 c2 ->
      match_com st (c1;; c0) (c2;; c0)
  | MatIf: forall b1 b2 c c',
      (beval b1 st <-> beval b2 st) ->
      match_com st (If b1 Then c Else c' EndIf) (If b2 Then c Else c' EndIf)
  | MatWhile: forall b c,
      match_com st (While b Do c EndWhile) (While b Do c EndWhile)
  | MatIfWhile: forall b1 b2 c,
      (beval b1 st <-> beval b2 st) ->
      match_com st
        (If b1 Then (c;; While b2 Do c EndWhile) Else Skip EndIf)
        (While b2 Do c EndWhile).

(** Most parts of this definition is trivial. The only interesting clause is
    the [MatIfWhile] clause for while loops. The following diagram illustrates
    the intuition of [MS_WhileTrue] case:

    [[

                                     match_com
             While b Do c EndWhile ------------- While b Do c EndWhile

                        |                                 |
                 cstep  |                                 |  no step
                        |                                 |
                        v                                 v
         If b
           Then c ;; While b Do c EndWhile ----- While b Do c EndWhile
           Else Skip

                        |                                 |
                 cstep  |                                 |  no step
                        |                                 |
                        v                                 v
         If b'
           Then c ;; While b Do c EndWhile ----- While b Do c EndWhile
           Else Skip

                        |                                 |
                 cstep  |                                 |  no step
                        |                                 |
                        v                                 v
         If b''
           Then c ;; While b Do c EndWhile ----- While b Do c EndWhile
           Else Skip

                        .                                 |
                        .                                 |
                        .                                 |  no step
                        .                                 |
                        v                                 v
         If True
           Then c ;; While b Do c EndWhile ----- While b Do c EndWhile
           Else Skip

                        |                                 |
                 cstep  |                                 |  mstep
                        |                                 |
                        v                                 v

            c;; While b Do c EndWhile --------- c;; While b Do c EndWhile

    ]]
*)

(** For proving [Multi_SmallStep_To_MidStep], we first prove that [match_com] is
    reflexive. *)

(** **** Exercise: 1 star, standard (match_com_refl) *)
Lemma match_com_refl: forall st c, match_com st c c.
Proof.
  intros.
  induction c; constructor; tauto.
Qed.
(** [] *)

(** Second, only [Skip] can match [Skip] via [match_com]. *)

(** **** Exercise: 1 star, standard (only_skip_matches_skip) *)
Lemma only_skip_matches_skip:
  forall (st : state) (c' : com), match_com st Skip c' -> c' = Skip.
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.
(** [] *)

(** Third, and most importantly, [match_com] is a simulation relation:

    [[
        Definition Simulation01_Statement match_com: Prop :=
          forall c1 c2 c1' st st',
            match_com st c1 c2 ->
            cstep (c1, st) (c1', st') ->
            exists c2',
              match_com st' c1' c2' /\
              mstep_or_not (c2, st) (c2', st').
    ]]

    We prove it by induction over the [cstep] relation, which means we need
    to complete base steps and induction steps as follow:

    [[

        (* CS_AssStep case *)

        forall st X a a',
          astep st a a' ->
          forall c2,
          match_com st (X ::= a) c2 ->
          exists c2',
             match_com st (X ::= a') c2' /\
             mstep_or_not (c2, st) (c2', st)

        (* CS_SeqStep case *)

        forall st st' c1_1 c1_1' c1_2,
          cstep (c1_1, st) (c1_1', st') ->
          (forall c2_1,
            match_com st c1_1 c2_1 ->
            exists c2_1' : com,
              match_com st' c1_1' c2_1' /\
              mstep_or_not (c2_1, st) (c2_1', st')) ->
          (forall c2,
            match_com st (c1_1;; c1_2) c2 ->
            exists c2',
              match_com st' (c1_1';; c1_2) c2' /\
              mstep_or_not (c2, st) (c2', st'))

    ]]
*)

(** For completing the [CS_AssStep] case, you may need the [aeval_preserve]
    property that we proved in class. *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_AssStep) *)
Lemma MiddleStep_Simulate_SmallStep_CS_AssStep:
  forall st X a a',
    astep st a a' ->
      forall c2,
      match_com st (X ::= a) c2 ->
      exists c2',
         match_com st (X ::= a') c2' /\
         mstep_or_not (c2, st) (c2', st).
Proof.
  intros.
  inversion H0; subst.
  exists (X ::= a2).
  split; constructor.
  + apply aeval_preserve in H.
    rewrite <- H, <- H4.
    reflexivity.
  + reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_Ass) *)
Lemma MiddleStep_Simulate_SmallStep_CS_Ass:
  forall st1 st2 (X: var) (n: Z),
    st2 X = n ->
    (forall Y, X <> Y -> st1 Y = st2 Y) ->
    forall c2,
      match_com st1 (X ::= n) c2 ->
      exists c2',
        match_com st2 Skip c2' /\
        mstep_or_not (c2, st1) (c2', st2).
Proof.
  intros.
  inversion H1; subst.
  exists Skip.
  split; [constructor | right].
  constructor; [| exact H0].
  rewrite <- H5; reflexivity.
Qed.

(** For the [CS_SeqStep] case, you may need [mstep_or_not]'s congruence property
    for [;;]. *)

(** **** Exercise: 1 star, standard (mstep_or_not_congr_CSeq) *)
Lemma mstep_or_not_congr_CSeq: forall c1 st c1' st' c2,
  mstep_or_not (c1, st) (c1', st') ->
  mstep_or_not (c1;; c2, st) (c1';; c2, st').
Proof.
  intros.
  inversion H.
  + unfold mstep_or_not; left.
    injection H0 as ? ?.
    rewrite H0, H1.
    reflexivity.
  + unfold mstep_or_not; right.
    apply MS_SeqStep.
    exact H0.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_SeqStep) *)
Lemma MiddleStep_Simulate_SmallStep_CS_SeqStep:
  forall st st' c1_1 c1_1' c1_2,
    cstep (c1_1, st) (c1_1', st') ->
    (forall c2_1,
      match_com st c1_1 c2_1 ->
      exists c2_1' : com,
        match_com st' c1_1' c2_1' /\
        mstep_or_not (c2_1, st) (c2_1', st')) ->
    (forall c2,
      match_com st (c1_1;; c1_2) c2 ->
      exists c2',
        match_com st' (c1_1';; c1_2) c2' /\
        mstep_or_not (c2, st) (c2', st')).
Proof.
  intros.
  inversion H1; subst.
  apply H0 in H5.
  destruct H5, H2.
  exists (x;; c1_2).
  split.
  + constructor.
    exact H2.
  + eapply mstep_or_not_congr_CSeq in H3.
    exact H3.
Qed.
(** [] *)

(** For the [CS_Seq] case, you may need [match_com]'s reflexivity, which you
    have already proved as [match_com_refl]. *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_Seq) *)
Lemma MiddleStep_Simulate_SmallStep_CS_Seq:
  forall st c1_2,
    forall c2,
      match_com st (Skip;; c1_2) c2 ->
      exists c2',
        match_com st c1_2 c2' /\
        mstep_or_not (c2, st) (c2', st).
Proof.
  intros.
  inversion H; subst.
  exists c1_2.
  split.
  + apply match_com_refl.
  + unfold mstep_or_not; right.
    apply only_skip_matches_skip in H3.
    rewrite H3.
    apply MS_Seq.
Qed.
(** [] *)

(** Each case of [CS_IfStep], [CS_IfTrue] and [CS_IfFalse] has two sub-cases,
    since a if-command may match another if command and may match a while-loop
    too. The diagram that illustrates [MS_WhileTrue] case's intuition may help
    (the diagram appeared right after the definition of [match_com]). *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_IfStep) *)
Lemma MiddleStep_Simulate_SmallStep_CS_IfStep:
  forall st b b' c1_1 c1_2,
    bstep st b b' ->
    forall c2,
      match_com st (If b Then c1_1 Else c1_2 EndIf) c2 ->
      exists c2',
        match_com st (If b' Then c1_1 Else c1_2 EndIf) c2' /\
        mstep_or_not (c2, st) (c2', st).
Proof.
  intros.
  inversion H0; subst.
  + exists (If b2 Then c1_1 Else c1_2 EndIf).
    split; constructor.
    - apply beval_preserve in H.
      rewrite <- H, <- H5.
      reflexivity.
    - reflexivity.
  + exists (While b2 Do c EndWhile).
    split; constructor.
    - apply beval_preserve in H.
      rewrite <- H, <- H5.
      reflexivity.
    - reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_IfTrue) *)
Lemma MiddleStep_Simulate_SmallStep_CS_IfTrue:
  forall st c1_1 c1_2,
    forall c2,
      match_com st (If true Then c1_1 Else c1_2 EndIf) c2 ->
      exists c2',
        match_com st c1_1 c2' /\ mstep_or_not (c2, st) (c2', st).
Proof.
  intros.
  inversion H; subst.
  + exists c1_1.
    split.
    - apply match_com_refl.
    - unfold mstep_or_not; right.
      constructor.
      rewrite <- H4.
      constructor.
  + exists (c;; While b2 Do c EndWhile).
    split.
    - apply match_com_refl.
    - unfold mstep_or_not; right.
      constructor.
      rewrite <- H4.
      constructor.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_IfFalse) *)
Lemma MiddleStep_Simulate_SmallStep_CS_IfFalse:
  forall st c1_1 c1_2,
    forall c2,
      match_com st (If false Then c1_1 Else c1_2 EndIf) c2 ->
      exists c2',
        match_com st c1_2 c2' /\ mstep_or_not (c2, st) (c2', st).
Proof.
  intros.
  inversion H; subst.
  + exists c1_2.
    split.
    - apply match_com_refl.
    - unfold mstep_or_not; right.
      constructor.
      rewrite <- H4.
      tauto.
  + exists (Skip).
    split.
    - apply match_com_refl.
    - unfold mstep_or_not; right.
      constructor.
      rewrite <- H4.
      tauto.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep_CS_While) *)
Lemma MiddleStep_Simulate_SmallStep_CS_While:
  forall st b c,
    forall c2,
       match_com st (While b Do c EndWhile) c2 ->
       exists c2',
         match_com
           st
           (If b Then c;; While b Do c EndWhile Else Skip EndIf)
           c2' /\
         mstep_or_not (c2, st) (c2', st).
Proof.
  intros.
  inversion H; subst.
  exists (While b Do c EndWhile).
  split.
  + apply MatIfWhile.
    reflexivity.
  + unfold mstep_or_not; left.
    reflexivity.
Qed.
(** [] *)

(** Now, you can connects all induction steps above together. *)

(** **** Exercise: 1 star, standard (MiddleStep_Simulate_SmallStep) *)
Lemma MiddleStep_Simulate_SmallStep: Simulation01_Statement match_com.
Proof.
  unfold Simulation01_Statement.
  intros.
  revert c2 H; induction_cstep H0; intros.

  + eapply MiddleStep_Simulate_SmallStep_CS_AssStep; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_Ass; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_SeqStep; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_Seq; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_IfStep; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_IfTrue; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_IfFalse; eauto.
  + eapply MiddleStep_Simulate_SmallStep_CS_While; eauto.
Qed.
(** [] *)

(** ... and use [Multi_SmallStep_To_MidStep_strategy] to prove
    [Multi_SmallStep_To_MidStep]. *)

Theorem Multi_SmallStep_To_MidStep: forall c st1 st2,
  multi_cstep (c, st1) (Skip, st2) ->
  multi_mstep (c, st1) (Skip, st2).
Proof.
  intros.
  eapply Multi_SmallStep_To_MidStep_strategy.
  + apply MiddleStep_Simulate_SmallStep.
  + apply match_com_refl.
  + apply only_skip_matches_skip.
  + exact H.
Qed.
(** [] *)

End MiddleStep.

(* ################################################################# *)
(** * Task 4: Understanding Assertion Syntax Trees *)

Module Task4.

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

(** Is the following claim correct?

    If [X], [Y] and [Z] are distinct program variables and [x] is a logical
    variable, then the subtitution result of
      [   ({[ X + Y ]} = {[Z]} + x) [X |-> x]   ]
    is
      [   {[ x + Y ]} = {[Z]} + x   ].

    1: Yes. 2: No. *)

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

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

(** Is the following claim correct?

    If [X] and [Y] are distinct program variables, [E1] and [E2] are integer
    expressions, [P] is an assertion, then
      [   P [X |-> E1] [Y |-> E2]   ]
    and
      [   P [Y |-> E2] [X |-> E1]   ]
    are always equivalent assertions.

    1: Yes. 2: No. *)

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

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

(** Is the following claim correct?

    If [X] is a program variables, [E1] and [E2] are integer expressions, [P] is
    an assertion, then
      [   P [X |-> E1] [X |-> E2]   ]
    and
      [   P [X |-> E1]   ]
    are always equivalent assertions.

    1: Yes. 2: No. *)

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

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

(** Is the following claim correct?

    If [X] is a program variables, [x] is a logical variable, [P] is an
    assertion, then [P] is a stronger assertion than
      [   EXISTS x, P [X |-> x]   ].

    1: Yes. 2: No. *)

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

End Task4.

(** Task 5: Understanding Validity and Provability *)

Module Task5.

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

(** Is the following reasoning about "valid" correct?

    BECAUSE the subtitution result of
    [    ({[X]} = m AND {[Y]} = n) [Y |-> Y - X]    ]
    is
    [    {[X]} = m AND {[Y - X]} = n    ],
    the following Hoare triple is VALID due to the backward assignment rule:
    [
          {{ {[X]} = m AND {[Y - X]} = n }}
             Y ::= Y - X
          {{ {[X]} = m AND {[Y]} = n }}.
    ]

    1: Yes. 2: No. *)

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

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

(** Is the following reasoning about "valid" correct?

    The following Hoare triple is VALID:
    [
          {{ True }}
             While X <= X Do X ::= X + 1 EndWhile
          {{ False }}.
    ]
    BECAUSE the loop will never terminate according to the denotational
    semantics [ceval].

    1: Yes. 2: No. *)

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

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

(** Is the following reasoning about "provable" correct?

    BECAUSE the ending state of [Skip] is always the same as its beginning
    state (according to the definition of [ceval]), this following Hoare triple
    is always PROVABLE:
        [    {{ P }} Skip {{ P }}.   ]

    1: Yes. 2: No. *)

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

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

(** Is the following reasoning about "valid" correct?

    Using [hoare_seq] and [hoare_asgn_bwd], we can build a Hoare logic proof for
    the following Hoare triple:
    [
          {{ {[(X + Y) - X]} = m AND {[(X + Y) - (X + Y - X)]} = n }}
             Y ::= X + Y;;
             X ::= Y - X;;
             Y ::= Y - X
          {{ {[X]} = m AND {[Y]} = n }}.
    ]
    IF our Hoare logic is complete, THEN this Hoare triple is also valid.

    1: Yes. 2: No. *)

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

End Task5.

(* ################################################################# *)
(** * Task 6: Alternative Primary Proof Rules *)

Module Task6.
Import Assertion_D.
Import Abstract_Pretty_Printing.

(** Consider the following proof rule for if-commands:

    - If [  {{ P }} c1 {{ Q }}  ] and [  {{ P }} c2 {{ Q }}  ], then
      [  {{ P }} If b Then c1 Else c2 EndIf {{ Q }}  ].

    We may add it to our proof system. If doing that, the logic is still sound.
    Your task is to show why. Hint: remember that [ceval_CIf] describes the
    denotational semantics of if-commands. *)

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

Lemma new_if_rule_sound: forall P b c1 c2 Q,
  |== {{ P }} c1 {{ Q }} ->
  |== {{ P }} c2 {{ Q }} ->
  |== {{ P }} If b Then c1 Else c2 EndIf {{ Q }}.
Proof.
  unfold valid.
  intros.
  rewrite ceval_CIf in H2.
  unfold if_sem, BinRel.union, BinRel.concat, BinRel.test_rel in H2.
  destruct H2; destruct H2; destruct H2; destruct H2; subst; firstorder.
Qed.
(** [] *)

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

(** If replacing our original proof rule for if-commands [hoare_if] with this
    new proof rule in the proof system, is the logic still complete?

    1: Yes. 2: No. *)

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

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

(** Consider the following proof rule for assignment commands:

    - If [X] is a program variable that does not appear in [E], then
      [  {{ P }} X ::= E {{ P [X |-> E] }}  ].

    Is the Hoare logic still sound if this additional rule is added to the proof
    system? (Suppose the underlying logic for assertion derivation is sound.)

    1: Yes. 2: No. *)

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

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

(** Consider the following proof rule for assignment commands:

    - If [X] is a program variable that does not appear in [E] or [P], then
      [  {{ P }} X ::= E {{ P AND {[ X ]} = {[ E ]} }}  ].

    Is the Hoare logic still sound if this additional rule is added to the proof
    system? (Suppose the underlying logic for assertion derivation is sound.)

    1: Yes. 2: No. *)

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

End Task6.

(* 2021-04-12 16:19 *)


(*
Last login: Wed Nov 25 19:21:08 on ttys000
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_H.

Coq < Goal forall l b t g k r:Prop, (((l \/ t) -> (b /\ g)) /\ l /\ (k <-> r)) -> (l /\ b).
1 subgoal

  ============================
   forall l b t g k r : Prop, (l \/ t -> b /\ g) /\ l /\ (k <-> r) -> l /\ b

Unnamed_thm < intros.
1 subgoal

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  ============================
   l /\ b

Unnamed_thm < elim H.
1 subgoal

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  ============================
   (l \/ t -> b /\ g) -> l /\ (k <-> r) -> l /\ b

Unnamed_thm < intro.
1 subgoal

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  H0 : l \/ t -> b /\ g
  ============================
   l /\ (k <-> r) -> l /\ b

Unnamed_thm < intro.
1 subgoal

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  H0 : l \/ t -> b /\ g
  H1 : l /\ (k <-> r)
  ============================
   l /\ b

Unnamed_thm < destruct H0.
2 subgoals

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  H1 : l /\ (k <-> r)
  ============================
   l \/ t

subgoal 2 is:
 l /\ b

Unnamed_thm < destruct H1.
2 subgoals

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  H0 : l
  H1 : k <-> r
  ============================
   l \/ t

subgoal 2 is:
 l /\ b

Unnamed_thm < left.
2 subgoals

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  H0 : l
  H1 : k <-> r
  ============================
   l

subgoal 2 is:
 l /\ b

Unnamed_thm < exact H0.
1 subgoal

  l : Prop
  b : Prop
  t : Prop
  g : Prop
  k : Prop
  r : Prop
  H : (l \/ t -> b /\ g) /\ l /\ (k <-> r)
  H0 : b
  H2 : g
  H1 : l /\ (k <-> r)
  ============================
   l /\ b

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
destruct H0.
 destruct H1.
 left.
 exact H0.
 firstorder.

Unnamed_thm is defined

Coq <

*)

Section Exercise_H.
Goal forall l b t g k r:Prop, (((l \/ t) -> (b /\ g)) /\ l /\ (k <-> r)) -> (l /\ b).
intros.
elim H.
intro.
intro.
destruct H0.
 destruct H1.
 left.
 exact H0.
 firstorder.
Qed.