(*--------------------------------------*)
(*--This file contains proofs of the ---*)
(*-----------Maximum Theorem:-----------*)
(*----and lemmas required to prove it---*)
(*--------------------------------------*)

Require Import Definitions Properties.

Set Implicit Arguments.

Section Matching.

Definition MaxMatch (M: list transaction) (B A: list order):=
forall M', Matching M' B A -> Matching M B A -> (Vol M') <= (Vol M).

Lemma Matching_over (M: list transaction) (B A: list order): Matching M B A ->
forall t : transaction, In t M -> over t B A.
Proof. unfold Matching. unfold Tvalid. unfold valid. intros. destruct H.
       unfold over. apply H in H0. destruct H0. destruct H0. exists x.
       exists x0. repeat split. all: apply H0. Qed.

Lemma anot_matchable_tradable (B A: list order)(b :order):~ matchable B A ->
~ (exists a : order, In a A -> tradable b a) -> ~matchable (b::B) A.
Proof. unfold matchable. intros. intro. destruct H1. destruct H1. simpl in H1.
destruct H1. destruct H2. destruct H2. { subst x. destruct H0. exists x0. auto. }
{ destruct H. exists x. exists x0. auto. } Qed.

Lemma bnot_matchable_tradable (B A: list order)(a :order): ~ matchable B A ->
~ (exists b : order, In b B -> tradable b a) -> ~matchable B (a::A).
Proof. unfold matchable. intros. intro. destruct H1. destruct H1. simpl in H1.
destruct H1. destruct H2. destruct H1. { subst. destruct H0. exists x. auto. }
{ destruct H. exists x. exists x0. auto. } Qed.

Lemma not_matchable_delete (B A: list order)(b a :order): ~matchable B A ->
~matchable (delete_order B (id b)) (delete_order A (id a)).
Proof. intros H H0. unfold matchable in H0. destruct H0 as [b0 H0].
       destruct H0 as [a0 H0]. destruct H0 as [H1 H2]. destruct H2 as [H2 H3].
       assert(In  b0 B). eapply delete_order_intro. exact H2.
       assert(In  a0 A). eapply delete_order_intro. exact H1. destruct H.
       unfold matchable. exists b0. exists a0. auto. Qed.

Lemma not_matchable_matching_nil (M: list transaction) (B A: list order):
~matchable B A -> Matching M B A -> M=nil.
Proof. intros. destruct H0. unfold Tvalid in H0. unfold valid in H0.
       destruct M eqn:HM. auto. assert(In t (t::l)). auto.  apply
       H0 in H2.  destruct H2. destruct H2. destruct H2. destruct H3.
       destruct H4. destruct H5. destruct H6. unfold matchable in H.
       destruct H. exists x. exists x0. auto. Qed.

Lemma not_matchable_perm_invariance (A A' B B': list order):
not (matchable B A) -> perm B B' -> perm A A' -> not (matchable B' A').
Proof. intros. unfold perm in H0. unfold perm in H1. move /andP in H0.
       move /andP in H1. destruct H0. destruct H1. intro. destruct H.
       unfold matchable. unfold matchable in H4. firstorder. exists x.
       exists x0. repeat split. eauto. eauto. auto. Qed.

Lemma Maching_perm (A1 A2 B1 B2: list order)(M1 M2: list transaction):
perm B1 B2 -> perm A1 A2 -> Matching M1 B1 A1 -> Matching M2 B2 A2 ->
Matching M2 B1 A1.
Proof. unfold perm. unfold Matching. unfold Tvalid. unfold valid. intros.
       move /andP in H. destruct H. move /andP in H0. destruct H0.
       repeat split. { intros. apply H2 in H5. destruct H5 as [b0 H5].
       destruct H5 as [a0 H5]. exists b0. exists a0.  destruct H5.
       destruct H6. split. eauto. split. eauto. auto. } { intros.
       apply H2. eauto.  } { intro. intro. apply H2. eauto. } Qed.

Lemma Maching_perm_wB (A1 A2 B1 B2: list order)(M1 M2: list transaction)(w:order):
perm B1 B2 -> perm A1 A2 -> Matching M2 (w :: B2) A2 -> Matching M2 (w :: B1) A1.
Proof. unfold perm. unfold Matching. unfold Tvalid. unfold valid. intros.
       move /andP in H. destruct H. move /andP in H0. destruct H0. repeat
       split. { intros. apply H1 in H4. destruct H4 as [b0 H4]. destruct H4
       as [a0 H4]. exists b0. exists a0.  destruct H4. destruct H5. split.
       eauto. split. destruct H5. simpl. auto. simpl. right. eauto. auto. }
       { intros. apply H1. destruct H4. subst. auto. eauto. } { intro. intro.
       apply H1. eauto. } Qed.

Lemma Maching_perm_wA (A1 A2 B1 B2: list order)(M1 M2: list transaction)(w:order):
perm B1 B2 -> perm A1 A2 -> Matching M2 B2 (w::A2) -> Matching M2 B1 (w::A1).
Proof. unfold perm. unfold Matching. unfold Tvalid. unfold valid. intros.
       move /andP in H. destruct H. move /andP in H0. destruct H0. repeat split.
       { intros. apply H1 in H4. destruct H4 as [b0 H4]. destruct H4 as
       [a0 H4]. exists b0. exists a0.  destruct H4. destruct H5. split.
       destruct H4. simpl. auto. simpl. right. eauto. split. eauto. auto. }
       { intros. apply H1. eauto. }  { intro. intros. destruct H4. subst.
       apply H1. auto. apply H1. simpl. right. eauto. } Qed.

Lemma insert_order_transaction_bid (M: list transaction) (B A: list order) (b:order):
~matchable B A -> Matching M (b::B) A -> (forall t, In t M -> idb t = id b).
Proof. intros.  destruct H0. unfold Tvalid in H0. unfold valid in H0. destruct M
       eqn:HM. auto. assert(In t (t::l)). auto.  apply H0 in H1. destruct H1.
       destruct H1. destruct H1. destruct H4. destruct H5. destruct H6. simpl
       in H4. destruct H4. { subst x. auto. } { unfold matchable in H. destruct H.
       exists x. exists x0. destruct H7. auto. } Qed.

Lemma insert_order_transaction_ask (M: list transaction) (B A: list order) (a:order):
~matchable B A -> Matching M B (a::A) -> (forall t, In t M -> ida t = id a).
Proof. intros.  destruct H0. unfold Tvalid in H0. unfold valid in H0.
       destruct M eqn:HM. auto. assert(In t (t::l)). auto.  apply H0 in H1.
       destruct H1. destruct H1. destruct H1. destruct H4. destruct H5. destruct H6.
       simpl in H1. destruct H1. { subst x0. auto. }  { unfold matchable in H.
       destruct H. exists x. exists x0. destruct H7. auto. } Qed.

Lemma insert_order_t_Q_le_bid_aux1 (M: list transaction) (b:order) :
(forall t, In t M-> idb t = id b) -> Qty_bid M (id b) = Vol M.
Proof. induction M. simpl. auto. intros. simpl. destruct(Nat.eqb (idb a)
       (id b)) eqn:Ht. specialize (H a) as H2. simpl in H2. cut(Qty_bid M
       (id b) = Vol M). lia. apply IHM. intros. move /eqP in Ht.
       specialize (H t) as H3. simpl in H3. destruct H3. auto. auto.
       specialize (H a) as H2. simpl in H2. destruct H2. auto.
       move /eqP in Ht. destruct Ht. auto. Qed.

Lemma insert_order_t_Q_le_ask_aux1 (M: list transaction) (b:order) :
(forall t, In t M-> ida t = id b) -> Qty_ask M (id b) = Vol M.
Proof. induction M. simpl. auto. intros. simpl.
       destruct(Nat.eqb (ida a) (id b)) eqn:Ht. specialize (H a) as H2.
       simpl in H2. cut(Qty_ask M (id b) = Vol M). lia. apply IHM.
       intros. move /eqP in Ht. specialize (H t) as H3. simpl in H3.
       destruct H3. auto. auto. specialize (H a) as H2. simpl in H2.
       destruct H2. auto. move /eqP in Ht. destruct Ht. auto. Qed.

Lemma insert_order_t_Q_le_bid_aux2 (M: list transaction) (b:order) :
(forall t, In t M -> idb t = id b) -> Qty_bid M (id b) <= oquantity b
-> Vol M <= oquantity b. intros.
Proof. intros. replace (Vol M) with (Qty_bid M (id b)). induction M
       as [|m0 M]. simpl;auto. simpl. simpl in H0.
       destruct(Nat.eqb (idb m0) (id b)) eqn:Ht. auto. auto.
       apply insert_order_t_Q_le_bid_aux1. auto. Qed.

Lemma insert_order_t_Q_le_ask_aux2 (M: list transaction) (b:order) :
(forall t, In t M -> ida t = id b) -> Qty_ask M (id b) <= oquantity b
-> Vol M <= oquantity b. intros.
Proof. intros. replace (Vol M) with (Qty_ask M (id b)). induction M
       as [|m0 M]. simpl;auto. simpl. simpl in H0.
       destruct(Nat.eqb (idb m0) (id b)) eqn:Ht. auto. auto.
       apply insert_order_t_Q_le_ask_aux1. auto. Qed.

Lemma insert_order_t_Q_le_bid (M: list transaction) (B A: list order) (b:order):
~matchable B A -> Matching M (b::B) A -> (Vol M) <= (oquantity b).
Proof. intros. assert((forall t, In t M -> idb t = id b)). intros.
       eapply insert_order_transaction_bid. exact H. exact H0. auto.
       destruct H0. unfold Tvalid in H0. unfold valid in H0. destruct H2.
       assert(In b (b::B)).  auto.  specialize (H2 b).
       apply insert_order_t_Q_le_bid_aux2. apply H1. auto. Qed.

Lemma insert_order_t_Q_le_ask (M: list transaction) (B A: list order) (a:order):
~matchable B A -> Matching M B (a::A) -> (Vol M) <= (oquantity a).
Proof.  intros. assert((forall t, In t M -> ida t = id a)). intros.
        eapply insert_order_transaction_ask. exact H. exact H0. auto.
        destruct H0. unfold Tvalid in H0. unfold valid in H0. destruct H2.
        assert(In a (a::A)).  auto.  specialize (H2 a).
        apply  insert_order_t_Q_le_ask_aux2. apply H1. auto. Qed.

Lemma insert_order_Qle_id_of_b_in_Bhat_aux2 (M: list transaction) (B A: list order) (b:order):
NoDup (ids B)-> In b B -> Matching M B A -> Vol M < oquantity b ->
In (id b) (ids (odiff B (bids M B))). intros.
Proof. intros. apply odiff_intro. replace (quant B (id b)) with
       (oquantity b). replace (quant (bids M B) (id b)) with (Qty_bid M (id b)).
       assert(Vol M >= Qty_bid M (id b)). apply Q_vs_Qty_bid. lia. symmetry.
       apply bids_id_quant. auto. apply ids_intro. auto. symmetry.
       apply quant_elim1. auto. Qed.

Lemma insert_order_Qle_id_of_a_in_Ahat_aux2 (M: list transaction) (B A: list order) (a:order):
NoDup (ids A)-> In a A -> Matching M B A -> Vol M < oquantity a ->
In (id a) (ids (odiff A (asks M A))).
Proof. intros. apply odiff_intro. replace (quant A (id a)) with
       (oquantity a). replace (quant (asks M A) (id a)) with (Qty_ask M (id a)).
       assert(Vol M >= Qty_ask M (id a)). apply Q_vs_Qty_ask. lia. symmetry.
       apply asks_id_quant. auto. apply ids_intro. auto.
       symmetry. apply quant_elim1. auto. Qed.

Lemma insert_order_Qle_id_of_b_in_Bhat
(M: list transaction) (B A: list order) (b:order):
NoDup (ids (b :: B)) -> ~matchable B A -> Matching M (b::B) A ->
(Vol M) < (oquantity b) -> In (id b) (ids (odiff (b::B) (bids M (b::B)))).
Proof. intros. apply insert_order_Qle_id_of_b_in_Bhat_aux2 with (A:=A). all: auto. Qed.

Lemma insert_order_Qle_id_of_a_in_Ahat (M: list transaction) (B A: list order) (a:order):
NoDup (ids (a :: A)) -> ~matchable B A -> Matching M B (a::A)->
(Vol M) < (oquantity a) -> In (id a) (ids (odiff (a::A) (asks M (a::A)))).
Proof. intros. apply insert_order_Qle_id_of_a_in_Ahat_aux2 with (B:=B). all: auto. Qed.

Lemma QM1_gt_QM2_extra_bid_in_M1_aux1 (M1 M2: list transaction):
(Vol M1)>(Vol M2) ->
(exists i, (In i (ids_bid_aux M1))/\(Qty_bid M1 i) > Qty_bid M2 i).
Proof. intro. assert(subset (fun_ids_bid M1) (fun_ids_bid M2)
        \/~subset (fun_ids_bid M1) (fun_ids_bid M2)). eauto. destruct H0.
       replace (Vol M1) with (Q_by_bids M1) in H. replace (Vol M2) with
       (Q_by_bids M2) in H. intros.  unfold Q_by_bids in H.
       assert(Q_by_bids_aux M2 (fun_ids_bid M2) >= Q_by_bids_aux M2 (fun_ids_bid M1)).
       apply Q_by_bids_aux_subset_I1_I2. unfold fun_ids_bid. eauto.
       unfold fun_ids_bid. eauto. auto. assert(Q_by_bids_aux M1 (fun_ids_bid M1) >
       Q_by_bids_aux M2 (fun_ids_bid M1)). lia. apply Q_by_bids_aux_T1_T2 in H2.
       destruct H2 as [i H2]. destruct H2. exists i. split.  unfold fun_ids_bid in H2.
       apply uniq_intro_elim. auto. auto. symmetry. apply Q_Qty_bid.
       symmetry;apply Q_Qty_bid. assert(exists i, In i (fun_ids_bid M1)/\~In i
       (fun_ids_bid M2)). apply no_subset_existsA. auto. destruct H1 as [i H1].
       exists i. destruct H1. split. apply uniq_intro_elim. auto.
       assert(Qty_bid M2 i = 0). apply Qty_bid_t_zero. intro. apply uniq_intro_elim
       in H3. eauto. rewrite H3. apply ids_bid_intro0. apply uniq_intro_elim;auto.
       Qed.

Lemma QM1_gt_QM2_extra_bid_in_M1 (M1 M2: list transaction) (B A: list order):
Matching M1 B A ->Matching M2 B A -> (Vol M1)>(Vol M2) ->
(exists b, (In b B)/\(Qty_bid M1 (id b)) >
Qty_bid M2 (id b)/\(exists t, In t M1/\(idb t = id b))).
Proof. intros. apply QM1_gt_QM2_extra_bid_in_M1_aux1 in H1.
       destruct H1. destruct H1. apply ids_bid_aux_intro1 in H1 as H3.
       destruct H3. destruct H. unfold Tvalid in H.
       destruct H3. apply H in H3 as H3m. unfold valid in H3m. destruct H3m.
       destruct H6. exists x1. split. apply H6. split. replace (id x1) with (x).
       auto. subst x. apply H6. exists x0. split.  auto. apply H6. Qed.

Lemma QM1_gt_QM2_extra_ask_in_M1_aux1 (M1 M2: list transaction):
(Vol M1)>(Vol M2) ->
(exists i, (In i (ids_ask_aux M1))/\(Qty_ask M1 i) > Qty_ask M2 i).
Proof. intro. assert(subset (fun_ids_ask M1) (fun_ids_ask M2)
       \/~subset (fun_ids_ask M1) (fun_ids_ask M2)). eauto.
       destruct H0. replace (Vol M1) with (Q_by_asks M1) in H.
       replace (Vol M2) with (Q_by_asks M2) in H. intros.  unfold Q_by_asks in H.
       assert(Q_by_asks_aux M2 (fun_ids_ask M2) >= Q_by_asks_aux M2 (fun_ids_ask M1)).
       apply Q_by_asks_aux_subset_I1_I2. unfold fun_ids_ask. eauto. unfold
       fun_ids_ask. eauto. auto. assert(Q_by_asks_aux M1 (fun_ids_ask M1) >
       Q_by_asks_aux M2 (fun_ids_ask M1)). lia. apply Q_by_asks_aux_T1_T2 in H2.
       destruct H2 as [i H2]. destruct H2. exists i. split.  unfold fun_ids_ask in H2.
       apply uniq_intro_elim. auto. auto. symmetry;apply Q_Qty_ask.
       symmetry;apply Q_Qty_ask. assert(exists i, In i (fun_ids_ask M1)/\
       ~In i (fun_ids_ask M2)). apply no_subset_existsA. auto. destruct H1 as [i H1].
       exists i. destruct H1. split. apply uniq_intro_elim. auto.
       assert(Qty_ask M2 i = 0). apply Qty_ask_t_zero. intro. apply uniq_intro_elim
       in H3. eauto. rewrite H3. apply ids_ask_intro0. apply uniq_intro_elim;auto.
       Qed.

Lemma QM1_gt_QM2_extra_ask_in_M1 (M1 M2: list transaction) (B A: list order):
Matching M1 B A ->Matching M2 B A -> (Vol M1)>(Vol M2) ->
(exists a, (In a A)/\(Qty_ask M1 (id a)) > Qty_ask M2 (id a)/\(exists t, In t M1/\(ida t = id a))).
Proof. intros. apply QM1_gt_QM2_extra_ask_in_M1_aux1 in H1.
       destruct H1. destruct H1. apply ids_ask_aux_intro1 in H1 as H3.
       destruct H3. destruct H. unfold Tvalid in H.
       destruct H3. apply H in H3 as H3m. unfold valid in H3m. destruct H3m.
       destruct H6. exists x2. split. apply H6. split. replace (id x2) with (x).
       auto. subst x. apply H6. exists x0. split.  auto. apply H6. Qed.

Lemma QM1_eq_QM2_extra_bid_in_M1 (M1 M2: list transaction)(i:nat):
Vol M1 = Vol M2 -> Qty_bid M1 i > Qty_bid M2 i -> exists i' : nat, Qty_bid M1 i' < Qty_bid M2 i'.
Proof. replace (Vol M1) with (Q_by_bids M1).
       replace (Vol M2) with (Q_by_bids M2).
       intros.  unfold Q_by_bids in H.
       assert(Q_by_bids_aux M1 (fun_ids_bid M1) = Q_by_bids_aux M2 (fun_ids_bid M1)\/
       Q_by_bids_aux M1 (fun_ids_bid M1) > Q_by_bids_aux M2 (fun_ids_bid M1)\/
       Q_by_bids_aux M1 (fun_ids_bid M1) < Q_by_bids_aux M2 (fun_ids_bid M1)). lia.
       destruct H1. assert(In i(fun_ids_bid M1)\/~In i(fun_ids_bid M1)).
       eauto. destruct H2. apply Q_by_bids_aux_T_i_In_I with (T:=M1) in H2 as Ha1.
       rewrite Ha1 in H1. apply Q_by_bids_aux_T_i_In_I with (T:=M2) in H2 as Ha2.
       rewrite Ha2 in H1. assert(Q_by_bids_aux M1 (delete i (fun_ids_bid M1)) <
       Q_by_bids_aux M2 (delete i (fun_ids_bid M1))). lia.
       apply Q_by_bids_aux_T1_T2 in H3.
       destruct H3. destruct H3. exists x. lia. unfold not in H2.
       assert(Qty_bid M1 i = 0). apply Qty_bid_t_zero. intro.
       apply uniq_intro_elim in H3. eauto. lia.
       destruct H1. 2:{ apply Q_by_bids_aux_T1_T2 in H1. destruct H1.
       destruct H1. exists x. lia. }
       rewrite H in H1.
       assert(Subset (fun_ids_bid M2) (fun_ids_bid M1)
       \/~Subset (fun_ids_bid M2) (fun_ids_bid M1)). eauto.
       destruct H2.  assert(Q_by_bids_aux M2 (fun_ids_bid M1) >=
       Q_by_bids_aux M2 (fun_ids_bid M2) ). eapply Q_by_bids_aux_subset_I1_I2 in H2.
       exact H2. unfold fun_ids_bid. eauto. unfold fun_ids_bid. eauto. lia.
       assert(exists i, In i (fun_ids_bid M2)/\~In i (fun_ids_bid M1)).
       apply no_subset_existsA. auto. destruct H3. exists x. destruct H3.
       assert(Qty_bid M1 x = 0).  apply Qty_bid_t_zero. intro.
       apply uniq_intro_elim in H3. apply uniq_intro_elim in H5.
       destruct H4. auto.
       apply uniq_intro_elim in H3. apply ids_bid_intro0 in H3.
       lia. symmetry;apply Q_Qty_bid. symmetry;apply Q_Qty_bid. Qed.

Lemma QM1_eq_QM2_extra_ask_in_M1 (M1 M2: list transaction)(i:nat):
Vol M1 = Vol M2 -> Qty_ask M1 i > Qty_ask M2 i -> exists i' : nat, Qty_ask M1 i' < Qty_ask M2 i'.
Proof. replace (Vol M1) with (Q_by_asks M1).
       replace (Vol M2) with (Q_by_asks M2).
       intros.  unfold Q_by_asks in H.
       assert(Q_by_asks_aux M1 (fun_ids_ask M1) = Q_by_asks_aux M2 (fun_ids_ask M1)\/
       Q_by_asks_aux M1 (fun_ids_ask M1) > Q_by_asks_aux M2 (fun_ids_ask M1)\/
       Q_by_asks_aux M1 (fun_ids_ask M1) < Q_by_asks_aux M2 (fun_ids_ask M1)). lia.
       destruct H1. assert(In i(fun_ids_ask M1)\/~In i(fun_ids_ask M1)).
       eauto. destruct H2. apply Q_by_asks_aux_T_i_In_I with (T:=M1) in H2 as Ha1.
       rewrite Ha1 in H1. apply Q_by_asks_aux_T_i_In_I with (T:=M2) in H2 as Ha2.
       rewrite Ha2 in H1. assert(Q_by_asks_aux M1 (delete i (fun_ids_ask M1)) <
       Q_by_asks_aux M2 (delete i (fun_ids_ask M1))). lia.
       apply Q_by_asks_aux_T1_T2 in H3.
       destruct H3. destruct H3. exists x. lia. unfold not in H2.
       assert(Qty_ask M1 i = 0). apply Qty_ask_t_zero. intro.
       apply uniq_intro_elim in H3. eauto. lia.
       destruct H1. 2:{ apply Q_by_asks_aux_T1_T2 in H1. destruct H1.
       destruct H1. exists x. lia. }
       rewrite H in H1.
       assert(Subset (fun_ids_ask M2) (fun_ids_ask M1)
       \/~Subset (fun_ids_ask M2) (fun_ids_ask M1)). eauto.
       destruct H2.  assert(Q_by_asks_aux M2 (fun_ids_ask M1) >=
       Q_by_asks_aux M2 (fun_ids_ask M2) ). eapply Q_by_asks_aux_subset_I1_I2 in H2.
       exact H2. unfold fun_ids_ask. eauto. unfold fun_ids_ask. eauto. lia.
       assert(exists i, In i (fun_ids_ask M2)/\~In i (fun_ids_ask M1)).
       apply no_subset_existsA. auto. destruct H3. exists x. destruct H3.
       assert(Qty_ask M1 x = 0).  apply Qty_ask_t_zero. intro.
       apply uniq_intro_elim in H3. apply uniq_intro_elim in H5.
       destruct H4. auto.
       apply uniq_intro_elim in H3. apply ids_ask_intro0 in H3.
       lia. symmetry;apply Q_Qty_ask. symmetry;apply Q_Qty_ask. Qed.

End Matching.

Section Maximum.

Lemma MaxLemmaDelete (M: list transaction) (B A: list order) (w:order):
~ matchable B A ->
Matching M (delete_order B (id w)) (delete_order A (id w)) ->
MaxMatch M (delete_order B (id w)) (delete_order A (id w)).
Proof. intros. unfold MaxMatch. intros.
       apply not_matchable_delete with (b:=w) (a:=w) in H.
       apply not_matchable_matching_nil  in H1. subst. simpl.
       lia. auto. Qed.

Lemma MaxLemmaBuy (M: list transaction) (B A: list order) (b:order):
NoDup (ids A) -> NoDup (ids (b :: B)) ->
~matchable B A ->
Matching M (b::B) A ->
~matchable (odiff (b::B) (bids M (b::B))) (odiff A (asks M A)) ->
MaxMatch M (b::B) A.

Proof.
assert(~(exists a, In a A->tradable b a)\/(exists a, In a A->tradable b a)) as H.
{ unfold tradable. eauto. }
destruct H.
  { intros NDA NDB. intro H0. unfold MaxMatch.
    intros H1 H2 M' H3 H4. assert (M' = nil).
    { apply anot_matchable_tradable with (b:=b) in H0.
      apply not_matchable_matching_nil with (M:=M') in H0.
      auto. auto. auto. }
    subst. simpl. lia. }
  { unfold MaxMatch. intros NDA NDB.
    intros H0 H1 H2 M' H3 H4. assert(HM':=H3).
    assert(~matchable B A ->
    Matching M' (b::B) A -> (forall t, In t M' -> idb t = id b)) as H5.
    intros H5 H6 t H7.
    apply insert_order_transaction_bid with (B:=B)(A:=A)(M:=M'). auto. auto. auto.
    apply insert_order_t_Q_le_bid in H3 as Hm3.
    apply insert_order_t_Q_le_bid in H4 as Hm4.
    assert(Vol M = oquantity b\/Vol M < oquantity b) as H6. lia.
    destruct H6. { lia. }
    { apply insert_order_Qle_id_of_b_in_Bhat with (B:=B)(A:=A) in H6.
    apply odiff_exists in H6 as H7.  (*separate out this proof.*)
    assert(Vol M' = Vol M\/Vol M' < Vol M\/Vol M' > Vol M) as H8. lia.
    destruct H8. lia. destruct H8. lia.
    apply QM1_gt_QM2_extra_ask_in_M1 with (B:=b::B)(A:=A) in H8.
    destruct H8 as [a0 H8]. destruct H8 as [HA H8].
    destruct H8 as [H8 H9]. destruct H9 as [m0 H9].
    destruct H7 as [b0 H7]. destruct H9 as [H9 H10]. apply H5 in H9 as Hm10.
    destruct H3 as [H3 H11]. unfold Tvalid in H3. apply H3 in H9 as Hm9.
    unfold valid in Hm9.
    assert(Qty_ask M' (id a0) <= oquantity a0) as H12.
    apply HM'. eauto.
    assert(Qty_ask M (id a0) < oquantity a0) as H13. lia.
    assert(quant (asks M A) (id a0) = Qty_ask M (id a0)) as H14. apply asks_id_quant.
    eauto. destruct Hm9. apply ids_intro. auto.
    assert(In (id a0) (ids (odiff A (asks M A)))).
    apply odiff_intro. replace (quant A (id a0)) with (oquantity a0).
    lia. symmetry. apply quant_elim1. split. auto. auto.
    apply odiff_exists in H15 as H16. destruct H16 as [a' H16]. unfold matchable in H2.
    destruct H2. exists b0. exists a'. split.  apply H16.
    split. apply H7. unfold tradable. replace (oprice b0) with (price (b::B) (id b0)).
    replace (oprice a') with (price A (id a0)).
    destruct Hm9 as [b1 Hm9]. destruct Hm9 as [a1 Hm9]. destruct Hm9 as [Hm9 H17].
    destruct H17 as [H17 H18]. destruct H18 as [H18 H19].
    destruct H19 as [H19 H20]. destruct H20 as [H20 H21]. unfold tradable in H20.
    rewrite Hm10 in H18. replace (id b) with (id b0) in H18.
    rewrite H10 in H19. replace (oprice b1) with (price (b :: B) (id b1)) in H20.
    replace (oprice a1) with (price A (id a1)) in H20. rewrite H18. rewrite H19. auto.
    apply price_elim1. split.  auto. auto. apply price_elim1. split.  auto. auto.
    apply H7. symmetry. apply H16. destruct Hm9 as [b1 Hm9].
    destruct Hm9 as [a1 Hm9]. destruct Hm9 as [Hm9 H17].
    destruct H17 as [H17 H18]. destruct H18 as [H18 H19].
    destruct H19 as [H19 H20]. destruct H20 as [H20 H21]. unfold tradable in H20.
    replace (id b0) with (id b).  symmetry. apply H7. symmetry;apply H7. eauto.
    all:auto. } all:auto. } Qed.

Lemma MaxLemmaSell (M: list transaction) (B A: list order) (a:order):
NoDup (ids (a :: A)) -> NoDup (ids B) -> ~matchable B A ->
Matching M B (a::A) ->
~matchable (odiff B (bids M B)) (odiff (a::A) (asks M (a::A))) ->
MaxMatch M B (a::A).
Proof. assert(~(exists b, In b B->tradable b a)\/(exists b, In b B->tradable b a)) as H.
{ unfold tradable. eauto. }
destruct H.
  { intros NDA NDB. intro H0. unfold MaxMatch.
    intros H1 H2 M' H3 H4. assert (M' = nil).
    { apply bnot_matchable_tradable with (a:=a) in H0.
      apply not_matchable_matching_nil with (M:=M') in H0.
      auto. auto. auto. }
    subst. simpl. lia. }
  { unfold MaxMatch. intros NDA NDB.
    intros H0 H1 H2 M' H3 H4. assert(HM':=H3).
    assert(~matchable B A ->
    Matching M' B (a::A) -> (forall t, In t M' -> ida t = id a)) as H5.
    intros H5 H6 t H7.
    apply insert_order_transaction_ask with (B:=B)(A:=A)(M:=M'). auto. auto. auto.
    apply insert_order_t_Q_le_ask in H3 as Hm3.
    apply insert_order_t_Q_le_ask in H4 as Hm4.
    assert(Vol M = oquantity a\/Vol M < oquantity a) as H6. lia.
    destruct H6. { lia. }
    { apply insert_order_Qle_id_of_a_in_Ahat with (B:=B)(A:=A) in H6.
    apply odiff_exists in H6 as H7.  (*separate out this proof.*)
    assert(Vol M' = Vol M\/Vol M' < Vol M\/Vol M' > Vol M) as H8. lia.
    destruct H8. lia. destruct H8. lia.
    apply QM1_gt_QM2_extra_bid_in_M1 with (B:=B)(A:=(a::A)) in H8.
    destruct H8 as [b0 H8]. destruct H8 as [HB H8].
    destruct H8 as [H8 H9]. destruct H9 as [m0 H9].
    destruct H7 as [a0 H7]. destruct H9 as [H9 H10].
    apply H5 in H9 as Hm10.
    destruct H3 as [H3 H11]. unfold Tvalid in H3. apply H3 in H9 as Hm9.
    unfold valid in Hm9.
    assert(Qty_bid M' (id b0) <= oquantity b0) as H12.
    apply HM'. auto.
    assert(Qty_bid M (id b0) < oquantity b0) as H13. lia.
    assert(quant (bids M B) (id b0) = Qty_bid M (id b0)) as H14. apply bids_id_quant.
    eauto. destruct Hm9. apply ids_intro. auto.
    assert(In (id b0) (ids (odiff B (bids M B)))).
    apply odiff_intro. replace (quant B (id b0)) with (oquantity b0).
    lia. symmetry. apply quant_elim1. split. auto. auto.
    apply odiff_exists in H15 as H16. destruct H16 as [b' H16].
    unfold matchable in H2.
    destruct H2. exists b'. exists a0. split.  apply H7.
    split. apply H16. unfold tradable.
    destruct Hm9 as [b1 Hm9]. destruct Hm9 as [a1 Hm9]. destruct Hm9 as [Hm9 H17].
    destruct H17 as [H17 H18]. destruct H18 as [H18 H19].
    destruct H19 as [H19 H20]. destruct H20 as [H20 H21]. unfold tradable in H20.
    destruct H16. destruct H16. rewrite H22. destruct H7. destruct H23.
    rewrite H24.
    rewrite price_elim1. split.  auto. auto. rewrite price_elim1. split.  auto. auto.
    assert(a1=a). apply nodup_ids_uniq_order with (B:=a::A). auto. auto. auto.
    lia.
    assert(b1=b0). apply nodup_ids_uniq_order with (B:=B). auto. auto. auto.
    lia. subst.  auto. all:auto. } all:auto. } Qed.

Theorem Maximum_Maching (Process: list order->list order -> instruction ->
(list order)*(list order)*(list transaction))(B A hat_B hat_A : list order)(tau:instruction):
let B' := (fst (Absorb B A tau)) in
let A' := (snd (Absorb B A tau)) in
let hat_B := (Blist (Process B A tau)) in
let hat_A := (Alist (Process B A tau)) in
let M := (Mlist (Process B A tau)) in

Condition1 M B A hat_B hat_A tau->

Condition3a M B A tau->
Condition3b M B A hat_B tau ->
Condition3c M B A hat_A tau ->

not (matchable B A) ->

NoDup (ids B') ->
NoDup (ids A') ->

MaxMatch (Mlist (Process B A tau)) B' A'.
Proof. set(M:=(Process B A tau)). case (cmd tau) eqn:Ht.
        {
        simpl. unfold Condition1, Condition3a, Condition3b, Condition3c.
        unfold Absorb. rewrite Ht. unfold fst. unfold snd.
        intros H H0 H1 H2 H3 H4 H5.
        apply MaxLemmaBuy. all: auto.
        eapply not_matchable_perm_invariance. exact H. auto. auto.
       }
       {
        simpl. unfold Condition1, Condition3a, Condition3b, Condition3c.
        unfold Absorb. rewrite Ht. unfold fst. unfold snd.
        intros H H0 H1 H2 H3 H4 H5.
        apply MaxLemmaSell. all:auto.
        eapply not_matchable_perm_invariance. exact H. auto. auto.
       }
       {
        simpl. unfold Condition1, Condition3a, Condition3b, Condition3c.
        unfold Absorb. rewrite Ht. unfold fst. unfold snd.
        intros H H0 H1 H2 H3 H4 H5.
        apply MaxLemmaDelete. all:auto.
       } Qed.

End Maximum.

Section PTPsize.

Lemma uniq_time (A:list order)(a1 a2:order):
NoDup (timesof A) -> In a1 A -> In a2 A ->a1<>a2 -> otime a1 <> otime a2.
Proof. revert a1 a2. induction A. simpl. auto. simpl. intros.
destruct H0;destruct H1. { subst. auto. }
{ subst. assert(~In (otime a1) (timesof A)). eauto.
  apply timesof_elim in H1. intro. rewrite H3 in H0. destruct (H0 H1). }
{ subst. assert(~In (otime a2) (timesof A)). eauto.
  apply timesof_elim in H0. intro. rewrite H3 in H0. destruct (H1 H0). }
{ apply IHA. eauto. all:auto. } Qed.

Lemma size_equal_and_price_time_priorityA (M1 M2: list transaction)(B A: list order):
NoDup (ids A) -> NoDup (ids B) ->
NoDup (timesof A) -> NoDup (timesof B) ->
(forall t, In t M1 -> over t B A) -> (forall t, In t M2 -> over t B A) ->
Vol M1 = Vol M2 ->
(forall a a', (In a A)/\(In a' A)/\(acompetitive a a'/\~eqcompetitive a a')/\(In (id a') (ids_ask_aux M1))
-> (Qty_ask M1 (id a)) = (oquantity a)) ->
(forall a a', (In a A)/\(In a' A)/\(acompetitive a a'/\~eqcompetitive a a')/\(In (id a') (ids_ask_aux M2))
-> (Qty_ask M2 (id a)) = (oquantity a)) ->
(forall a, In a A -> (Qty_ask M1 (id a) ) <= (oquantity a)) ->
(forall a, In a A-> (Qty_ask M2 (id a) ) <= (oquantity a)) ->
(forall i, Qty_ask M1 i = Qty_ask M2 i).
Proof.
intros NDtA NDtB NDA NDB M1BA M2BA H H01 H02 H11 H12 i. assert (Qty_ask M1 i = Qty_ask M2 i\/Qty_ask M1 i > Qty_ask M2 i
\/Qty_ask M1 i < Qty_ask M2 i) as H2. lia. destruct H2 as [H2 | H2]. auto. destruct H2 as [H2 | H2].
{ assert(exists i', Qty_ask M1 i' < Qty_ask M2 i') as H3.
  apply QM1_eq_QM2_extra_ask_in_M1 in H2.
  auto. auto. unfold over in M1BA.
  unfold over in M2BA. destruct H3 as [i' H3].
  assert(Qty_ask M1 i >0) as H4. lia. apply Qty_ask_elim in H4.
  assert(Qty_ask M2 i' >0) as H5. lia. apply Qty_ask_elim in H5.
  destruct H4 as [m1 H4]. destruct H5 as [m2 H5].
  destruct H4 as [H4a H4b]. destruct H5 as [H5a H5b].
  apply M1BA in H4a as M1a. apply M2BA in H5a as M2a.
  destruct M1a as [b1 M1a]. destruct M1a as [a1 M1a].
  destruct M1a as [a1A M1a]. destruct M1a as [b1B M1a].
  destruct M1a as [idb1 ida1].
  destruct M2a as [b2 M2a]. destruct M2a as [a2 M2a].
  destruct M2a as [a2A M2a]. destruct M2a as [b2B M2a].
  destruct M2a as [idb2 ida2].
  assert (a1 = a2\/a1<>a2) as Ha1a2. eauto. destruct Ha1a2 as [Heq|Hneq].
  { assert(i = i'). subst a1. lia. subst i. subst i'. rewrite H0 in H2. lia. }
  { (*Case:a1<>a2*)
  assert (acompetitive a1 a2 \/~acompetitive a1 a2) as H4. eauto.
  destruct H4 as [H4|H4].
   { specialize (H02 a1 a2).
     specialize (H11 a1). specialize (H11 a1A).
     assert (Qty_ask M2 (id a1) < oquantity a1) as M2q.
     replace i with (ida m1) in H2. replace (ida m1) with (id a1) in H2.
     lia. assert(Qty_ask M2 (id a1) = oquantity a1) as H2q'.
     apply H02. split. auto. split. auto. replace (id a2) with (ida m2).
     split. split. auto. intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime a1 <> otime a2).
     apply uniq_time with (A:=A). all:auto. apply uniq_intro_elim.
     apply ids_ask_intro1. auto.
     replace i with (id a2) in H2. replace i' with (id a2) in H3. lia. lia.
     lia.
   }
   { apply not_acompetitive in H4. specialize (H01 a2 a1).
     specialize (H12 a2).  specialize (H12 a2A).
     assert (Qty_ask M1 (id a2) < oquantity a2) as M1q.
     replace i' with (ida m2) in H3. replace (ida m2) with (id a2) in H3.
     lia. assert(Qty_ask M1 (id a2) = oquantity a2) as H1q'.
     apply H01. split. auto. split. auto. split. split. auto.
     intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime a1 <> otime a2).
     apply uniq_time with (A:=A). all:auto.
     replace (id a1) with (ida m1).
     apply uniq_intro_elim.
     auto. apply ids_ask_intro1. auto.
     lia.
   }
} }
{ assert(exists i', Qty_ask M2 i' < Qty_ask M1 i') as H3.
  apply QM1_eq_QM2_extra_ask_in_M1 in H2.
  auto. auto. unfold over in M1BA.
  unfold over in M2BA. destruct H3 as [i' H3].
  assert(Qty_ask M2 i >0) as H4. lia. apply Qty_ask_elim in H4.
  assert(Qty_ask M1 i' >0) as H5. lia. apply Qty_ask_elim in H5.
  destruct H4 as [m2 H4]. destruct H5 as [m1 H5].
  destruct H4 as [H4a H4b]. destruct H5 as [H5a H5b].
  apply M1BA in H5a as M1a. apply M2BA in H4a as M2a.
  destruct M1a as [b1 M1a]. destruct M1a as [a1 M1a].
  destruct M1a as [a1A M1a]. destruct M1a as [b1B M1a].
  destruct M1a as [idb1 ida1].
  destruct M2a as [b2 M2a]. destruct M2a as [a2 M2a].
  destruct M2a as [a2A M2a]. destruct M2a as [b2B M2a].
  destruct M2a as [idb2 ida2].
  assert (a1 = a2\/a1<>a2) as Ha1a2. eauto. destruct Ha1a2 as [Heq|Hneq].
  { assert(i = i'). subst a1. lia. subst i. subst i'. rewrite H0 in H2. lia. }
  { (*Case:a1<>a2*)
  assert (acompetitive a1 a2 \/~acompetitive a1 a2) as H4. eauto.
  destruct H4 as [H4|H4].
   { subst. specialize (H02 a1 a2).
     specialize (H11 a1).  specialize (H11 a1A).
     assert (Qty_ask M2 (id a1) < oquantity a1) as M1q.
     replace (ida m1) with (id a1) in H3.
     lia. assert(Qty_ask M2 (id a1) = oquantity a1) as H2q'.
     apply H02. split. auto. split. auto. split. split. auto.
     intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime a1 <> otime a2).
     apply uniq_time with (A:=A). all:auto.
     replace (id a2) with (ida m2).
     apply uniq_intro_elim. apply ids_ask_intro1. auto.
     lia.
   }
   { subst. apply not_acompetitive in H4. specialize (H01 a2 a1).
     specialize (H12 a2).  specialize (H12 a2A).
     assert (Qty_ask M1 (id a2) < oquantity a2) as M1q.
     replace (ida m2) with (id a2) in H2.
     lia. assert(Qty_ask M1 (id a2) = oquantity a2) as H1q'.
     apply H01. split. auto. split. auto.
     split. split. auto.
     intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime a1 <> otime a2).
     apply uniq_time with (A:=A). all:auto.
     replace (id a1) with (ida m1).
     apply uniq_intro_elim. apply ids_ask_intro1. auto.
     lia.
   }
} }
Qed.

Lemma size_equal_and_price_time_priorityB (M1 M2: list transaction)(B A: list order):
NoDup (ids A) -> NoDup (ids B) ->
NoDup (timesof A) -> NoDup (timesof B) ->
(forall t, In t M1 -> over t B A) -> (forall t, In t M2 -> over t B A) ->
Vol M1 = Vol M2 ->
(forall b b', (In b B)/\(In b' B)/\(bcompetitive b b'/\~eqcompetitive b b')/\(In (id b') (ids_bid_aux M1))
-> (Qty_bid M1 (id b)) = (oquantity b)) ->
(forall b b', (In b B)/\(In b' B)/\(bcompetitive b b'/\~eqcompetitive b b')/\(In (id b') (ids_bid_aux M2))
-> (Qty_bid M2 (id b)) = (oquantity b)) ->
(forall b, In b B -> (Qty_bid M1 (id b) ) <= (oquantity b)) ->
(forall b, In b B -> (Qty_bid M2 (id b) ) <= (oquantity b)) ->
(forall i, Qty_bid M1 i = Qty_bid M2 i).
Proof.
intros NDtA NDtB NDA NDB M1BA M2BA H H01 H02 H11 H12 i. assert (Qty_bid M1 i = Qty_bid M2 i\/Qty_bid M1 i > Qty_bid M2 i
\/Qty_bid M1 i < Qty_bid M2 i) as H2. lia. destruct H2 as [H2 | H2]. auto. destruct H2 as [H2 | H2].
{ assert(exists i', Qty_bid M1 i' < Qty_bid M2 i') as H3.
  apply QM1_eq_QM2_extra_bid_in_M1 in H2.
  auto. auto. unfold over in M1BA.
  unfold over in M2BA. destruct H3 as [i' H3].
  assert(Qty_bid M1 i >0) as H4. lia. apply Qty_bid_elim in H4.
  assert(Qty_bid M2 i' >0) as H5. lia. apply Qty_bid_elim in H5.
  destruct H4 as [m1 H4]. destruct H5 as [m2 H5].
  destruct H4 as [H4a H4b]. destruct H5 as [H5a H5b].
  apply M1BA in H4a as M1a. apply M2BA in H5a as M2a.
  destruct M1a as [b1 M1a]. destruct M1a as [a1 M1a].
  destruct M1a as [a1A M1a]. destruct M1a as [b1B M1a].
  destruct M1a as [idb1 ida1].
  destruct M2a as [b2 M2a]. destruct M2a as [a2 M2a].
  destruct M2a as [a2A M2a]. destruct M2a as [b2B M2a].
  destruct M2a as [idb2 ida2].
  assert (b1 = b2\/b1<>b2) as Ha1a2. eauto. destruct Ha1a2 as [Heq|Hneq].
  { assert(i = i'). subst b1. lia. subst i. subst i'. rewrite H0 in H2. lia. }
  { (*Case:b1<>b2*)
  assert (bcompetitive b1 b2 \/~bcompetitive b1 b2) as H4. eauto.
  destruct H4 as [H4|H4].
   { specialize (H02 b1 b2).
     specialize (H11 b1). specialize (H11 b1B).
     assert (Qty_bid M2 (id b1) < oquantity b1) as M2q.
     replace i with (idb m1) in H2. replace (idb m1) with (id b1) in H2.
     lia. assert(Qty_bid M2 (id b1) = oquantity b1) as H2q'.
     apply H02. split. auto. split. auto. replace (id b2) with (idb m2).
     split. split. auto. intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime b1 <> otime b2).
     apply uniq_time with (A:=B). all:auto. apply uniq_intro_elim.
     apply ids_bid_intro1. auto. lia.
   }
   { apply not_bcompetitive in H4. specialize (H01 b2 b1).
     specialize (H12 b2). specialize (H12 b2B).
     assert (Qty_bid M1 (id b2) < oquantity b2) as M1q.
     replace i' with (idb m2) in H3. replace (idb m2) with (id b2) in H3.
     lia. assert(Qty_bid M1 (id b2) = oquantity b2) as H1q'.
     apply H01. split. auto. split. auto. split. split. auto.
     intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime b1 <> otime b2).
     apply uniq_time with (A:=B). all:auto.
     replace (id b1) with (idb m1).
     apply uniq_intro_elim.
     auto. apply ids_bid_intro1. auto.
     lia.
   }
} }
{ assert(exists i', Qty_bid M2 i' < Qty_bid M1 i') as H3.
  apply QM1_eq_QM2_extra_bid_in_M1 in H2.
  auto. auto. unfold over in M1BA.
  unfold over in M2BA. destruct H3 as [i' H3].
  assert(Qty_bid M2 i >0) as H4. lia. apply Qty_bid_elim in H4.
  assert(Qty_bid M1 i' >0) as H5. lia. apply Qty_bid_elim in H5.
  destruct H4 as [m2 H4]. destruct H5 as [m1 H5].
  destruct H4 as [H4a H4b]. destruct H5 as [H5a H5b].
  apply M1BA in H5a as M1a. apply M2BA in H4a as M2a.
  destruct M1a as [b1 M1a]. destruct M1a as [a1 M1a].
  destruct M1a as [a1A M1a]. destruct M1a as [b1B M1a].
  destruct M1a as [idb1 ida1].
  destruct M2a as [b2 M2a]. destruct M2a as [a2 M2a].
  destruct M2a as [a2A M2a]. destruct M2a as [b2B M2a].
  destruct M2a as [idb2 ida2].
  assert (b1 = b2\/b1<>b2) as Ha1a2. eauto. destruct Ha1a2 as [Heq|Hneq].
  { assert(i = i'). subst b1. lia. subst i. subst i'. rewrite H0 in H2. lia. }
  { (*Case:b1<>b2*)
  assert (bcompetitive b1 b2 \/~bcompetitive b1 b2) as H4. eauto.
  destruct H4 as [H4|H4].
   { subst. specialize (H02 b1 b2).
     specialize (H11 b1). specialize (H11 b1B).
     assert (Qty_bid M2 (id b1) < oquantity b1) as M1q.
     replace (idb m1) with (id b1) in H3.
     lia. assert(Qty_bid M2 (id b1) = oquantity b1) as H2q'.
     apply H02. split. auto. split. auto. split. split. auto.
     intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime b1 <> otime b2).
     apply uniq_time with (A:=B). all:auto.
     replace (id b2) with (idb m2).
     apply uniq_intro_elim. apply ids_bid_intro1. auto.
     lia.
   }
   { subst. apply not_bcompetitive in H4. specialize (H01 b2 b1).
     specialize (H12 b2). specialize (H12 b2B).
      assert (Qty_bid M1 (id b2) < oquantity b2) as M1q.
     replace (idb m2) with (id b2) in H2.
     lia. assert(Qty_bid M1 (id b2) = oquantity b2) as H1q'.
     apply H01. split. auto. split. auto.
     split. split. auto.
     intro Hcontra. unfold eqcompetitive in Hcontra.
     move /andP in Hcontra. destruct Hcontra as [H1c H2c].
     move /eqP in H2c. assert(otime b1 <> otime b2).
     apply uniq_time with (A:=B). all:auto.
     replace (id b1) with (idb m1).
     apply uniq_intro_elim. apply ids_bid_intro1. auto.
     lia.
   }
} }
Qed.

End PTPsize.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Ring_cat.
Require Export Operation_of_monoid.
(** Title "The category of modules on a ring." *)
Section Def.
Variable R : RING.
Section Module_def.
Variable Mod : abelian_group.
Variable op : operation (ring_monoid R) Mod.

Definition op_lin_left :=
  forall (a b : R) (x : Mod),
  Equal (op (sgroup_law R a b) x) (sgroup_law Mod (op a x) (op b x)).

Definition op_lin_right :=
  forall (a : R) (x y : Mod),
  Equal (op a (sgroup_law Mod x y)) (sgroup_law Mod (op a x) (op a y)).
End Module_def.

Record module_on (M : abelian_group) : Type :=
  {module_op : operation (ring_monoid R) M;
   module_op_lin_left_prf : op_lin_left module_op;
   module_op_lin_right_prf : op_lin_right module_op}.

Record module : Type :=
  {module_carrier :> abelian_group;
   module_on_def :> module_on module_carrier}.
Coercion Build_module : module_on >-> module.

Definition module_mult (B : module) (a : R) (x : B) := module_op B a x.
Section Hom.
Variable E F : module.

Definition module_hom_prop (f : E -> F) :=
  forall (a : R) (x : E), Equal (f (module_mult a x)) (module_mult a (f x)).

Record module_hom : Type :=
  {module_monoid_hom :> monoid_hom E F;
   module_hom_prf : module_hom_prop module_monoid_hom}.
End Hom.

Definition module_hom_comp :
  forall E F Mod : module,
  module_hom F Mod -> module_hom E F -> module_hom E Mod.
intros E F Mod g f; try assumption.
apply
 (Build_module_hom (E:=E) (F:=Mod) (module_monoid_hom:=monoid_hom_comp g f)).
unfold module_hom_prop in |- *; auto with algebra.
simpl in |- *.
unfold comp_map_fun in |- *.
intros a x; try assumption.
apply
 Trans
  with
    (Ap (sgroup_map (monoid_sgroup_hom (module_monoid_hom g)))
       (module_mult a
          (Ap (sgroup_map (monoid_sgroup_hom (module_monoid_hom f))) x))).
cut
 (Equal
    (Ap (sgroup_map (monoid_sgroup_hom (module_monoid_hom f)))
       (module_mult a x))
    (module_mult a
       (Ap (sgroup_map (monoid_sgroup_hom (module_monoid_hom f))) x))).
auto with algebra.
apply (module_hom_prf f).
apply (module_hom_prf g).
Defined.

Definition module_id : forall E : module, module_hom E E.
intros E; try assumption.
apply (Build_module_hom (module_monoid_hom:=monoid_id E)).
red in |- *.
simpl in |- *; auto with algebra.
Defined.

Definition MODULE : category.
apply
 (subcat (C:=MONOID) (C':=module) (i:=module_carrier)
    (homC':=fun E F : module =>
            Build_subtype_image (E:=Hom (c:=ABELIAN_GROUP) E F)
              (subtype_image_carrier:=module_hom E F)
              (module_monoid_hom (E:=E) (F:=F))) (CompC':=module_hom_comp)
    (idC':=module_id)).
simpl in |- *.
intros a; try assumption.
red in |- *.
auto with algebra.
simpl in |- *.
intros a b c g f; try assumption.
red in |- *.
auto with algebra.
Defined.
End Def.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal7.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst):@eq natural (len (qreva x (Cons n Nil))) (Succ (plus (len x) Zero)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_smallclam_lf_goal7_theorem0_58_plus_comm/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x.
QuickChick collect_data.
Success.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Import ListNotations.
Local Open Scope list_scope. Local Open Scope Z_scope.

Fixpoint update_nth {T} n f (xs:list T) {struct n} :=
	match n with
	| O => match xs with
				 | nil => nil
				 | x'::xs' => f x'::xs'
				 end
	| S n' =>  match xs with
				 | nil => nil
				 | x'::xs' => x'::update_nth n' f xs'
				 end
  end.

Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y.
Reserved Notation "'dlet' x .. y := v 'in' f"
         (at level 200, x binder, y binder, f at level 200, format "'dlet'  x .. y  :=  v  'in' '//' f").
Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).

Definition encodemod := (fun (limbwidth_num limbwidth_den s : Z) (c : list (Z * Z)) (n : nat) =>
 (fun (weight : nat -> Z) (n0 : nat) (s0 : Z) (c0 : list (Z * Z)) (x : Z) =>
  (fun (weight0 : nat -> Z) (n1 : nat) (s1 : Z) (c1 : list (Z * Z)) (p : list Z) (idxs : list nat) =>
   fold_right
     (fun (a : nat) (b : list Z) =>
      (fun (weight1 : nat -> Z) (n2 : nat) (s2 : Z) (c2 : list (Z * Z)) (index : nat) (p0 : list Z) =>
       (fun (weight2 : nat -> Z) (n3 : nat) (p1 : list (Z * Z)) =>
        fold_right
          (fun (t : Z * Z) (ls : list Z) =>
           dlet p2 : nat * Z := (fun (weight3 : nat -> Z) (t0 : Z * Z) (i : nat) =>
                                 nat_rect (fun _ : nat => (nat * Z)%type) (0%nat, fst t0 * snd t0)
                                   (fun (i' : nat) (place_i' : (fun _ : nat => (nat * Z)%type) i') =>
                                    let i0 := S i' in
                                    if fst t0 mod weight3 i0 =? 0
                                    then (i0, let c3 := fst t0 / weight3 i0 in c3 * snd t0)
                                    else place_i') i) weight2 t (Init.Nat.pred n3) in
           (fun (i : nat) (x0 : Z) (ls0 : list Z) => update_nth i (fun y : Z => x0 + y) ls0) (fst p2) (snd p2) ls)
          ((fun n4 : nat => repeat 0 n4) n3) p1) weight1 n2
         ((fun (s3 : Z) (c3 p1 : list (Z * Z)) =>
           let lo_hi :=
             (fun (s4 : Z) (p2 : list (Z * Z)) =>
              let hi_lo := partition (fun t : Z * Z => fst t mod s4 =? 0) p2 in
              (snd hi_lo, map (fun t : Z * Z => (fst t / s4, snd t)) (fst hi_lo))) s3 p1 in
           fst lo_hi ++
           (fun p2 q : list (Z * Z) => flat_map (fun t : Z * Z => map (fun t' : Z * Z => (fst t * fst t', snd t * snd t')) q) p2)
             c3 (snd lo_hi)) s2 c2
            ((fun (weight2 : nat -> Z) (n3 : nat) (xs : list Z) => combine (map weight2 (seq 0 n3)) xs) weight1
               (S n2)
               ((fun (weight2 : nat -> Z) (n3 m index0 : nat) (p1 : list Z) =>
                 (fun (weight3 : nat -> Z) (n4 : nat) (p2 : list (Z * Z)) =>
                  fold_right
                    (fun (t : Z * Z) (ls : list Z) =>
                     dlet p3 : nat * Z := (fun (weight4 : nat -> Z) (t0 : Z * Z) (i : nat) =>
                                           nat_rect (fun _ : nat => (nat * Z)%type) (0%nat, fst t0 * snd t0)
                                             (fun (i' : nat) (place_i' : (fun _ : nat => (nat * Z)%type) i') =>
                                              let i0 := S i' in
                                              if fst t0 mod weight4 i0 =? 0
                                              then (i0, let c3 := fst t0 / weight4 i0 in c3 * snd t0)
                                              else place_i') i) weight3 t (Init.Nat.pred n4) in
                     (fun (i : nat) (x0 : Z) (ls0 : list Z) => update_nth i (fun y : Z => x0 + y) ls0) (fst p3) (snd p3) ls)
                    ((fun n5 : nat => repeat 0 n5) n4) p2) weight2 m
                   ((fun (w fw : Z) (p2 : list (Z * Z)) =>
                     flat_map
                       ((fun (w0 fw0 : Z) (t : Z * Z) =>
                         if fst t =? w0
                         then
                          dlet t2 : Z := snd t in
                         dlet d2 : Z := t2 / fw0 in
                         dlet m2 : Z := t2 mod fw0 in
                         [(w0 * fw0, d2); (w0, m2)]
                         else [t]) w fw) p2) (weight2 index0) (weight2 (S index0) / weight2 index0)
                      ((fun (weight3 : nat -> Z) (n4 : nat) (xs : list Z) => combine (map weight3 (seq 0 n4)) xs) weight2 n3 p1)))
                  weight1 n2 (S n2) index p0)))) weight0 n1 s1 c1 a b) p (rev idxs)) weight n0 s0 c0
    ((fun (weight0 : nat -> Z) (n1 : nat) (p : list (Z * Z)) =>
      fold_right
        (fun (t : Z * Z) (ls : list Z) =>
         dlet p0 : nat * Z := (fun (weight1 : nat -> Z) (t0 : Z * Z) (i : nat) =>
                               nat_rect (fun _ : nat => (nat * Z)%type) (0%nat, fst t0 * snd t0)
                                 (fun (i' : nat) (place_i' : (fun _ : nat => (nat * Z)%type) i') =>
                                  let i0 := S i' in
                                  if fst t0 mod weight1 i0 =? 0
                                  then (i0, let c1 := fst t0 / weight1 i0 in c1 * snd t0)
                                  else place_i') i) weight0 t (Init.Nat.pred n1) in
         (fun (i : nat) (x0 : Z) (ls0 : list Z) => update_nth i (fun y : Z => x0 + y) ls0) (fst p0) (snd p0) ls)
        ((fun n2 : nat => repeat 0 n2) n1) p) weight n0 [(1, x)]) (seq 0 n0))
   ((fun (limbwidth_num0 limbwidth_den0 : Z) (i : nat) => 2 ^ (- (- (limbwidth_num0 * Z.of_nat i) / limbwidth_den0)))
      limbwidth_num limbwidth_den) n s c).

Notation encodep := (encodemod 51 2 (2^255) [(1,19)] 10 (2^255-1)).
Notation encodepby := (encodemod 8 1 (2^255) [(1,19)] 32 (2^255-1)).
Definition test1 := encodep.
Definition test5 := (encodep, encodep, encodep, encodep, encodep).
Definition test1by := encodepby.
Definition test5by := (encodepby, encodepby, encodepby, encodepby, encodepby).
Time Eval lazy in test1. (* 10.211 s *)
Time Eval cbv in test1. (* 12.285 s *)
Time Eval vm_compute in test1. (* 0.551 s *)
Time Eval native_compute in test1. (* 0.382 s *)
Time Eval vm_compute in test5. (* 2.547 s *)
Time Eval native_compute in test5. (* 1.372 s *)
Time Eval vm_compute in test1by. (* 14.394 s *)
Time Eval native_compute in test1by. (* 6.883 s *)

Require Import Coq.extraction.Extraction.
Redirect "test1.ml" Recursive Extraction test1.
Redirect "test5.ml" Recursive Extraction test5.
Redirect "test1by.ml" Recursive Extraction test1by.
Redirect "test5by.ml" Recursive Extraction test5by.
Require Import Coq.extraction.ExtrOcamlBasic.
Redirect "test1b.ml" Recursive Extraction test1.
Redirect "test5b.ml" Recursive Extraction test5.
Redirect "test1byb.ml" Recursive Extraction test1by.
Redirect "test5byb.ml" Recursive Extraction test5by.
(*
test1
real    0m0.043s
user    0m0.040s
sys     0m0.000s

test5
real    0m0.104s
user    0m0.100s
sys     0m0.000s

test1b
real    0m0.042s
user    0m0.040s
sys     0m0.000s

test5b
real    0m0.114s
user    0m0.112s
sys     0m0.000stest1
real    0m0.043s
user    0m0.040s
sys     0m0.000s

test5
real    0m0.104s
user    0m0.100s
sys     0m0.000s

test1b
real    0m0.042s
user    0m0.040s
sys     0m0.000s

test5b
real    0m0.114s
user    0m0.112s
sys     0m0.000s

test1by
real    0m0.538s
user    0m0.532s
sys     0m0.004s

test5by
real    0m2.248s
user    0m2.244s
sys     0m0.004s

test1byb
real    0m0.533s
user    0m0.524s
sys     0m0.008s

test5byb
real    0m2.295s
user    0m2.292s
sys     0m0.000s
*)


Require Export Coq.Lists.List.
Require Export Coq.ZArith.ZArith.
Require Export compcert.lib.Coqlib.
Require Export compcert.lib.Integers.
Require Export compcert.lib.Floats.
Require Export compcert.common.Values.
Require Export VST.msl.eq_dec.
Require Export VST.msl.Coqlib2.
Require Export VST.floyd.coqlib3.
Require Export VST.floyd.sublist.
Require Export Lia.
Require Export VST.floyd.list_solver.

Create HintDb entailer_rewrite discriminated.

Require Import VST.veric.val_lemmas.

Lemma Vint_injective i j (H: Vint i = Vint j): i=j.
Proof. inv H; trivial. Qed.

Lemma map_Vint_injective: forall l m, map Vint l = map Vint m -> l=m.
Proof. induction l; intros.
+ destruct m; inv H; trivial.
+ destruct m; inv H. f_equal; eauto.
Qed.

Lemma cons_inv {A} (a a':A) l l': a::l = a'::l' -> a=a' /\ l=l'.
Proof. intros. inv H; eauto. Qed.

Hint Rewrite
   (@Znth_map val _) (@Znth_map int _) (@Znth_map byte _)
   (@Znth_map int64 _) (@Znth_map ptrofs _) (@Znth_map float _)
   (@Znth_map float32 _)
    using (auto; rewrite ?Zlength_map in *; lia) : sublist entailer_rewrite.

Lemma is_long_dec v: {is_long v} + {~ is_long v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial]; left; trivial. Defined.

Lemma is_single_dec v: {is_single v} + {~ is_single v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial]; left; trivial. Defined.

Lemma is_float_dec v: {is_float v} + {~ is_float v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial]; left; trivial. Defined.

Lemma is_pointer_or_integer_dec v: {is_pointer_or_integer v} + {~ is_pointer_or_integer v}.
Proof.
unfold is_pointer_or_integer.
destruct Archi.ptr64 eqn:Hp;
destruct v; simpl; try solve [right; intros N; trivial]; left; trivial.
Defined.

Lemma is_pointer_or_null_dec v: {is_pointer_or_null v} + {~ is_pointer_or_null v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial]; try solve [left; trivial].
 try apply Int.eq_dec;  (* this line works for CompCert 3.3 *)
 destruct Archi.ptr64; auto; apply Int64.eq_dec.  (* this line needed for newer CompCert *)
Defined.

Lemma isptr_dec v: {isptr v} + {~ isptr v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial]; left; trivial. Defined.

Lemma isptr_offset_val':
 forall i p, isptr p -> isptr (offset_val i p).
Proof. intros. destruct p; try contradiction; apply Coq.Init.Logic.I. Qed.
Hint Extern 1 (isptr (offset_val _ _)) => apply isptr_offset_val' : core.
Hint Resolve isptr_offset_val': norm.

Lemma offset_val_force_ptr:
  offset_val 0 = force_ptr.
Proof. extensionality v. destruct v; try reflexivity.
simpl. rewrite Ptrofs.add_zero; auto.
Qed.
Hint Rewrite <- offset_val_force_ptr : norm.

Lemma offset_offset_val:
  forall v i j, offset_val j (offset_val i v) = offset_val (i + j) v.
Proof. intros; unfold offset_val.
 destruct v; auto.
 f_equal. rewrite Ptrofs.add_assoc. f_equal. apply ptrofs_add_repr.
Qed.
Hint Rewrite offset_offset_val: norm.

Hint Rewrite add_repr add64_repr ptrofs_add_repr : norm.
Hint Rewrite mul_repr mul64_repr ptrofs_mul_repr : norm.
Hint Rewrite sub_repr sub64_repr ptrofs_sub_repr : norm.
Hint Rewrite and_repr and64_repr : norm.
Hint Rewrite or_repr or64_repr : norm.
Hint Rewrite neg_repr neg64_repr : norm.

Lemma ltu_repr: forall i j,
 (0 <= i <= Int.max_unsigned ->
  0 <= j <= Int.max_unsigned ->
  Int.ltu (Int.repr i) (Int.repr j) = true -> i<j)%Z.
Proof.
intros. unfold Int.ltu in H1. if_tac in H1; inv H1.
repeat rewrite Int.unsigned_repr in H2 by assumption.
auto.
Qed.

Lemma ltu_repr_false: forall i j,
 (0 <= i <= Int.max_unsigned ->
  0 <= j <= Int.max_unsigned ->
  Int.ltu (Int.repr i) (Int.repr j) = false -> i>=j)%Z.
Proof.
intros. unfold Int.ltu in H1. if_tac in H1; inv H1.
repeat rewrite Int.unsigned_repr in H2 by assumption.
auto.
Qed.

Lemma int_add_assoc1:
  forall z i j, Int.add (Int.add z (Int.repr i)) (Int.repr j) = Int.add z (Int.repr (i+j)).
Proof.
intros.
rewrite Int.add_assoc. f_equal. apply add_repr.
Qed.
Hint Rewrite int_add_assoc1 : norm.

Lemma ptrofs_add_assoc1:
  forall z i j, Ptrofs.add (Ptrofs.add z (Ptrofs.repr i)) (Ptrofs.repr j) = Ptrofs.add z (Ptrofs.repr (i+j)).
Proof.
intros.
rewrite Ptrofs.add_assoc. f_equal. apply ptrofs_add_repr.
Qed.
Hint Rewrite ptrofs_add_assoc1 : norm.

Lemma divide_add_align: forall a b c, Z.divide b a -> a + (align c b) = align (a + c) b.
Proof.
  intros.
  pose proof zeq b 0.
  destruct H0; unfold Z.divide in H; unfold align.
  + destruct H. subst.
    repeat rewrite Zdiv_0_r.
    simpl.
    lia.
  + destruct H.
    subst.
    replace (x * b + c + b - 1) with (x * b + (c + b - 1)) by lia.
    rewrite Z_div_plus_full_l.
    rewrite Z.mul_add_distr_r.
    reflexivity.
    lia.
Qed.

Lemma force_val_e:
 forall v, force_val (Some v) = v.
Proof. reflexivity. Qed.
Hint Rewrite force_val_e: norm.

Definition ptr_eq (v1 v2: val) : Prop :=
      match v1,v2 with
      | Vint n1, Vint n2 =>  Archi.ptr64 = false /\ Int.cmpu Ceq n1 n2 = true  /\ Int.cmpu Ceq n1 (Int.repr 0) = true
      | Vlong n1, Vlong n2 =>  Archi.ptr64 = true /\ Int64.cmpu Ceq n1 n2 = true  /\ Int64.cmpu Ceq n1 (Int64.repr 0) = true
      | Vptr b1 ofs1,  Vptr b2 ofs2  =>
            b1=b2 /\ Ptrofs.cmpu Ceq ofs1 ofs2 = true
      | _,_ => False
      end.

Definition ptr_neq (v1 v2: val) := ~ ptr_eq v1 v2.

Lemma ptr_eq_e: forall v1 v2, ptr_eq v1 v2 -> v1=v2.
Proof.
intros. destruct v1; destruct v2; simpl in H; try contradiction.
*
pose proof (Int.eq_spec i i0). destruct H as [Hp [? ?]].
rewrite H in H0. subst; auto.
*
pose proof (Int64.eq_spec i i0). destruct H as [Hp [? ?]].
rewrite H in H0. subst; auto.
*
destruct H; subst.
f_equal.
pose proof (Ptrofs.eq_spec i i0). rewrite H0 in H; auto.
Qed.

Lemma ptr_eq_True':
   forall p, isptr p -> ptr_eq p p = True.
Proof. intros.
 apply prop_ext; intuition. destruct p; inv H; simpl; auto.
 rewrite Ptrofs.eq_true. auto.
Qed.
(* Hint Rewrite ptr_eq_True' using solve[auto] : norm. *)

Lemma ptr_eq_True:
   forall p, is_pointer_or_null p -> ptr_eq p p = True.
Proof. intros.
 apply prop_ext; intuition. destruct p; inv H; simpl; auto.
 rewrite Ptrofs.eq_true. auto.
Qed.
Hint Rewrite ptr_eq_True using solve[auto] : norm.

Lemma ptr_eq_is_pointer_or_null: forall x y, ptr_eq x y -> is_pointer_or_null x.
Proof.
  intros.
  unfold ptr_eq, is_pointer_or_null in *.
  destruct x; destruct y; try tauto;
  destruct H as [Hp [_ ?]]; rewrite Hp.
  unfold Int.cmpu in H.
  pose proof (Int.eq_spec i (Int.repr 0)). rewrite H in H0. auto.
  unfold Int64.cmpu in H.
  pose proof (Int64.eq_spec i (Int64.repr 0)). rewrite H in H0. auto.
Qed.

Lemma ptr_eq_sym: forall x y, ptr_eq x y -> ptr_eq y x.
Proof.
   intros.
   pose proof ptr_eq_is_pointer_or_null _ _ H.
   apply ptr_eq_e in H.
   rewrite H in *.
   rewrite ptr_eq_True; tauto.
Qed.

Lemma ptr_eq_trans: forall x y z, ptr_eq x y -> ptr_eq y z -> ptr_eq x z.
Proof.
   intros.
   pose proof ptr_eq_is_pointer_or_null _ _ H.
   apply ptr_eq_e in H.
   apply ptr_eq_e in H0.
   subst.
   rewrite ptr_eq_True; tauto.
Qed.

Lemma isptr_offset_val_zero:
  forall v, isptr v -> offset_val 0 v = v.
Proof. intros. destruct v; inv H; subst; simpl.  rewrite Ptrofs.add_zero; reflexivity.
Qed.

Hint Rewrite isptr_offset_val_zero using solve [auto] : norm.

Lemma isptr_offset_val:
 forall i p, isptr (offset_val i p) = isptr p.
Proof.
intros.
unfold isptr.
destruct p; simpl; auto.
Qed.
Hint Rewrite isptr_offset_val : norm.

Lemma isptr_force_ptr: forall v, isptr v -> force_ptr v = v.
Proof. intros. destruct v; inv H; auto. Qed.
Hint Rewrite isptr_force_ptr using solve [auto] : norm.

Lemma isptr_force_ptr' : forall p, isptr (force_ptr p) =  isptr p.
Proof.
intros. destruct p; reflexivity.
Qed.
Hint Rewrite isptr_force_ptr' : norm.

Ltac no_evars P := (has_evar P; fail 1) || idtac.

Create HintDb computable.
Inductive computable {t:Type} (x:t) : Prop := computable_any.

Ltac putable' x :=
 lazymatch x with
 | O => idtac
 | S ?x => putable x
 | Z.lt ?x ?y => putable x; putable y
 | Z.le ?x ?y => putable x; putable y
 | Z.gt ?x ?y => putable x; putable y
 | Z.ge ?x ?y => putable x; putable y
 | eq?x ?y => putable x; putable y
 | ?x <> ?y => putable x; putable y
 | Zpos ?x => putable x
 | Zneg ?x => putable x
 | Z0 => idtac
 | xH => idtac
 | xI ?x => putable x
 | xO ?x => putable x
 | Z.add ?x ?y => putable x; putable y
 | Z.sub ?x ?y => putable x; putable y
 | Z.mul ?x ?y => putable x; putable y
 | Z.div ?x ?y => putable x; putable y
 | Zmod ?x ?y => putable x; putable y
 | Z.max ?x ?y => putable x; putable y
 | Z.opp ?x => putable x
 | Ceq => idtac
 | Cne => idtac
 | Clt => idtac
 | Cle => idtac
 | Cgt => idtac
 | Cge => idtac
 | ?x /\ ?y => putable x; putable y
 | two_power_nat ?x => putable x
 | Int.eq ?x ?y => putable x; putable y
 | Int64.eq ?x ?y => putable x; putable y
 | Ptrofs.eq ?x ?y => putable x; putable y
 | Int.lt ?x ?y => putable x; putable y
 | Int64.lt ?x ?y => putable x; putable y
 | Ptrofs.lt ?x ?y => putable x; putable y
 | Int.ltu ?x ?y => putable x; putable y
 | Int64.ltu ?x ?y => putable x; putable y
 | Ptrofs.ltu ?x ?y => putable x; putable y
 | Int.add ?x ?y => putable x; putable y
 | Int64.add ?x ?y => putable x; putable y
 | Ptrofs.add ?x ?y => putable x; putable y
 | Int.sub ?x ?y => putable x; putable y
 | Int64.sub ?x ?y => putable x; putable y
 | Ptrofs.sub ?x ?y => putable x; putable y
 | Int.mul ?x ?y => putable x; putable y
 | Int64.mul ?x ?y => putable x; putable y
 | Ptrofs.mul ?x ?y => putable x; putable y
 | Int.neg ?x => putable x
 | Int64.neg ?x => putable x
 | Ptrofs.neg ?x => putable x
 | Int.cmp ?op ?x ?y => putable op; putable x; putable y
 | Int64.cmp ?op ?x ?y => putable op; putable x; putable y
 | Ptrofs.cmp ?op ?x ?y => putable op; putable x; putable y
 | Int.cmpu ?op ?x ?y => putable op; putable x; putable y
 | Int64.cmpu ?op ?x ?y => putable op; putable x; putable y
 | Ptrofs.cmpu ?op ?x ?y => putable op; putable x; putable y
 | Int.repr ?x => putable x
 | Int64.repr ?x => putable x
 | Ptrofs.repr ?x => putable x
 | Int.signed ?x => putable x
 | Int64.signed ?x => putable x
 | Ptrofs.signed ?x => putable x
 | Int.unsigned ?x => putable x
 | Int64.unsigned ?x => putable x
 | Ptrofs.unsigned ?x => putable x
 | two_power_nat ?x => putable x
 | Int.max_unsigned => idtac
 | Int64.max_unsigned => idtac
 | Ptrofs.max_unsigned => idtac
 | Int.min_signed => idtac
 | Int64.min_signed => idtac
 | Ptrofs.min_signed => idtac
 | Int.max_signed => idtac
 | Int64.max_signed => idtac
 | Ptrofs.max_signed => idtac
 | Int.modulus => idtac
 | Int64.modulus => idtac
 | Ptrofs.modulus => idtac
 | Int.zwordsize => idtac
 | Int64.zwordsize => idtac
 | Ptrofs.zwordsize => idtac
 | _ => tryif (let b := eval cbv delta [x] in x in putable b) then idtac else fail
end
with putable x :=
  first [putable' x
         | tryif (try (assert (computable x) by (clear; auto 100 with computable); fail 1)) then fail else idtac ].

Hint Extern 1 (computable ?x) => (putable' x; apply computable_any) : computable.

Ltac computable := match goal with |- ?x =>
 no_evars x;
 putable x;
 compute; clear; repeat split; auto; congruence;
  (match goal with |- context [Archi.ptr64] => idtac end;
    first [change Archi.ptr64 with false | change Archi.ptr64 with true];
    compute; repeat split; auto; congruence)
end.

Lemma sign_ext_range2:
   forall lo n i hi,
      0 < n < Int.zwordsize ->
      lo = - two_p (n-1) ->
      hi = two_p (n-1) - 1 ->
      lo <= Int.signed (Int.sign_ext n i) <= hi.
Proof.
intros.
subst.
pose proof (Int.sign_ext_range n i H).
lia.
Qed.

Lemma zero_ext_range2:
  forall n i lo hi,
      0 <= n < Int.zwordsize ->
      lo = 0 ->
      hi = two_p n - 1 ->
      lo <= Int.unsigned (Int.zero_ext n i) <= hi.
Proof.
intros; subst.
pose proof (Int.zero_ext_range n i H).
lia.
Qed.

Hint Extern 3 (_ <= Int.signed (Int.sign_ext _ _) <= _) =>
    (apply sign_ext_range2; [computable | reflexivity | reflexivity]) : core.

Hint Extern 3 (_ <= Int.unsigned (Int.zero_ext _ _) <= _) =>
    (apply zero_ext_range2; [computable | reflexivity | reflexivity]) : core.

Hint Rewrite sign_ext_inrange using assumption : norm.
Hint Rewrite zero_ext_inrange using assumption : norm.

Definition repable_signed (z: Z) :=
  Int.min_signed <= z <= Int.max_signed.

Definition repable_signed_dec (z: Z) : {repable_signed z}+{~repable_signed z}.
Proof.
 intros. unfold repable_signed.
 destruct (zlt z Int.min_signed).
 right; intros [? _]; unfold Int.min_signed; lia.
 destruct (zlt Int.max_signed z).
 right; intros [_ ?]; unfold Int.max_signed; lia.
 left; split; lia.
Defined.

Lemma repable_signed_mult2:
  forall i j, i<>0 -> (j <= Int.max_signed \/ i <> -1) ->
   repable_signed (i*j) -> repable_signed j.
Proof.
intros until 1. intro HACK. intros.
assert (MAX: 0 < Int.max_signed) by (compute; auto).
assert (MIN: Int.min_signed < 0) by (compute; auto).
hnf in H0|-*.
assert (0 < i \/ i < 0) by lia; clear H.
destruct H1.
replace i with ((i-1)+1) in H0 by lia.
rewrite Z.mul_add_distr_r in H0.
rewrite Z.mul_1_l in H0.
assert (j < 0 \/ 0 <= j) by lia. destruct H1.
assert ((i-1)*j <= 0) by (apply Z.mul_nonneg_nonpos; lia).
lia.
assert (0 <= (i-1)*j) by (apply Z.mul_nonneg_nonneg; lia).
lia.
replace i with ((i+1)-1) in H0 by lia.
rewrite Z.mul_sub_distr_r in H0.
rewrite Z.mul_1_l in H0.
assert (MINMAX: Int.min_signed = -Int.max_signed - 1) by reflexivity.
assert (j < 0 \/ 0 <= j) by lia. destruct H1.
assert (0 <= (i+1)*j) by (apply Z.mul_nonpos_nonpos; lia).
rewrite MINMAX in H0|-*.
lia.
assert ((i+1)*j <= 0) by (apply Z.mul_nonpos_nonneg; lia).
rewrite MINMAX in H0|-*.
split; try lia.
clear MIN MINMAX.
destruct H0 as [? _].
assert (- Int.max_signed <= 1 + (i+1)*j - j) by lia; clear H0.
assert (-1 - (i + 1) * j + j <= Int.max_signed) by lia; clear H3.
destruct HACK; auto.
assert (i < -1) by lia.
destruct (zlt 0 j); try lia.
assert ((i+1)*j < 0).
rewrite Z.mul_add_distr_r.
replace i with ((i+1)-1) by lia.
rewrite Z.mul_sub_distr_r.
assert ((i+1)*j<0); [ | lia].
apply Z.mul_neg_pos; auto. lia.
lia.
Qed.

Lemma repable_signed_mult1:
  forall i j, j<>0 ->  (i <= Int.max_signed \/ j <> -1) ->
              repable_signed (i*j) -> repable_signed i.
Proof.
intros.
 rewrite Zmult_comm in H1.
 apply repable_signed_mult2 in H0; auto.
Qed.

Lemma force_signed_int_e:
  forall i, force_signed_int (Vint i) = Int.signed i.
Proof. reflexivity. Qed.
Hint Rewrite force_signed_int_e : norm.

Ltac const_equation x :=
  let y := eval compute in x
   in exact (x = y).

Ltac Zground X :=
  match X with
  | Z0 => idtac
  | Zpos ?y => Zground y
  | Zneg ?y => Zground y
  | xH => idtac
  | xO ?y => Zground y
  | xI ?y => Zground y
 end.

Ltac natground X :=
  match X with O => idtac | S ?Y => natground Y end.

Ltac compute_Z_of_nat :=
 repeat
  match goal with
  | H: context [Z.of_nat ?n] |- _ =>
          natground n;
          let z := constr:(Z.of_nat n) in let y := eval hnf in z
           in change z with y in *
  | |- context [Z.of_nat ?n] =>
          natground n;
          let z := constr:(Z.of_nat n) in let y := eval hnf in z
           in change z with y in *
   end.

(*
Ltac pose_const_equation X :=
 match goal with
 | H: X = ?Y |- _ => Zground Y
 | _ => let z := eval compute in X in assert (X = z) by reflexivity
 end.
*)

Ltac pose_const_equation X :=
 match goal with
 | H: X = ?Y |- _ => Zground Y
 | _ => let z := eval compute in X in
            match z with context C [Archi.ptr64] =>
                       first [
                           unify Archi.ptr64 false; let u := context C [false] in let u := eval compute in u in change X with u in *
                          |unify Archi.ptr64 true; let u := context C [true] in let u := eval compute in u in change X with u in *
                      ]
              | _ => change X with z in *
            end
 end.

Ltac perhaps_post_const_equation X :=
 lazymatch goal with
 | H: context [X] |- _ => pose_const_equation X
(* | H:= context [X] |- _ => pose_const_equation X *)
 | |- context [X] => pose_const_equation X
 | |- _ => idtac
 end.

Ltac pose_const_equations L :=
 match L with
 | ?X :: ?Y => perhaps_post_const_equation X; pose_const_equations Y
 | nil => idtac
 end.

Import ListNotations.

Ltac pose_standard_const_equations :=
pose_const_equations
  [
  Int.zwordsize; Int.modulus; Int.half_modulus; Int.max_unsigned; Int.max_signed; Int.min_signed;
  Int64.zwordsize; Int64.modulus; Int64.half_modulus; Int64.max_unsigned; Int64.max_signed; Int64.min_signed;
  Ptrofs.zwordsize; Ptrofs.modulus; Ptrofs.half_modulus; Ptrofs.max_unsigned; Ptrofs.max_signed; Ptrofs.min_signed;
  Byte.min_signed; Byte.max_signed; Byte.max_unsigned; Byte.modulus
  ];
 pose_const_equations [Int.wordsize; Int64.wordsize; Ptrofs.wordsize].

Ltac pose_lemma F A L :=
  match type of (L A) with ?T =>
     lazymatch goal with
      | H:  T |- _ => fail
      | H:  T /\ _ |- _ => fail
      | |- _ => pose proof (L A)
     end
  end.

Ltac pose_lemmas F L :=
 repeat
  match goal with
  | |- context [F ?A] => pose_lemma F A L
  | H: context [F ?A] |- _ => pose_lemma F A L
 end.

Ltac warn_rep_omega :=
  idtac "Warning: Hint database 'rep_omega' is deprecated, use Hint Rewrite ... : rep_lia".

Ltac rep_lia_setup :=
 repeat match goal with
            | x := _ : ?T |- _ => lazymatch T with Z => fail | nat => fail | _ => clearbody x end
            end;
 zify;
  try autorewrite with rep_lia in *;
  try (progress autorewrite with rep_lia rep_omega in *;
       warn_rep_omega);
  unfold repable_signed in *;
  pose_Zlength_nonneg;
  pose_lemmas Byte.unsigned Byte.unsigned_range;
  pose_lemmas Byte.signed Byte.signed_range;
  pose_lemmas Int.unsigned Int.unsigned_range;
  pose_lemmas Int.signed Int.signed_range;
  pose_lemmas Int64.unsigned Int64.unsigned_range;
  pose_lemmas Int64.signed Int64.signed_range;
  pose_lemmas Ptrofs.unsigned Ptrofs.unsigned_range;
  pose_standard_const_equations.

Ltac rep_lia_setup2 := idtac.

Ltac rep_lia :=
   rep_lia_setup;
   rep_lia_setup2;
   lia.

Ltac repable_signed :=
  idtac "Warning: repable_signed is deprecated;  use rep_lia"; rep_lia.

Lemma Vubyte_injective i j (H: Vubyte i = Vubyte j): i=j.
Proof.
  assert (B: Byte.zwordsize = 8) by reflexivity.
  assert (I: Int.zwordsize = 32) by reflexivity.
  apply Byte.same_bits_eq; intros a A.
  unfold Vubyte in H. remember (Int.repr (Byte.unsigned i)) as z.
  inv H. destruct i; destruct j. unfold Byte.testbit.
  unfold Byte.unsigned in H1. simpl in *.
  rewrite <- 2 Int.testbit_repr, H1; trivial; lia.
Qed.

Lemma map_Vubyte_injective: forall l m, map Vubyte l = map Vubyte m -> l=m.
Proof. induction l; intros.
+ destruct m; simpl in *; inv H; trivial.
+ destruct m; [ inv H |]. rewrite 2 map_cons in H. apply cons_inv in H.
  destruct H; subst. apply Vubyte_injective in H. f_equal; eauto.
Qed.

Lemma Vbyte_injective a b (H: Vbyte a = Vbyte b): a=b.
Proof. unfold Vbyte in H. apply Vint_injective in H.
  apply Byte.same_bits_eq; intros i I.
  assert (Imin: Int.min_signed = -2147483648) by reflexivity.
  assert (Imax: Int.max_signed = 2147483647) by reflexivity.
  assert (Bmin: Byte.min_signed = -128) by reflexivity.
  assert (Bmax: Byte.max_signed = 127) by reflexivity.
  assert (Byte.signed a = Byte.signed b).
  { rewrite <- (Int.signed_repr (Byte.signed a)).
    rewrite <- (Int.signed_repr (Byte.signed b)).
    rewrite H; trivial. specialize (Byte.signed_range b); lia.
    specialize (Byte.signed_range a); lia. }
  clear H. unfold Byte.testbit. rewrite 2 Byte.unsigned_signed.
  unfold Byte.lt. rewrite H0. trivial.
Qed.

Lemma Znth_map_Vbyte: forall (i : Z) (l : list byte),
  0 <= i < Zlength l -> Znth i (map Vbyte l)  = Vbyte (Znth i l).
Proof.
  intros i l.
  apply Znth_map.
Qed.
Hint Rewrite Znth_map_Vbyte using old_list_solve : norm entailer_rewrite.

Lemma Znth_map_Vubyte: forall (i : Z) (l : list byte),
  0 <= i < Zlength l -> Znth i (map Vubyte l)  = Vubyte (Znth i l).
Proof.
  intros i l.
  apply Znth_map.
Qed.
Hint Rewrite Znth_map_Vubyte using old_list_solve : norm entailer_rewrite.

Lemma repr_inj_signed:
  forall i j,
    repable_signed i -> repable_signed j -> Int.repr i = Int.repr j -> i=j.
Proof.
intros.
rewrite <- (Int.signed_repr i) by rep_lia.
rewrite <- (Int.signed_repr j) by rep_lia.
congruence.
Qed.

Lemma repr_inj_unsigned:
  forall i j,
    0 <= i <= Int.max_unsigned ->
    0 <= j <= Int.max_unsigned ->
    Int.repr i = Int.repr j -> i=j.
Proof.
intros.
rewrite <- (Int.unsigned_repr i) by rep_lia.
rewrite <- (Int.unsigned_repr j) by rep_lia.
congruence.
Qed.

Lemma repr_inj_signed':
  forall i j,
    (* The first two premises are not needed to prove this,
     but are used to limit its applicability *)
    repable_signed i -> repable_signed j ->
    Int.repr i <> Int.repr j -> i<>j.
Proof.
intros.
congruence.
Qed.

Lemma repr_inj_unsigned':
  forall i j,
    0 <= i <= Int.max_unsigned ->
    0 <= j <= Int.max_unsigned ->
    Int.repr i <> Int.repr j -> i<>j.
Proof.
intros.
congruence.
Qed.

Lemma opaque_constant {A: Type} (N: A) : {x: A | x=N}.
Proof. exists N. reflexivity. Qed.

Ltac hint := idtac "Hints are only available when verifying C programs,
that is, when VST.floyd.proofauto has been imported.  But you have
imported only VST.floyd.functional_base, without separation logic.

In VST.floyd.functional_base the following VST tactics are available:
rep_lia, list_solve, if_tac, autorewrite with sublist, computable, ...".

Ltac rep_omega := idtac "Warning: rep_omega is a deprecated synonym for rep_lia"; rep_lia.
Ltac omega := idtac "Warning: use of omega without Require Import Coq.omega.Omega; deprecated; should use lia anyway"; Coq.omega.Omega.omega.


From Undecidability.Shared.Libs.PSL Require Export
FiniteTypes.BasicDefinitions
FiniteTypes.FinTypes
FiniteTypes.BasicFinTypes
FiniteTypes.CompoundFinTypes
FiniteTypes.VectorFin
FiniteTypes.DepPairs.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(*                              monofun.v                                   *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(* the monoid of functions from A to A *)
(***************************************)
Require Import monoid.

Section fun_.
 Variable A : Set.
 Hypothesis eta_A : forall f g : A -> A, (forall x : A, f x = g x) -> f = g.

 Let comp (f g : A -> A) (x : A) := g (f x).
 Let Id (a : A) := a.

 Lemma funmono : monoid (A -> A).
  Proof.
  refine (mkmonoid (A -> A) Id comp _ _ _); auto.
 Defined.
End fun_.


(** * Well-founded relation on [reachable] *)
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Import Fiat.Parsers.BaseTypes.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}.

  Section size.
    Context {ch : Char} {valid : nonterminals_listT}.
    Definition size_of_maybe_empty_item'
               (size_of_maybe_empty_productions : forall {pats}, maybe_empty_productions G valid pats -> nat)
               {it} (p : maybe_empty_item G valid it) : nat
      := match p with
           | MaybeEmptyNonTerminal _ _ p' => S (size_of_maybe_empty_productions p')
         end.

    Fixpoint size_of_maybe_empty_productions {pats} (p : maybe_empty_productions G valid pats) : nat
      := match p with
           | MaybeEmptyHead _ _ p' => S (size_of_maybe_empty_production p')
           | MaybeEmptyTail _ _ p' => S (size_of_maybe_empty_productions p')
         end
    with size_of_maybe_empty_production {pat} (p : maybe_empty_production G valid pat) : nat
         := match p with
              | MaybeEmptyProductionNil => 0
              | MaybeEmptyProductionCons _ _ p0 p1 => S (size_of_maybe_empty_item' (@size_of_maybe_empty_productions) p0 + size_of_maybe_empty_production p1)
            end.

    Definition size_of_maybe_empty_item
               {it} (p : maybe_empty_item G valid it) : nat
      := @size_of_maybe_empty_item' (@size_of_maybe_empty_productions) it p.
  End size.
End rel.


From Coq Require Export NArith Ascii String.
From stdpp Require Import gmap.

Declare Custom Entry arr.

Notation "'input' i j1 .. jn" := (i%string, cons j1 .. (cons jn nil) ..)
  (at level 200, i at level 0, j1 custom arr, jn custom arr).

Notation "p -> q" := (p%string, q%char)
  (in custom arr at level 1, p constr at level 0, q constr at level 0).

Definition Input : Type := string * list (string * ascii).

Definition example : Input := input
"NNCB"

"CH" -> "B"
"HH" -> "N"
"CB" -> "H"
"NH" -> "C"
"HB" -> "C"
"HC" -> "B"
"HN" -> "C"
"NN" -> "C"
"BH" -> "H"
"NC" -> "B"
"NB" -> "B"
"BN" -> "B"
"BB" -> "N"
"BC" -> "B"
"CC" -> "N"
"CN" -> "C"
.

Infix "::" := String : string_scope.

#[global] Open Scope N_scope.

Definition pairmap (xs : list (string * ascii)) : gmap (ascii * ascii) ascii :=
  fold_left (fun m '(x, y) =>
    match x with
    | (x1 :: x2 :: "")%string => insert (x1,x2) y m
    | _ => m
    end) xs empty.

Fixpoint _occs (z : list ascii) : gmap (ascii * ascii) N :=
  match z with
  | nil | _ :: nil => empty
  | c1 :: (c2 :: _) as z =>
    let incr o := match o with
      | None => Some 1%N
      | Some n => Some (N.succ n)
      end in
    partial_alter incr (c1, c2) (_occs z)
  end.

Definition occ (s : string) : (list ascii * gmap (ascii * ascii) N) :=
  let z := list_ascii_of_string s in
  let ends := match z with
              | c1 :: c2 :: z' => c1 :: List.last z' c2 :: nil
              | c1 :: nil => c1 :: nil
              | nil => nil
              end in
  (ends, _occs z).

Definition Pairs : Type := gmap (ascii * ascii) N.

Definition incrmap {A} `{Countable A} (a : A) (n : N) : gmap A N -> gmap A N :=
  partial_alter (fun i => Some
    match i with
    | Some i => i + n
    | None => n
    end) a.

Definition step_pairs (trans : gmap (ascii * ascii) ascii) (pairs : Pairs) : Pairs :=
  let go m '((a, b), n) :=
        match lookup (a, b) trans with
        | None => incrmap (a, b) n m
        | Some c => incrmap (a, c) n (incrmap (c, b) n m)
        end in
  fold_left go (map_to_list pairs) empty.

Definition steps_pairs (n : N) (trans : gmap (ascii * ascii) ascii) : Pairs -> Pairs :=
  N.iter n (step_pairs trans).

Definition count (extra : list ascii) (pairs : Pairs) : gmap ascii N :=
  let extra' := fold_left (fun m c => incrmap c 1 m) extra empty in
  let pairs' :=
    fold_left (fun m '((a, b), n) => incrmap a n (incrmap b n m)) (map_to_list pairs) extra' in
  fmap N.div2 pairs'.

Fixpoint max_by {A} (leb : A -> A -> bool) (a : A) (xs : list A) : A :=
  match xs with
  | nil => a
  | x :: xs => max_by leb (if leb a x then x else a) xs
  end.

Definition min_by {A} (leb : A -> A -> bool) := max_by (fun x y => leb y x).

Definition min_max (z : gmap ascii N) : N * N :=
  let z := map snd (map_to_list z) in
  match z with
  | n0 :: z => (min_by N.leb n0 z, max_by N.leb n0 z)
  | nil => (0, 0)
  end.

Definition run (n : N) '((ini, trans) : Input) :=
  let trans := pairmap trans in
  let '(extra, pairs) := occ ini in
  let pairs := steps_pairs n trans pairs in
  (extra, pairs).

Definition _solve (n : N) (x : Input) : N :=
  let '(extra, pairs) := run n x in
  let cc := count extra pairs in
  let '(mini, maxi) := min_max cc in
  maxi - mini.

Definition solve := _solve 10.
Definition solve2 := _solve 40.
Definition solve12 x := (solve x, solve2 x).

(* Compute solve example. *)


(* begin hide *)
From Coq Require Import
     Classes.Morphisms
     Classes.RelationClasses
     Lists.List
     Relations
     Logic.ProofIrrelevance.
     (* Relations.Operators_Properties. *)

From Heapster Require Import
     Permissions.
(* end hide *)

Section SPred.
  Context (config : Type).
  Context (spred1 spred2 : config -> Prop).
  (* spred1 is a subset of spred2 *)
  Context (Hspred: forall x, spred1 x -> spred2 x).

  Definition lift1 (p : {x | spred2 x} -> Prop) : {x | spred1 x} -> Prop.
    intros []. apply p. econstructor. apply Hspred. apply s.
  Defined.
  Definition lift2 (p : relation {x | spred2 x}) :
    relation {x | spred1 x}.
    intros [] []. apply p.
    - econstructor. apply Hspred. apply s.
    - econstructor. apply Hspred. apply s0.
  Defined.

  (* Context (p : @perm { x | spred1 x }). *)
  (* Context (q : @perm { x | spred2 x }). *)

  Program Definition restrict (p : @perm { x | spred2 x }) : @perm { x | spred1 x } :=
    {|
      rely := lift2 (rely p);
      guar := lift2 (guar p);
      pre := lift1 (pre p);
    |}.
  Next Obligation.
    constructor; repeat intro.
    - destruct x. cbn. reflexivity.
    - destruct x, y, z. cbn. etransitivity; eauto.
  Qed.
  Next Obligation.
    constructor; repeat intro.
    - destruct x. cbn. reflexivity.
    - destruct x, y, z. cbn. etransitivity; eauto.
  Qed.
  Next Obligation.
    cbn. respects.
  Qed.

  (* smaller perm has smaller config type *)
  Definition hlte_perm1 (p : @perm { x | spred1 x }) (q : @perm { x | spred2 x }) : Prop :=
    lte_perm p (restrict q).

  (* smaller perm has bigger config type *)
  Definition hlte_perm2 (p : @perm { x | spred2 x }) (q : @perm { x | spred1 x }) : Prop :=
    lte_perm (restrict p) q.

  Program Definition Restrict (P : @Perms { x | spred2 x }) : @Perms { x | spred1 x } :=
    {|
      in_Perms (p : @perm { x | spred1 x }) :=
      (* p' <= p, but p' has the bigger config type *)
      exists (p' : @perm { x | spred2 x }), hlte_perm2 p' p /\ p' ∈ P;
    |}.
  Next Obligation.
    exists H. split; auto. unfold hlte_perm2 in *. etransitivity; eauto.
  Qed.

  Definition hlte_Perms1 (P : @Perms { x | spred1 x }) (Q : @Perms { x | spred2 x }) : Prop :=
    lte_Perms P (Restrict Q).

  Definition hlte_Perms2 (P : @Perms { x | spred2 x }) (Q : @Perms { x | spred1 x }) : Prop :=
    lte_Perms (Restrict P) Q.

End SPred.

Section SPred2.
  Context (config specConfig : Type).
  Context (spred1 spred1' : config -> Prop).
  Context (spred2 spred2' : specConfig -> Prop).
  (* spred1 is a subset of spred1' *)
  Context (Hspred1: forall x, spred1 x -> spred1' x).
  Context (Hspred2: forall x, spred2 x -> spred2' x).

  Definition lift21 (p : {x | spred1' x} * {x | spred2' x} -> Prop) :
    {x | spred1 x} * {x | spred2 x} -> Prop.
    intros [[] []]. apply p. split.
    - econstructor. apply Hspred1. apply s.
    - econstructor. apply Hspred2. apply s0.
  Defined.
  Definition lift22 (p : relation ({x | spred1' x} * {x | spred2' x})) :
    relation ({x | spred1 x} * {x | spred2 x}).
    intros [[] []] [[] []]. apply p.
    - split.
      + econstructor. apply Hspred1. apply s.
      + econstructor. apply Hspred2. apply s0.
    - split.
      + econstructor. apply Hspred1. apply s1.
      + econstructor. apply Hspred2. apply s2.
  Defined.

  Program Definition restrict2 (p : @perm ({x | spred1' x} * {x | spred2' x})) :
    @perm ({x | spred1 x} * {x | spred2 x}) :=
    {|
      rely := lift22 (rely p);
      guar := lift22 (guar p);
      pre := lift21 (pre p);
    |}.
  Next Obligation.
    constructor; repeat intro.
    - destruct x as [[] []]. cbn. reflexivity.
    - destruct x as [[] []], y as [[] []], z as [[] []]. cbn. etransitivity; eauto.
  Qed.
  Next Obligation.
    constructor; repeat intro.
    - destruct x as [[] []]. cbn. reflexivity.
    - destruct x as [[] []], y as [[] []], z as [[] []]. cbn. etransitivity; eauto.
  Qed.
  Next Obligation.
    cbn. respects.
  Qed.

End SPred2.

Lemma restrict_same config (spred : config -> Prop) p
      (H : forall x, spred x -> spred x) :
  restrict _ _ _ H p ≡≡ p.
Proof.
  split.
  {
    unfold restrict. constructor; cbn; auto.
    - unfold lift1. intros [] ?. rewrite (proof_irrelevance _ (H x s) s); auto.
    - unfold lift2. intros [] [] ?.
      rewrite (proof_irrelevance _ (H x s) s); auto.
      rewrite (proof_irrelevance _ (H x0 s0) s0); auto.
    - unfold lift2. intros [] [] ?.
      rewrite (proof_irrelevance _ s (H x s)); auto.
      rewrite (proof_irrelevance _ s0 (H x0 s0)); auto.
  }
  {
    unfold restrict. constructor; cbn; auto.
    - unfold lift1. intros [] ?. rewrite (proof_irrelevance _ s (H x s)); auto.
    - unfold lift2. intros [] [] ?.
      rewrite (proof_irrelevance _ s (H x s)); auto.
      rewrite (proof_irrelevance _ s0 (H x0 s0)); auto.
    - unfold lift2. intros [] [] ?.
      rewrite (proof_irrelevance _ (H x s) s); auto.
      rewrite (proof_irrelevance _ (H x0 s0) s0); auto.
  }
Qed.

Lemma restrict_restrict config (spred1 spred2 spred3 : config -> Prop) p
      (H12 : forall x, spred1 x -> spred2 x)
      (H23 : forall x, spred2 x -> spred3 x) :
  restrict _ _ _ (fun (x : config) (H : spred1 x) => H23 x (H12 x H)) p ≡≡
  restrict _ _ _ H12 (restrict _ _ _ H23 p).
Proof.
  split.
  {
    intros. constructor.
    - intros [] ?. apply H; auto.
    - intros [] [] ?. apply H; auto.
    - intros [] [] ?. apply H; auto.
  }
  {
    intros. constructor.
    - intros [] ?. apply H; auto.
    - intros [] [] ?. apply H; auto.
    - intros [] [] ?. apply H; auto.
  }
Qed.

(*
Lemma restrict_restrict config (spred1 spred2 spred3 : config -> Prop) p q
      (H12 : forall x, spred1 x -> spred2 x)
      (H23 : forall x, spred2 x -> spred3 x) :
  restrict _ _ _ (fun (x : config) (H : spred1 x) => H23 x (H12 x H)) p <= q ->
  restrict _ _ _ H12 (restrict _ _ _ H23 p) <= q.
Proof.
  intros. constructor.
  - intros [] ?. apply H; auto.
  - intros [] [] ?. apply H; auto.
  - intros [] [] ?. apply H; auto.
Qed.
Lemma restrict_restrict' config (spred1 spred2 spred3 : config -> Prop) p q
      (H12 : forall x, spred1 x -> spred2 x)
      (H23 : forall x, spred2 x -> spred3 x) :
  restrict _ _ _ H12 (restrict _ _ _ H23 p) <= q ->
  restrict _ _ _ (fun (x : config) (H : spred1 x) => H23 x (H12 x H)) p <= q.
Proof.
  intros. constructor.
  - intros [] ?. apply H; auto.
  - intros [] [] ?. apply H; auto.
  - intros [] [] ?. apply H; auto.
Qed.
*)

Lemma lte_perm_restrict config (spred1 spred2 : config -> Prop) (p1 p2 : perm)
  (Hspred : forall x, spred1 x -> spred2 x) :
  p1 <= p2 ->
  restrict _ _ _ Hspred p1 <= restrict _ _ _ Hspred p2.
Proof.
  intros. constructor; intros.
  - destruct x. apply H; auto.
  - destruct x, y. apply H; auto.
  - destruct x, y. apply H; auto.
Qed.

Lemma hlte_perm1_reflexive config (spred : config -> Prop) p H :
  hlte_perm1 config spred spred H p p.
Proof.
  unfold hlte_perm1. rewrite restrict_same. reflexivity.
Qed.

Lemma hlte_perm1_transitive config (spred1 spred2 spred3 : config -> Prop) (p1 p2 p3 : perm)
      (H12 : forall x, spred1 x -> spred2 x)
      (H23 : forall x, spred2 x -> spred3 x) :
  hlte_perm1 _ _ _ H12 p1 p2 ->
  hlte_perm1 _ _ _ H23 p2 p3 ->
  hlte_perm1 _ _ _ ((fun (x : config) (H : spred1 x) => H23 x (H12 x H))) p1 p3.
Proof.
  intros. unfold hlte_perm1 in *. etransitivity; eauto.
  clear H. constructor.
  - destruct H0 as [? _ _].
    intros [] ?. cbn in *. apply pre_inc. cbn. apply H.
  - destruct H0 as [_ ? _].
    intros [] [] ?. cbn in *. apply rely_inc. cbn. apply H.
  - destruct H0 as [_ _ ?].
    intros [] [] ?. cbn in *.
    specialize (guar_inc _ _ H). (* same as before but slightly cumbersome *)
    apply guar_inc.
Qed.

Lemma hlte_perm2_reflexive config (spred : config -> Prop) H p :
  hlte_perm2 config spred spred H p p.
Proof.
  unfold hlte_perm2. rewrite restrict_same. reflexivity.
Qed.

Lemma hlte_perm2_transitive config (spred1 spred2 spred3 : config -> Prop) (p1 p2 p3 : perm)
      (H12 : forall x, spred2 x -> spred1 x)
      (H23 : forall x, spred3 x -> spred2 x) :
  hlte_perm2 _ _ _ H12 p1 p2 ->
  hlte_perm2 _ _ _ H23 p2 p3 ->
  hlte_perm2 _ _ _ ((fun (x : config) (H : spred3 x) => H12 x (H23 x H))) p1 p3.
Proof.
  intros. unfold hlte_perm2 in *. etransitivity; eauto.
  clear H0. constructor.
  - destruct H as [? _ _].
    intros [] ?. cbn in *.
    specialize (pre_inc _ H). cbn in pre_inc.
    apply pre_inc.
  - destruct H as [_ ? _].
    intros [] [] ?. cbn in *.
    specialize (rely_inc _ _ H).
    apply rely_inc.
  - destruct H as [_ _ ?].
    intros [] [] ?. cbn in *.
    apply guar_inc. apply H.
Qed.

Lemma separate_restrict config (spred1 spred2 : config -> Prop) (p1 p2 : perm)
      (Hspred : forall x, spred1 x -> spred2 x) :
  p1 ⊥ p2 ->
  (restrict _ _ _ Hspred p1) ⊥ (restrict _ _ _ Hspred p2).
Proof.
  intros. constructor.
  - intros [] [] ?. apply H; auto.
  - intros [] [] ?. apply H; auto.
Qed.

(* only makes sense when the smaller permission also has a smaller spred (actually no) *)
Lemma h_sep_antimonotone config (spred1 spred2 : config -> Prop) (p1 p2 p2' : perm)
      (Hspred : forall x, spred1 x -> spred2 x) :
  p1 ⊥ p2 ->
  hlte_perm1 _ _ _ Hspred p2' p2 ->
  (restrict _ _ _ Hspred p1) ⊥ p2'.
Proof.
  intros.
  eapply separate_antimonotone; eauto.
  apply separate_restrict; auto.
Qed.

Lemma restrict_sep_conj config (spred1 spred2 : config -> Prop) Hspred p1 p2 :
  restrict config spred1 spred2 Hspred p1 ** restrict config spred1 spred2 Hspred p2 <=
  restrict config spred1 spred2 Hspred (p1 ** p2).
Proof.
  constructor.
  - intros [] (? & ? & ?). split; [| split]; auto. apply separate_restrict; auto.
  - intros [] [] ?. auto.
  - intros [] [] ?. induction H.
    + destruct x1, y. destruct H; constructor; auto.
    + destruct x1, y, z. cbn in *. econstructor 2; eauto.
Qed.

(* the converse is not true *)
Lemma restrict_sep_conj' config (spred1 spred2 : config -> Prop) Hspred p1 p2 :
  restrict config spred1 spred2 Hspred (p1 ** p2) <=
  restrict config spred1 spred2 Hspred p1 ** restrict config spred1 spred2 Hspred p2.
Proof.
  constructor.
  - intros [] (? & ? & ?). split; [| split]; auto.
Abort.

Lemma lte_Perms_Restrict config (spred1 spred2 : config -> Prop) (P1 P2 : Perms)
  (Hspred : forall x, spred1 x -> spred2 x) :
  P1 ⊑ P2 ->
  Restrict _ _ _ Hspred P1 ⊑ Restrict _ _ _ Hspred P2.
Proof.
  repeat intro. destruct H0 as (p2 & Hhlte & Hp2).
  exists p2. split; auto.
Qed.

Lemma in_Perms_Restrict config (spred1 spred2 : config -> Prop) p P
  (Hspred : forall x, spred1 x -> spred2 x) :
  p ∈ P ->
  restrict _ _ _ Hspred p ∈ Restrict _ _ _ Hspred P.
Proof.
  repeat intro. exists p. split; auto. unfold hlte_perm2. reflexivity.
Qed.

Lemma hlte_Perms1_transitive config (spred1 spred2 spred3 : config -> Prop) (P1 P2 P3 : Perms)
      (H12 : forall x, spred1 x -> spred2 x)
      (H23 : forall x, spred2 x -> spred3 x) :
  hlte_Perms1 _ _ _ H12 P1 P2 ->
  hlte_Perms1 _ _ _ H23 P2 P3 ->
  hlte_Perms1 _ _ _ ((fun (x : config) (H : spred1 x) => H23 x (H12 x H))) P1 P3.
Proof.
  intros. unfold hlte_Perms1 in *. etransitivity; eauto.
  clear H. intros p Hp. destruct Hp as (p3 & Hhlte & Hp3).
  exists (restrict _ _ _ H23 p3). split.
  2: { apply H0. apply in_Perms_Restrict; auto. }
  unfold hlte_perm2 in *. rewrite <- restrict_restrict. apply Hhlte.
Qed.

Lemma hlte_Perms2_transitive config (spred1 spred2 spred3 : config -> Prop) (P1 P2 P3 : Perms)
      (H12 : forall x, spred2 x -> spred1 x)
      (H23 : forall x, spred3 x -> spred2 x) :
  hlte_Perms2 _ _ _ H12 P1 P2 ->
  hlte_Perms2 _ _ _ H23 P2 P3 ->
  hlte_Perms2 _ _ _ ((fun (x : config) (H : spred3 x) => H12 x (H23 x H))) P1 P3.
Proof.
  intros. unfold hlte_Perms2 in *. etransitivity; eauto.
  intros p Hp. destruct Hp as (p2 & Hhlte & Hp2).
  apply H in Hp2. destruct Hp2 as (p1 & Hhlte' & Hp1).
  cbn. exists p1. split; auto.
  unfold hlte_perm2 in *. etransitivity; eauto. rewrite restrict_restrict.
  apply lte_perm_restrict. auto.
Qed.