(** Testing functional CWP and compilation+inference on example *)
(*     programs.  *)

Set Implicit Arguments.
Require Import Coq.Program.Basics.
Require Import Coq.QArith.QArith.
Require Import Coq.micromega.Lqa.
Require Import FunctionalExtensionality.
Local Open Scope program_scope.

Require Import List.
Import ListNotations.

Require Import compile.
Require Import cpGCL.
Require Import cwp.
Require Import cwp_cwpf.
Require Import geometric.
Require Import infer.
(* Require Import measure. *)
Require Import misc.
Require Import order.
Require Import Q.
Require Import tree.
Require Import itree.
Local Open Scope Q_scope.

(** Testing compilation and inference on example programs *)

Definition sample (x : nat) (p : Q) : cpGCL :=
  CChoice p (CAssign x (const true)) (CAssign x (const false)).

Definition goldfish_piranha : cpGCL :=
  sample 0%nat (1#2) ;;;
  CAssign 1%nat (const true) ;;;
  CChoice (1#2) (CAssign 2%nat (fun st => st 0%nat))
                (CAssign 2%nat (fun st => st 1%nat)) ;;;
  CObserve (fun st => eqb (st 2%nat) true).

(* Definition goldfish_piranha_tree : tree St := *)
(*   evalCompile' goldfish_piranha empty. *)

(* Definition gp_tree := reduce_tree (fmap (fun st => st O) goldfish_piranha_tree). *)
(* Definition gp_itree := remove_taus (unbiased_tree_to_itree' gp_tree). *)
(* Definition gp_seq := measure_seq gp_itree id. *)
(* Definition gp_chain := partial_sum gp_seq. *)

(* Definition bits := map (fun b => if b : bool then 1 else 0) ∘ bit_sequences. *)
(* Definition ind := preimageb' gp_itree id ∘ bit_sequences. *)
(* Definition bits_ind := tuple bits ind. *)

(* Eval compute in gp_tree. *)
(* (* Choice (1 # 2) (Leaf true) (Choice (1 # 2) (Fail bool 0) (Leaf false)) *) *)

(* Eval compute in (prefix' gp_itree 10). *)
(* Eval compute in (exists_tau gp_itree 3). *)
(* Eval compute in (walk_path gp_itree [true; false; false] 10). *)

(* Eval compute in (first_n bits_ind 40). *)

(* Eval compute in (filter (fun p => snd p) (first_n bits_ind 40)). *)

(* (* Eval compute in (map (preimageb' gp_itree id) (first_n bit_sequences 10)). *) *)

(* (* Eval compute in (map Qred (first_n (partial_sum fair_coin_chain) 50)). *) *)

(* (* Eval compute in (first_n gp_chain 100). *) *)
(* (* Eval compute in (gp_chain 5000). *) *)

(* Definition ex1_f := fun st => if st O : bool then 1 else 0. *)
(* Example ex1 : infer ex1_f goldfish_piranha_tree == 2#3. *)
(* Proof. reflexivity. Qed. *)
(* Example ex2 : infer ex1_f goldfish_piranha_tree == *)
(*               cwpf goldfish_piranha ex1_f empty. *)
(* Proof. reflexivity. Qed. *)

(* Definition test_abort : cpGCL := *)
(*   CChoice (1#3) (CAssign 0%nat (const true)) CAbort. *)

(* Definition test_abort_tree : tree St := evalCompile' test_abort empty. *)

(* (* Eval compute in (evalCompile' test_abort empty). *) *)

(* Definition ex3_f := fun st => if st O : bool then 1 else 0. *)
(* Example ex3 : infer ex3_f test_abort_tree == 1#3. *)
(* Proof. reflexivity. Qed. *)
(* Example ex4 : infer ex3_f test_abort_tree == cwpf test_abort ex3_f empty. *)
(* Proof. reflexivity. Qed. *)

(* Definition ex5_f := fun st => if st O : bool then 1 else 0. *)
(* Example ex5 : infer ex5_f test_abort_tree == 1#3. *)
(* Proof. reflexivity. Qed. *)
(* Example ex6 : infer ex5_f test_abort_tree == cwpf test_abort ex5_f empty. *)
(* Proof. reflexivity. Qed. *)

(* Definition ex7_f := fun st => if negb (st O) then 1 else 0. *)
(* Example ex7 : infer ex7_f test_abort_tree == 0. *)
(* Proof. reflexivity. Qed. *)
(* Example ex8 : infer ex7_f test_abort_tree == cwpf test_abort ex7_f empty. *)
(* Proof. reflexivity. Qed. *)

(* Example ex9 : infer (const 1) test_abort_tree == 1#3. *)
(* Proof. reflexivity. Qed. *)
(* Example ex10 : infer (const 1) test_abort_tree == *)
(*                cwpf test_abort (const 1) empty. *)
(* Proof. reflexivity. Qed. *)

(* (** infer_f (const 1) yields the probability of terminating. *) *)
(* Example ex11 : infer_f (const 1) test_abort_tree == 1#3. *)
(* Proof. reflexivity. Qed. *)
(* (** infer_f_lib (const 1) always yields 1. *) *)
(* Example ex12 : infer_f_lib (const 1) test_abort_tree == 1. *)
(* Proof. reflexivity. Qed. *)

(* Definition ex13_f := fun st => if st O : bool then 1 else 0. *)
(* Example ex13 : infer ex13_f test_abort_tree == 1#3. *)
(* Proof. reflexivity. Qed. *)
(* Example ex14 : infer ex13_f test_abort_tree == *)
(*                cwpf test_abort ex13_f empty. *)
(* Proof. reflexivity. Qed. *)

(* Definition ex15_c := CChoice (1#2) CSkip CAbort. *)
(* Example ex15 : infer (const 1) (evalCompile' ex15_c empty) == 1#2. *)
(* Proof. reflexivity. Qed. *)
(* Example ex16 : infer (const 1) (evalCompile' ex15_c empty) == *)
(*                cwpf ex15_c (const 1) empty. *)
(* Proof. reflexivity. Qed. *)

(* Definition fair_coin : cpGCL := *)
(*   CAssign 0 (const false) ;;; *)
(*   CAssign 1 (const false) ;;; *)
(*   CWhile (fun st => eqb (st 0%nat) (st 1%nat)) *)
(*          (sample 0%nat (1#3) ;;; sample 1%nat (1#3)). *)

(* Definition fair_coin_tree : tree St := evalCompile' fair_coin empty. *)

(* Definition ex17_f := fun st => if st O : bool then 1 else 0. *)
(* Example ex17 : infer ex17_f fair_coin_tree == 1#2. *)
(* Proof. reflexivity. Qed. *)
(* Example ex18 : infer ex17_f fair_coin_tree == cwpf fair_coin ex17_f empty. *)
(* Proof. reflexivity. Qed. *)

(* (* Definition fair_coin_itree := unbiased_tree_to_itree' fair_coin_tree. *) *)
(* (* Definition fair_coin_chain := measure_chain fair_coin_itree (fun st => st O). *) *)

(* (* Definition bits := map (fun b => if b : bool then 1 else 0) ∘ bit_sequences. *) *)
(* (* Definition ind := preimageb' fair_coin_itree (fun st => st O) ∘ bit_sequences. *) *)
(* (* Definition bits_ind := tuple bits ind. *) *)

(* (* Eval compute in (first_n bits_ind 1000). *) *)

(* (* Eval compute in (map (preimageb' fair_coin_itree (fun st => st O)) *) *)
(* (*                      (first_n bit_sequences 10)). *) *)

(* (* (* Eval compute in (map Qred (first_n (partial_sum fair_coin_chain) 50)). *) *) *)
(* (* Eval compute in (partial_sum fair_coin_chain 100). *) *)

(* Definition two_thirds_loop (x : nat) (z : nat) : cpGCL := *)
(*   CAssign z (const true) ;;; *)
(*     CWhile (fun st => st z) *)
(*            (CChoice (1#2) *)
(*                     (CAssign x (const true) ;;; *)
(*                      CAssign z (const false)) *)
(*                     (CChoice (1#2) *)
(*                              CSkip *)
(*                              (CAssign x (const false) ;;; *)
(*                               CAssign z (const false)))). *)

(* Definition fair_coin_loop : cpGCL := *)
(*   CAssign 0 (const false) ;;; *)
(*   CAssign 1 (const false) ;;; *)
(*   CWhile (fun st => eqb (st 0%nat) (st 1%nat)) *)
(*          (two_thirds_loop 0%nat 2%nat ;;; *)
(*           two_thirds_loop 1%nat 2%nat). *)

(* Definition fair_coin_loop_tree : tree St := evalCompile' fair_coin_loop empty. *)

(* Definition ex19_f := fun st => if st O : bool then 1 else 0. *)
(* Example ex19 : infer ex19_f fair_coin_loop_tree == 1#2. *)
(* Proof. reflexivity. Qed. *)
(* Example ex20 : infer ex19_f fair_coin_loop_tree == *)
(*                cwpf fair_coin_loop ex19_f empty. *)
(* Proof. reflexivity. Qed. *)

(* (* Eval compute in fair_coin_loop_tree. *) *)

(* (* Lemma goldfish_piranha_cwp (f : St -> Q) : *) *)
(* (*   cwp goldfish_piranha (fun st => if st O then 1 else 0) f -> f ==f const (2#3). *) *)
(* (* Proof. *) *)
(* (*   intros (f' & g' & [Hwp Hwlp] & Hf) x. *) *)
(* (*   repeat wp_inversion; repeat wlp_inversion; reflexivity. *) *)
(* (* Qed. *) *)

(* (* Ltac rewrite_equiv := *) *)
(* (*   match goal with *) *)
(* (*   | [ H : forall _ : St, _ == _ |- _ ] => rewrite H; simpl *) *)
(* (*   end. *) *)

(* (** Proving iid-ness of loops and using cwpf to help automate cwp *)
(*   reasoning. *) *)

(* Lemma simple_loop_iid : *)
(*   iid_wpf (const true) (CAssign O (const true)). *)
(* Proof. *)
(*   intros f x i. simpl. *)
(*   unfold compose, const, indicator. rewrite Qmult_1_l, Qplus_0_r. *)
(*   revert x. *)
(*   induction i; intro x. simpl. unfold const. reflexivity. *)
(*   simpl in *; unfold compose; rewrite IHi; reflexivity. *)
(* Qed. *)

(* (** Some properties of upd (requiring funext) *) *)

(* Lemma upd_shadow n x y st : *)
(*   upd n x (upd n y st) = upd n x st. *)
(* Proof. *)
(*   apply functional_extensionality. *)
(*   intro i; unfold upd; simpl. *)
(*   destruct (Nat.eqb_spec i n); subst; reflexivity. *)
(* Qed. *)

(* Lemma upd_eq n st : *)
(*   upd n (st n) st = st. *)
(* Proof. *)
(*   apply functional_extensionality. *)
(*   intro i; unfold upd; destruct (Nat.eqb_spec i n); subst; auto. *)
(* Qed. *)

(* Lemma upd_comm n m x y st : *)
(*   n <> m -> *)
(*   upd n x (upd m y st) = upd m y (upd n x st). *)
(* Proof. *)
(*   intro Hneq. *)
(*   unfold upd. *)
(*   apply functional_extensionality; intro i. *)
(*   destruct (Nat.eqb_spec i n); subst. *)
(*   - destruct (Nat.eqb_spec n m); subst; congruence. *)
(*   - destruct (Nat.eqb_spec i m); subst; congruence. *)
(* Qed. *)

(* Lemma simple_loop2_iid : *)
(*   iid_wpf (fun st => st O) (CChoice (1#2) (CAssign O (const true)) (CAssign O (const false))). *)
(* Proof. *)
(*   intros f x i. simpl. unfold compose, const, indicator. simpl. *)
(*   intro Hx. rewrite Hx. *)
(*   field_simplify_eq. *)
(*   cut (wpf *)
(*          (unroll (fun st : St => st O) *)
(*                  (CChoice (1 # 2) (CAssign 0 (fun _ : St => true)) *)
(*                           (CAssign 0 (fun _ : St => false))) i) f *)
(*          (upd 0 true x) == *)
(*        wpf *)
(*          (unroll (fun st : St => st O) *)
(*                  (CChoice (1 # 2) (CAssign 0 (fun _ : St => true)) *)
(*                           (CAssign 0 (fun _ : St => false))) i) f x). *)
(*   { intros H. rewrite H. clear H. *)
(*     cut (wpf *)
(*            (unroll (fun st : St => st O) *)
(*                    (CChoice (1 # 2) (CAssign 0 (fun _ : St => true)) *)
(*                             (CAssign 0 (fun _ : St => false))) i) f *)
(*            (upd 0 false x) == *)
(*          f (upd 0 false x)). *)
(*     { lra. } *)
(*     destruct i; reflexivity. } *)
(*   revert Hx. revert x. *)
(*   induction i; intros x Hx; simpl. *)
(*   + rewrite Hx. reflexivity. *)
(*   + rewrite Hx. unfold compose. simpl. *)
(*     field_simplify_eq. *)
(*     rewrite IHi; auto. *)
(*     rewrite IHi; auto. *)
(*     rewrite upd_shadow. reflexivity. *)
(* Qed. *)

(* Lemma wpf_unroll_false e c i f st : *)
(*   e st = false -> *)
(*   wpf (unroll e c i) f st == f st. *)
(* Proof. intro He; destruct i; simpl; rewrite He; reflexivity. Qed. *)

(* Lemma wlpf_unroll_false e c i f st : *)
(*   e st = false -> *)
(*   wlpf (unroll e c i) f st == f st. *)
(* Proof. intro He; destruct i; simpl; rewrite He; reflexivity. Qed. *)

(* Lemma upd_1_0_shadow st x y z w : *)
(*   upd 1 x (upd 0 y (upd 1 z (upd 0 w st))) = *)
(*   upd 1 x (upd 0 y st). *)
(* Proof. repeat (rewrite upd_comm; auto; rewrite upd_shadow). Qed. *)

(* Lemma iid_wpf_fair_coin : *)
(*   iid_wpf (fun st : St => eqb (st O) (st (S O))) (sample 0 (1 # 3);;; sample 1 (1 # 3)). *)
(* Proof. *)
(*   intros f x i. simpl. *)
(*   unfold compose, const, indicator; simpl. *)
(*   intro Hx. rewrite Hx. *)
(*   field_simplify_eq. *)
(*   rewrite wpf_unroll_false with (st := upd 1 false (upd 0 true x)); auto. *)
(*   rewrite wpf_unroll_false with (st := upd 1 true (upd 0 false x)); auto. *)
(*   cut (wpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                    (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f *)
(*            (upd 1 true (upd 0 true x)) == *)
(*        wpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                    (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f x). *)
(*   { intro H; rewrite H; clear H. *)
(*     cut (wpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                      (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f *)
(*              (upd 1 false (upd 0 false x)) == *)
(*          wpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                      (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f x). *)
(*     { lra. } *)
(*     revert x Hx. *)
(*     induction i; intros x Hx; simpl. *)
(*     - rewrite Hx; reflexivity. *)
(*     - rewrite Hx. unfold compose, const. *)
(*       field_simplify_eq. *)
(*       rewrite !IHi; auto. *)
(*       rewrite !upd_1_0_shadow; lra. } *)
(*   revert x Hx. *)
(*   induction i; intros x Hx; simpl. *)
(*   - rewrite Hx; reflexivity. *)
(*   - rewrite Hx. unfold compose, const. *)
(*     field_simplify_eq. *)
(*     rewrite !IHi; auto. *)
(*     rewrite !upd_1_0_shadow; lra. *)
(* Qed. *)

(* Lemma iid_wlpf_fair_coin : *)
(*   iid_wlpf (fun st : St => eqb (st O) (st (S O))) (sample 0 (1 # 3);;; sample 1 (1 # 3)). *)
(* Proof. *)
(*   intros f x i. simpl. *)
(*   unfold compose, const, indicator; simpl. *)
(*   intro Hx. rewrite Hx. *)
(*   field_simplify_eq. *)
(*   rewrite wlpf_unroll_false with (st := upd 1 false (upd 0 true x)); auto. *)
(*   rewrite wlpf_unroll_false with (st := upd 1 true (upd 0 false x)); auto. *)
(*   cut (wlpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                     (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f *)
(*             (upd 1 true (upd 0 true x)) == *)
(*        wlpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                     (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f x). *)
(*   { intro H; rewrite H; clear H. *)
(*     cut (wlpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                       (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f *)
(*               (upd 1 false (upd 0 false x)) == *)
(*          wlpf (unroll (fun st : St => Bool.eqb (st O) (st (S O))) *)
(*                       (sample 0 (1 # 3);;; sample 1 (1 # 3)) i) f x). *)
(*     { lra. } *)
(*     revert x Hx. *)
(*     induction i; intros x Hx; simpl. *)
(*     - rewrite Hx; reflexivity. *)
(*     - rewrite Hx. unfold compose, const. *)
(*       field_simplify_eq. *)
(*       rewrite !IHi; auto. *)
(*       rewrite !upd_1_0_shadow; lra. } *)
(*   revert x Hx. *)
(*   induction i; intros x Hx; simpl. *)
(*   - rewrite Hx; reflexivity. *)
(*   - rewrite Hx. unfold compose, const. *)
(*     field_simplify_eq. *)
(*     rewrite !IHi; auto. *)
(*     rewrite !upd_1_0_shadow; lra. *)
(* Qed. *)

(* Lemma wf_fair_coin : wf_cpGCL fair_coin. *)
(* Proof. repeat constructor; lra. Qed. *)

(* Lemma iid_fair_coin : iid_cpGCL fair_coin. *)
(* Proof. *)
(*   repeat constructor. *)
(*   - apply iid_wpf_fair_coin. *)
(*   - apply iid_wlpf_fair_coin. *)
(* Qed. *)

(* Lemma fair_coin_cwp (f : St -> Q) : *)
(*   cwp fair_coin (fun st => if st O then 1 else 0) f -> f ==f const (1#2). *)
(* Proof. *)
(*   intros Hcwp x. *)
(*   transitivity (cwpf fair_coin (fun st => if st O then 1 else 0) x). *)
(*   - eapply cwp_deterministic; eauto. *)
(*     apply cwp_cwpf; auto. *)
(*     + apply wf_fair_coin. *)
(*     + apply iid_fair_coin. *)
(*     + intro y; destruct (y O); lra. *)
(*   - compute. (* :O *) *)
(*     reflexivity. *)
(* Qed. *)

(* Lemma fair_coin_cwp' (f : St -> Q) : *)
(*   expectation f -> *)
(*   cwp fair_coin f (cwpf fair_coin f). *)
(* Proof. *)
(*   intro Hexp; apply cwp_cwpf; auto. *)
(*   - apply wf_fair_coin. *)
(*   - apply iid_fair_coin. *)
(* Qed. *)

(* Lemma fair_coin_cwp'' : *)
(*   cwp fair_coin (fun st => if st O then 1 else 0) *)
(*       (cwpf fair_coin (fun st => if st O then 1 else 0)). *)
(* Proof. *)
(*   apply fair_coin_cwp'. *)
(*   intro x; destruct (x O); lra. *)
(* Qed. *)

(* Eval compute in Qred ∘ cwpf fair_coin (fun st => if st O then 1 else 0). *)

(* Definition fair_coin_noinit : cpGCL := *)
(*   CWhile (fun st => eqb (st 0%nat) (st 1%nat)) *)
(*          (sample 0%nat (1#3) ;;; sample 1%nat (1#3)). *)

(* Lemma fair_coin_noinit_cwp' (f : St -> Q) : *)
(*   expectation f -> *)
(*   cwp fair_coin_noinit f (cwpf fair_coin_noinit f). *)
(* Proof. *)
(*   intro Hexp; apply cwp_cwpf; auto. *)
(*   - repeat constructor; lra. *)
(*   - repeat constructor. *)
(*     + apply iid_wpf_fair_coin. *)
(*     + apply iid_wlpf_fair_coin. *)
(* Qed. *)

(* Lemma fair_coin_noinit_cwp'' : *)
(*   cwp fair_coin_noinit (fun st => if st O then 1 else 0) *)
(*       (cwpf fair_coin_noinit (fun st => if st O then 1 else 0)). *)
(* Proof. *)
(*   apply fair_coin_noinit_cwp'. *)
(*   intro x; destruct (x O); lra. *)
(* Qed. *)

(* Eval compute in Qred (cwpf fair_coin_noinit (fun st => if st O then 1 else 0) *)
(*                            (upd O true (upd (S O) true empty))). *)


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Bedrock.Word
        Coq.omega.Omega
        Coq.Strings.Ascii
        Coq.Numbers.BinNums
        Coq.NArith.BinNat.

Section Ascii.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Definition format_ascii (c : ascii) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    format_word (NToWord 8 (N_of_ascii c)) ce.

  Definition encode_ascii (c : ascii) (ce : CacheFormat)
    : B * CacheFormat :=
    encode_word (NToWord 8 (N_of_ascii c)) ce.

  Definition decode_ascii (b : B) (cd : CacheDecode) : option (ascii * B * CacheDecode) :=
    `(n, b, cd) <- decode_word (sz:=8) b cd;
      Some (ascii_of_N (wordToN n), b, cd).

  Open Local Scope nat.
  Theorem Ascii_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : forall b cd, P cd -> P (addD cd b))
    :
      CorrectDecoder monoid (fun n => True)
                              (fun _ _ => True)
                              format_ascii decode_ascii P.
  Proof.
    unfold decode_ascii; split.
    {
      intros env env' xenv c c' ext env_OK Eeq Ppred Ppred_rest Penc.
      destruct (proj1 (Word_decode_correct (sz := 8) P_OK) _ _ _ _ _ ext env_OK Eeq I I Penc) as [? [? [? xenv_OK] ] ].
      rewrite H; simpl.
      eexists; intuition eauto.
      repeat f_equal.
      rewrite wordToN_nat. rewrite NToWord_nat.
      destruct (wordToNat_natToWord' 8 (BinNat.N.to_nat (N_of_ascii c))).
      assert (x0 = 0).
      { destruct x0; eauto; exfalso.
        remember (wordToNat (natToWord 8 (BinNat.N.to_nat (N_of_ascii c)))) as xx; clear Heqxx.
        replace (xx + S x0 * pow2 8) with (256 + (xx + x0 * 256)) in H1.
        assert (BinNat.N.to_nat (N_of_ascii c) < 256).
        assert (N.lt (N_of_ascii c) 256).
        clear H. induction c; repeat (match goal with
                                      | B : bool |- _ => destruct B
                                      end); simpl; unfold Nlt; eauto.
        change (256%nat) with (N.to_nat 256).
        apply Nomega.Nlt_out. eauto.
        omega. change (pow2 8) with 256. omega.
      }
      subst. rewrite <- plus_n_O in H1. rewrite H1. clear H1.
      rewrite Nnat.N2Nat.id. rewrite ascii_N_embedding. eauto.
    }
    { intros env xenv xenv' n n' ext Eeq OK_env' Penc.
      destruct (decode_word n' xenv) as [ [ [? ? ] ? ] | ] eqn: ? ;
        simpl in *; try discriminate.
      injections.
      eapply (proj2 (Word_decode_correct P_OK)) in Heqo;
        destruct Heqo as [? [? ?] ]; destruct_ex; intuition; subst; eauto.
      unfold format_word in *; computes_to_inv; injections.
      repeat eexists; eauto.
      repeat f_equal.
      rewrite N_ascii_embedding.
      rewrite NToWord_nat, wordToN_nat.
      rewrite Nnat.Nat2N.id.
      rewrite natToWord_wordToNat; eauto.
      rewrite wordToN_nat.
      pose proof (wordToNat_bound w).
      simpl in H2.
      eapply Nomega.Nlt_in.
      rewrite Nnat.Nat2N.id.
      eauto.
    }
  Qed.

  Lemma ascii_decode_lt
    : forall (b3 : B) (cd0 : CacheDecode) (a : ascii) (b' : B) (cd' : CacheDecode),
      decode_ascii b3 cd0 = Some (a, b', cd') -> lt_B b' b3.
  Proof.
    unfold decode_ascii; intros.
    destruct (WordOpt.decode_word b3 cd0) as [ [ [? ?] ?] | ] eqn: ? ;
      simpl in *; try discriminate.
    apply WordOpt.decode_word_lt in Heqo.
    injections; eauto.
  Qed.

  Lemma ascii_decode_le :
    forall (b : B) (cd : CacheDecode) (a : ascii) (b' : B) (cd' : CacheDecode),
      decode_ascii b cd = Some (a, b', cd') -> le_B b' b.
  Proof.
    unfold decode_ascii, DecodeBindOpt2; intros.
    destruct (decode_word b cd) as [ [ [? ? ] ?] | ] eqn: decode_b; simpl in H;
      try discriminate; injections.
    eauto using decode_word_le.
  Qed.

End Ascii.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^322 - 2^161 - 1
Base: 26 + 5/6
***)

Definition curve : CurveParameters :=
  {|
    sz := 12%nat;
    base := 26 + 5/6;
    bitwidth := 32;
    s := 2^322;
    c := [(1, 1); (2^161, 1)];
    carry_chains := Some [[5; 11]; [6; 0; 7; 1; 8; 2; 9; 3; 10; 4; 11; 5]; [6; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(**************************************************************************)
(*  This is part of EXCEPTIONS-CL, it is distributed under the terms of   *)
(*         the GNU Lesser General Public License version 3                *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Prerequistes.

Module Make(Import M: Prerequistes.T).

 Inductive term: Type -> Type -> Type :=
  | tpure: forall {X Y: Type}, (X -> Y) -> term Y X
  | comp: forall {X Y Z: Type}, term X Y -> term Y Z -> term X Z
  | tag: forall t:EName, term empty_set (Val t)
  | untag: forall t:EName, term (Val t) empty_set.

 Infix "o" := comp (at level 70).

 Definition id  {X: Type}       : term X X         := tpure id.

 Definition emptyfun (X: Type) (e: empty_set) : X := match e with end.
 Definition empty X: term X empty_set := tpure (emptyfun X).

 (*category theoretic approach*)
(* Definition constant {A B} (a: term A unit) := a o (@forget B). *)

End Make.


(* Narjes Jomaa and David Nowak,
   Pip code refactored by Mohamed Sami Cherif *)
Require Import Pip_state Lib.

Require Import ProofIrrelevance  Coq.Program.Equality Arith List Omega.
Import List.ListNotations.

(** Internals *)

Definition readPhysicalInternal p i memory :option page :=
match (lookup p i memory beqPage beqIndex) with
                            | Some (PP a) => Some a
                            | _ => None
                       end.

Definition readVirtualInternal p i memory : option vaddr:=
  match (lookup p i memory beqPage beqIndex) with
  | Some (VA a) => Some a
  | _ => None
  end.

Definition succIndexInternal (idx:index) : option index :=
let (i,_):=idx in
  if lt_dec i tableSize
  then Some (CIndex (i+1))
  else None.

Definition writeVirtualInternal (p:page) (i:index) (v:vaddr) :=
fun s => {| currentPartition := s.(currentPartition);
  memory :=   add p i (VA v)  s.(memory) beqPage beqIndex|}.

Module Index.
Definition geb (a b : index) : bool := b <=? a.
Definition leb (a b : index) : bool := a <=? b.
Definition ltb (a b : index) : bool := a <? b.
Definition gtb (a b : index) : bool := b <? a.
Definition eqb (a b : index) : bool := a =? b.
End Index.

Module Page.
Definition eqb (p1 : page)  (p2 : page) : bool := (p1 =? p2).
End Page.

Module Level.
Definition gtb (a b : level) : bool := b <? a .
Definition eqb (a b : level) : bool:= a =? b.
Program Definition pred (n : level) : option level :=
if gt_dec n 0 then
let ipred := n-1 in
Some (Build_level ipred _ )
else  None.
Next Obligation.
destruct n.
simpl.
omega.
Qed.
End Level.

Module VAddr.
Definition eqbList(vaddr1 : vaddr) (vaddr2 : vaddr) : bool :=
 beqVAddr vaddr1 vaddr2.
End VAddr.

(** For conditions *)

(** The [getCurPartition] function returns the current partition descriptor of a given state *)
Definition getCurPartition s :page:=
currentPartition s.

(** The [getMaxIndex] function returns the last position into a page table *)
Definition getMaxIndex : option index:=
match gt_dec tableSize 0 with
| left x =>
    Some (CIndex (tableSize-1))
| right _ => None
end.

(** The [readPhysical] function returns the physical page stored into a given
    page at a given position in physical memory. The table should contain only Physical pages
    (The type [PP] is already defined into [Model.ADT]) *)
Definition readPhysical (paddr : page) (idx : index) memory: option page :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PP a) => Some a
  | _ => None
 end.

(**  The [getPd] function returns the physical page of the page directory of
     a given partition  *)
Definition getPd partition memory: option page:=
match succIndexInternal PDidx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(**  The [getFstShadow] returns the physical page of the first shadow page of
     a given partition  *)
Definition getFstShadow partition memory: option page:=
match succIndexInternal sh1idx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(**  The [getSndShadow] returns the physical page of the second shadow page  of
     a given partition *)
Definition getSndShadow partition memory: option page:=
match succIndexInternal sh2idx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(**  The [getConfigTablesLinkedList] returns the physical address of the indirection tables
 reverse translation of a given partition  *)
Definition getConfigTablesLinkedList partition memory: option page:=
match succIndexInternal sh3idx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(** The [readPDflag] function returns the flag value stored into a given table
    at a given position in memory. The table should contain only virtual entries
    (The type [VE] is already defined in [Model.ADT])  *)
Definition readPDflag  (paddr : page) (idx : index) memory : option bool:=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (VE a) => Some a.(pd)
  | Some _ => None
  | None => None
 end.

(** The [getNbLevel] function returns the number of translation levels of the MMU *)
Definition getNbLevel : option level:=
if gt_dec nbLevel 0
then Some (CLevel (nbLevel-1))
else None.

(** The [readPresent] function returns the flag value stored into a given table
    at a given position in memory. The table should contain only Physical entries *)
Definition readPresent  (paddr : page) (idx : index) memory : option bool:=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PE a) => Some a.(present)
  | Some _ => None
  | None => None
 end.

(** The [readAccessible] function returns the flag value stored into a given table
    at a given position in memory. The table should contain only Physical entries  *)
Definition readAccessible  (paddr : page) (idx : index) memory : option bool:=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PE a) => Some a.(user)
  | Some _ => None
  | None => None
 end.

Definition getIndexOfAddr (va : vaddr) (l : level) : index:=
nth ((length va) - (l + 2))  va defaultIndex .

(** The [checkVAddrsEqualityWOOffset] function compares two given virtual addresses
    without taking into account the last index *)
Fixpoint checkVAddrsEqualityWOOffset (timeout : nat) (va1 va2 : vaddr) (l : level) :=
match timeout with
|0 => true
|S timeout1 =>
let idx1 := getIndexOfAddr va1 l in
 let idx2 := getIndexOfAddr va2 l in
if Level.eqb l fstLevel
then
      (idx1 =? idx2)
    else
      match Level.pred l with
      | Some levelpred =>  if idx1 =? idx2
                              then checkVAddrsEqualityWOOffset timeout1 va1 va2 levelpred
                              else false
      | _ => true
      end
end.

(** The [readPhyEntry] function returns the physical page stored into a given table
    at a given position in memory. The table should contain only Physical entries *)
Definition readPhyEntry(paddr : page) (idx : index) memory: option page :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PE a) => Some a.(pa)
  | Some _ => None
  | None => None
 end.

(** The [readIndex] function returns the index stored into a given table
    at a given position in memory. The table should contain only indices  *)
Definition readIndex  (paddr : page) (idx : index) memory : option index :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (I indexValue) => Some indexValue
  | Some _ => None
  | None => None
 end.

 (** The [readVirtual] function returns the virtual address strored into a given table
    at a given position in memory. The table should contain a virtual address at this position *)
Definition readVirtual (paddr : page) (idx : index) memory : option vaddr :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (VA addr) => Some addr
  | Some _ => None
  | None => None
 end.

(** The [readVirEntry] function returns the virtual address strored into a given table
    at a given position in memory. The table should contain a VEntry at this position *)
Definition readVirEntry (paddr : page) (idx : index) memory : option vaddr :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (VE addr) => Some (vad addr)
  | Some _ => None
  | None => None
 end.

(** The [getDefaultPage] function returns the value of the default page *)
Definition getDefaultPage := defaultPage.

(** The [getIndirection] function returns the configuration table entry that corresponds
    to the given level and virtual address *)
Fixpoint  getIndirection (pd : page) (va : vaddr) (currentlevel : level) (stop : nat) s :=
match stop with
|0 => Some pd
|S stop1 =>
if (Level.eqb currentlevel fstLevel)
then Some pd
  else
    let idx :=  getIndexOfAddr va currentlevel in
       match readPhyEntry pd idx s.(memory) with
       | Some addr =>  if  defaultPage =? addr
                          then Some defaultPage
                          else
                            match Level.pred currentlevel with
                            |Some p =>  getIndirection addr va p stop1 s
                            |None => None
                            end
      |None => None
    end
   end.

(** The [getMappedPage] function returns the physical page stored into a leaf node,
   which corresponds to a given virtual address, if the present flag is equal to true **)
Definition getMappedPage pd s va: option page :=
match getNbLevel  with
 |None => None
 |Some level => let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection pd va level (nbLevel - 1) s with
                | Some tbl =>  if defaultPage =? tbl
                                   then None
                                   else match (readPresent tbl idxVA s.(memory)) with
                                         |Some true => readPhyEntry tbl idxVA s.(memory)
                                         | _ =>  None
                                        end
                | _ => None
               end
end.

(** The [getVirtualAddressSh2] function returns the virtual address stored into the
    second shadow structure which corresponds to a given virtual address **)
Definition getVirtualAddressSh2 sh2 s va: option vaddr :=
match getNbLevel  with
 |None => None
 |Some level => let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection sh2 va level (nbLevel - 1) s with
                | Some tbl =>  if defaultPage =? tbl
                                   then None
                                   else readVirtual tbl idxVA s.(memory)
                | _ => None
               end
end.

(** The [getVirtualAddressSh2] function returns the virtual address stored into the
    parent **)
Definition getVAInParent partition s va: option vaddr :=
match getSndShadow partition (memory s) with
|Some sh2 => match getVirtualAddressSh2 sh2 s va with
             | Some vainparent =>  if (VAddr.eqbList defaultVAddr vainparent)
                                     then None
                                     else Some vainparent
             | _ => None
             end
| _ => None
end.

(** The [getVirtualAddressSh1] function returns the virtual address stored into the first
   shadow structure which corresponds to a given virtual address **)
Definition getVirtualAddressSh1 sh1 s va: option vaddr :=
match getNbLevel  with
 |None => None
 |Some level => let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection sh1 va level (nbLevel - 1) s with
                | Some tbl =>  if defaultPage =? tbl
                                   then None
                                   else readVirEntry tbl idxVA s.(memory)
                | _ => None
               end
end.

(** The [getAccessibleMappedPage] function returns the physical page stored into a leaf node,
   which corresponds to a given virtual address, if the present and user flags are equal to true **)
Definition getAccessibleMappedPage pd s va: option page :=
match getNbLevel  with
 |None => None
 |Some level =>let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection pd va level (nbLevel - 1) s with
                | Some tbl => if defaultPage =? tbl
                                   then None
                                   else  match (readPresent tbl idxVA s.(memory)),
                                                   (readAccessible tbl idxVA s.(memory)) with
                                           |Some true, Some true => readPhyEntry tbl idxVA s.(memory)
                                           | _, _ =>  None
                                          end
                | _ => None
               end
end.

(** The [geTrdShadows] returns physical pages used to keep informations about
    configuration pages
*)
Fixpoint getTrdShadows (sh3 : page) s bound :=
match bound with
|0 => []
|S bound1 => match getMaxIndex with
            |None => []
            |Some maxindex =>  match readPhysical sh3 maxindex s.(memory) with
                                |None => [sh3]
                                |Some addr => if addr =? defaultPage then [sh3] else sh3 :: getTrdShadows addr s bound1
                               end
           end
end.

(** The [checkChild] function returns true if the given virtual address corresponds
    to a child of the given partition
    *)
Definition checkChild partition level (s:state) va : bool :=
let idxVA :=  getIndexOfAddr va fstLevel in
match getFstShadow partition s.(memory)  with
| Some sh1  =>
   match getIndirection sh1 va level (nbLevel -1) s with
    |Some tbl => if tbl =? defaultPage
                    then false
                    else match readPDflag tbl idxVA s.(memory) with
                          |Some true => true
                          |_ => false
                          end
    |None => false
    end
| _ => false
end.

(** The [getTablePages] function returns the list of physical pages stored into
    a given configuration table from a given index *)
Fixpoint getTablePages (table : page ) (idx : nat) s : list page :=
match idx with
| 0 => []
|S idx1 => match  lookup table (CIndex idx1) s.(memory) beqPage beqIndex  with
              | Some (PE entry) => if (pa entry =? defaultPage ) then getTablePages table idx1 s
                                      else getTablePages table idx1 s ++ [pa entry]
              | _ => getTablePages table idx1 s
            end
end.

Fixpoint getIndirectionsAux (pa : page) (s : state) level {struct level} : list page :=
  match level with
    | O => []
    | S level1 => pa :: flat_map (fun p => getIndirectionsAux p s level1)
                                    (getTablePages pa tableSize s)
  end.

(** The [getIndirectionsAux] function returns the list of physical pages
    used into a configuration tables tree *)
Definition getIndirections pd s : list page :=
  getIndirectionsAux pd s nbLevel.

Fixpoint getAllIndicesAux (pos count: nat) : list index :=
  match count with
    | 0        => []
    | S count1 => match lt_dec pos tableSize with
                   | left pf => Build_index pos pf :: getAllIndicesAux (S pos) count1
                   | _       => []
                 end
  end.

(** The [getAllIndicesAux] function returns the list of all indices  *)
Definition getAllIndices := getAllIndicesAux 0 tableSize.

Fixpoint getAllVAddrAux (levels: nat) : list (list index) :=
  match levels with
    | 0         => [[]]
    | S levels1 => let alls := getAllVAddrAux levels1 in
                  flat_map (fun (idx : index) => map (cons idx) alls) getAllIndices
  end.

(** The [getAllVAddr] function returns the list of all virtual addresses *)
Definition getAllVAddr := map CVaddr (getAllVAddrAux (S nbLevel)).

(** The [getPdsVAddr] function returns the list of virtual addresses used as
    partition descriptor into a given partition *)
Definition getPdsVAddr partition l1 (vaList : list vaddr) s :=
filter (checkChild partition l1 s) vaList.

(** The [getMappedPagesOption] function Return all physical pages marked as
    present into a partition *)
Definition getMappedPagesOption (pd : page) (vaList : list vaddr) s : list (option page) :=
map (getMappedPage pd s) vaList.

(** The [getAccessibleMappedPagesOption] function Return all physical pages
    marked as present and accessible into a partition *)
Definition getAccessibleMappedPagesOption (pd : page) (vaList : list vaddr) s : list (option page) :=
map (getAccessibleMappedPage pd s) vaList.

(** The [filterOption] function Remove option type from list *)
Fixpoint filterOption (l : list (option page)) :=
match l with
| [] => []
| Some a :: l1 => a:: filterOption l1
|None :: l1 => filterOption l1
end.

(** The [getMappedPagesAux] function removes option type from mapped pages list *)
Definition getMappedPagesAux (pd :page)  (vaList : list vaddr) s : list page :=
filterOption (getMappedPagesOption pd vaList s).

(** The [getAccessibleMappedPagesAux] function removes option type from
    accessible mapped pages list *)
Definition getAccessibleMappedPagesAux (pd :page)  (vaList : list vaddr) s : list page :=
filterOption (getAccessibleMappedPagesOption pd vaList s).

(** The [getConfigPagesAux] function returns all configuration pages of a
    given partition *)
Definition getConfigPagesAux (partition : page) (s : state) : list page :=
let vaList := getAllVAddr in
match getPd partition s.(memory),
      getFstShadow partition s.(memory),
      getSndShadow partition s.(memory),
      getConfigTablesLinkedList partition s.(memory)  with
| Some pd , Some sh1, Some sh2 , Some sh3  => (getIndirections pd s)++
                         (getIndirections sh1 s)++
                         (getIndirections sh2 s )++
                         (getTrdShadows sh3 s (nbPage+1))
|_,_,_,_ => []
end.

Definition getConfigPages (partition : page) (s : state) :=
partition :: (getConfigPagesAux partition s).

(** The [getMappedPages] function Returns all present pages of a given partition *)
Definition getMappedPages (partition : page) s : list page :=
  match getPd partition s.(memory) with
    |None => []
    |Some pd => let vaList := getAllVAddr in getMappedPagesAux pd vaList s
  end.

(** The [getAccessibleMappedPages] function Returns all present and
    accessible pages of a given partition *)
Definition getAccessibleMappedPages (partition : page) s : list page :=
  match getPd partition s.(memory) with
    |None => []
    |Some pd => let vaList := getAllVAddr in getAccessibleMappedPagesAux pd vaList s
  end.

(** The [getUsedPages] function Returns all used pages (present and config pages)
    of a given partition including the partition descriptor itself *)
Definition getUsedPages (partition: page) s : list page :=
  getConfigPages partition s ++ getMappedPages partition s.

Lemma  eqPageDec : forall n m : page, {n = m} + {n <> m}.
Proof.
intros.
destruct n. destruct m.
assert ({p = p0} + {p <> p0}).
apply eq_nat_dec.
destruct H.
left.
subst.
assert(Hp = Hp0) by apply proof_irrelevance.
subst.
trivial.
right.
unfold not in *.
intros. apply n.
clear n.
inversion H. trivial.
Qed.

(** The [getChildren] function Returns all children of a given partition *)
Definition getChildren (partition : page) s :=
let vaList := getAllVAddr in
match getNbLevel, getPd partition s.(memory) with
|Some l1,Some pd => getMappedPagesAux pd (getPdsVAddr partition l1 vaList s) s
|_, _ => []
end.

(** The [getPartitionsAux] function returns all pages marked as descriptor partition *)
Fixpoint getPartitionAux (partitionRoot : page) (s : state) bound {struct bound} : list page :=
  match bound with
    | O => []
    | S bound1 => partitionRoot :: flat_map (fun p => getPartitionAux p s bound1)
                                    (getChildren partitionRoot s )
  end.

(** The [getPartitions] function fixes the sufficient timeout value to retrieve all partitions *)
Definition getPartitions (root : page) s : list page  :=
(getPartitionAux root s (nbPage+1)).

(** The [getParent] function returns the parent partition descriptor of a given partition *)
Definition getParent partition memory :=
match succIndexInternal PPRidx with
| Some idx =>  readPhysical partition idx memory
| _ => None
end.

(** The [getAncestorsAux] function returns the ancestors list of a given partition *)
Fixpoint getAncestorsAux (partition : page) memory depth : list page :=
match depth with
|0 => []
| S depth1 => match getParent partition memory with
               | Some parent => parent :: getAncestorsAux parent memory depth1
               | _ => []
              end
end.

(** The [getAncestors] function fixes the sufficient timeout value to retrieve all ancestors *)
Definition getAncestors (partition : page) s :=
getAncestorsAux partition s.(memory) (nbPage+1).

(** Propositions *)
(** The [isPE] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PE] *)
Definition isPE table idx s: Prop :=
match lookup table idx s.(memory) beqPage beqIndex with
             |Some (PE _) => True
             |_ => False
end.

(** The [isVE] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [VE] *)
Definition isVE table idx s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (VE _) => True
             |_ => False
end.

(** The [isVA] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [VA] *)
Definition isVA table idx s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (VA _) => True
             |_ => False
end.

(** The [isPP] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PE] *)
Definition isPP table idx s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (PP _) => True
             |_ => False
end.

(** The [isPP'] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PP] and physical page stored into this entry
    is equal to a given physical page [pg]*)
Definition isPP' table idx pg s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (PP p) => p = pg
             |_ => False
end.

(** The [nextEntryIsPP] proposition reutrns True if the entry at position [idx+1]
    into the given physical page [table] is type of [PP] and physical page stored into
    this entry is equal to a given physical page [pg] *)
Definition nextEntryIsPP table idxroot tableroot s : Prop:=
match succIndexInternal idxroot with
| Some idxsucc => match lookup table idxsucc (memory s) beqPage beqIndex with
                  | Some (PP table) => tableroot = table
                  |_ => False
                  end
| _ => False
end.

(** The [entryPresentFlag] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [PP] and the present flag stored into
    this entry is equal to a given flag [flag] *)
Definition entryPresentFlag table idx flag s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (PE entry) => flag =  entry.(present)
| _ => False
end.

(** The [entryPDFlag]  proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the pd flag stored into
    this entry is equal to a given flag [flag] *)
Definition entryPDFlag table idx flag s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (VE entry) => flag =  entry.(pd)
| _ => False
end.

(** The [entryUserFlag] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the user flag stored into
    this entry is equal to a given flag [flag] *)
Definition entryUserFlag table idx flag s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (PE entry) => flag =  entry.(user)
| _ => False
end.

(** The [VEDerivation] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the given boolean value
    [res] specifies if the virtual address stored into
    this entry is equal or not to the default virtual address *)
Definition VEDerivation table idx (res : bool) s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (VE entry) => ~ (beqVAddr entry.(vad) defaultVAddr) = res
| _ => False
end.

(** The [isEntryVA] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the virtual address
    stored into this entry is equal to a given virtual address [v1] *)
Definition isEntryVA table idx v1 s:=
 match lookup table idx (memory s) beqPage beqIndex with
 | Some (VE entry)  => entry.(vad) = v1
 | _ => False
 end.

(** The [isVA'] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VA] and the virtual address
    stored into this entry is equal to a given virtual address [v1] *)
Definition isVA' table idx v1 s:=
 match lookup table idx (memory s) beqPage beqIndex with
 | Some (VA entry)  => entry = v1
 | _ => False
 end.

(** The [isEntryPage] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PE] and physical page stored into this entry
    is equal to a given physical page [page1]*)
Definition isEntryPage table idx page1 s:=
 match lookup table idx (memory s) beqPage beqIndex with
 | Some (PE entry)  => entry.(pa) = page1
 | _ => False
 end.

(** The [getTableAddrRoot'] proposition returns True if the given physical page [table]
is a configuration table into different structures (pd, shadow1 or shadow2). This table should be associated to the
given virtual address [va]  *)
Definition getTableAddrRoot' (table : page) (idxroot : index)
(currentPart : page) (va : vaddr) (s : state) : Prop :=
(idxroot = PDidx \/ idxroot = sh1idx \/ idxroot = sh2idx) /\
(forall tableroot : page,
 nextEntryIsPP currentPart idxroot tableroot s ->
 exists nbL : level,
   Some nbL = getNbLevel /\
   (exists stop : nat, stop > 0 /\ stop <= nbL /\ getIndirection tableroot va nbL stop s = Some table)).

(** The [getTableAddrRoot] proposition returns True if the given physical page [table]
is the last page table into a structure (pd, shadow1 or shadow2) that corresponds to a given virtual address [va] *)
Definition getTableAddrRoot table idxroot currentPart va s : Prop :=
(idxroot = PDidx \/ idxroot = sh1idx \/ idxroot = sh2idx)/\
   forall (tableroot : page), nextEntryIsPP  currentPart idxroot tableroot s ->
   exists nbL, Some nbL = getNbLevel  /\ exists (stop :nat) , stop = nbL+1  /\
    getIndirection tableroot va nbL stop s = Some table .

(** The [getAllPages] returns the list of all physical pages *)
Definition getAllPages: list page:=
map CPage (seq 0 nbPage ).

(** The [getPDFlag] checks if the given virtual address corresponds to a partition
    descriptor **)
Definition getPDFlag sh1 va s :=
let idxVA := getIndexOfAddr va fstLevel in
match getNbLevel with
|Some nbL =>  match getIndirection sh1 va nbL (nbLevel - 1) s with
  | Some tbl =>
      if tbl =? defaultPage
      then false
      else
       match readPDflag tbl idxVA (memory s) with
       | Some true => true
       | Some false => false
       | None => false
       end
  | None => false
  end
| None => false
end.

(** The [isAccessibleMappedPageInParent] function returns true if the given physical
    page is accessible in the parent of the given partition **)
Definition isAccessibleMappedPageInParent partition va accessiblePage s  :=
match getSndShadow partition (memory s) with
| Some sh2 =>
  match  getVirtualAddressSh2 sh2 s va  with
   | Some vaInParent =>
     match getParent partition (memory s) with
      | Some parent =>
        match getPd parent (memory s) with
         | Some pdParent =>
           match getAccessibleMappedPage pdParent s vaInParent with
            | Some sameAccessiblePage => accessiblePage =? sameAccessiblePage
            | None => false
           end
         | None => false
        end
    | None => false
           end
| None => false
           end
| None => false
end.

(** The [isPartitionFalse] returns true if the partition descriptor flag of a given
     entry is equal to false or there is no data stored into this entry **)
Definition isPartitionFalse ptPDChildSh1 idxPDChild s :=
readPDflag ptPDChildSh1 idxPDChild (memory s) = Some false \/
readPDflag ptPDChildSh1 idxPDChild (memory s) = None.

(** The [isAncestor] funtion returns true if the given partitions are equal
    or the descParent partition is an ancestor of currentPart **)
Definition isAncestor  currentPart descParent s :=
( currentPart = descParent \/ In descParent (getAncestors currentPart s)).

Definition isWellFormedFstShadow nbL table  s:=
(nbL <> fstLevel /\
(forall idx, readPhyEntry table  idx s.(memory) = Some defaultPage /\
readPresent table idx (memory s) = Some false )) \/
(nbL = fstLevel /\
( forall idx : index,
(readVirEntry table idx (memory s) = Some defaultVAddr) /\
readPDflag table idx (memory s) = Some false) ).

Definition isWellFormedSndShadow nbL table  s:=
(nbL <> fstLevel /\ (
forall idx, readPhyEntry table  idx s.(memory) = Some defaultPage /\
readPresent table idx (memory s) = Some false )) \/
(nbL = fstLevel /\ ( forall idx : index,
(readVirtual table idx (memory s) = Some defaultVAddr) ) ).

(** The [isDerived] funtion returns true if a physical page is derived
    into the given partition , this physical page is associated to the given
    virtual address [va] **)
Definition isDerived partition va  s  :=
match getFstShadow partition (memory s) with
| Some sh1 =>
  match  getVirtualAddressSh1 sh1 s va  with
   | Some va0 => beqVAddr defaultVAddr va0 = false
   | _ => False
  end
| None => False
end.

Lemma  pageDec :
forall x y : page, {x = y} + {x <> y}.
Proof.
intros.
destruct x; destruct y.
assert({p = p0} + {p <> p0}).
apply Nat.eq_dec.
destruct H.
left.
subst.
f_equal.
apply proof_irrelevance.
right.
contradict n.
inversion n.
subst;trivial.
Qed.

Fixpoint closestAncestorAux part1 part2 s bound : option page :=
match bound  with
| 0 => None
| S bound1 => match getParent part1 (memory s) with
              | Some parent => match in_dec pageDec part2
                                    (getPartitionAux parent s (nbPage+1)) with
                               | left _  => Some parent
                               | _ =>  closestAncestorAux parent part2 s bound1
                               end
              | None =>  Some multiplexer
              end
end.

Definition closestAncestor part1 part2 s :=
closestAncestorAux part1 part2 s (nbPage+1).

Ltac symmetrynot :=
match goal with
| [ |- ?x <> ?y ] => unfold not ; let Hk := fresh in intro Hk ; symmetry in Hk ;contradict Hk
end.


From discprob.basic Require Import base order nify seq_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.finite Require Import monad monad_hoare counter leader.
From discprob.rec Require Import leader_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier Psatz Omega.

Definition h (rp: nat * nat) :=
  match (fst rp) with
    | O => mret (O, snd rp)
    | S r' =>
      match (snd rp) with
      | O => mret (fst rp, O)
      | S O => mret (fst rp, O)
      | S (S n') =>
        surv ← counter.binomial (S (S n'));
        if sval surv == O then
            mret (r', S (S n'))
          else
            mret (r', sval surv)
      end
  end.
Definition rsize (n: nat * nat) :=
  match fst n with
    | O => 0
    | _ => INR (snd n)
  end.

Definition m x :=
  match (Rlt_dec x 2) with
  | left _ => 0
  | _ => x * (3 / 4)
  end.

Lemma Ex_h_aux n r:
  (Ex (rvar_of_ldist (x ← counter.binomial n; mret (rsize (r, (sval x))))) : R) <= 1/2 * INR n.
Proof.
  induction n.
  - rewrite binomial_unfold ldist_left_id Ex_mret_simpl /rsize //=.
    destruct r => //=; nra.
  - rewrite binomial_unfold ldist_assoc Ex_mbind_ldist2 ?big_cons ?big_nil Rplus_0_r /snd.
    rewrite ?ldist_fmap_bind; simpl sval.
    rewrite pr_flip_true pr_flip_false.
    rewrite Ex_mbind_mret.
    etransitivity.
    { apply Rplus_le_compat_r. apply Rmult_le_compat_l; first nra.
      apply (Ex_fin_comp_mono _ _ (λ x, (1 + rsize (r, sval x)))).
      intros (x&?) => //=. rewrite /rsize.
      destruct r => //=; try nra.
      destruct x => //=; try nra.
    }
    rewrite -(rvar_comp_comp _ (λ x, rsize (r, sval x))).
    rewrite Ex_fin_plus_l. rewrite (Rplus_comm 1).
    rewrite -Ex_mbind_mret. rewrite S_INR.
    etransitivity.
    { apply Rplus_le_compat.
      * apply Rmult_le_compat_l; first nra. apply Rplus_le_compat_r; apply IHn.
      * apply Rmult_le_compat_l; first nra. apply IHn.
    }
    nra.
Qed.

Lemma Ex_h rp:
  Ex (rvar_comp (rvar_of_ldist (h rp)) rsize) <= m (rsize rp).
Proof.
  destruct rp as (r, p).
  revert r.
  induction p as [n IH] using (well_founded_induction lt_wf) => r.
  destruct r.
  {
    rewrite Ex_fin_comp.
    rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ a)).
    rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
    rewrite pr_mret_simpl //= /m eq_refl.
    rewrite /rsize//=. destruct Rlt_dec; nra.
  }
  destruct n as [| n]; last destruct n as [| n].
  - rewrite Ex_fin_comp.
    rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ a)).
    rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
    rewrite pr_mret_simpl //= /m eq_refl.
    rewrite /rsize//=. destruct (Rlt_dec) => //; nra.
  - rewrite Ex_fin_comp.
    rewrite -(big_map _ (λ x, true) (λ a, pr_eq _ a * _ a)).
    rewrite img_rvar_of_ldist//=/img/undup//= !big_cons ?big_nil.
    rewrite pr_mret_simpl //= /m eq_refl.
    rewrite /rsize//=. destruct (Rlt_dec) => //; nra.
  - rewrite /h/fst/snd binomial_unfold.
    rewrite -Ex_mbind_mret ?ldist_assoc.
    rewrite Ex_mbind_ldist2 ?big_cons ?big_nil Rplus_0_r /snd.
    rewrite pr_flip_true pr_flip_false.
    rewrite ?ldist_fmap_bind. simpl sval.
    rewrite -ldist_assoc ldist_fmap_bind.
    destruct n as [| n].
    {
      rewrite binomial_unfold ?ldist_assoc ?Ex_mbind_ldist2 ?big_cons ?big_nil Rplus_0_r /snd.
      rewrite ?pr_flip_true ?pr_flip_false.
      rewrite ?ldist_fmap_bind. simpl sval.
      rewrite ?binomial_unfold ?ldist_assoc ?Ex_mbind_ldist2 ?big_cons ?big_nil Rplus_0_r /snd.
      rewrite ?ldist_left_id ?Ex_mret_simpl pr_mret_simpl.
      rewrite eq_refl //=.
      rewrite /rsize/m//=. destruct Rlt_dec => //=; first nra.
      destruct r; nra.
    }
    etransitivity.
    {
      apply Rplus_le_compat.
      * apply Rmult_le_compat_l; first nra.
        etransitivity.
        ** rewrite Ex_mbind_mret. apply (Ex_fin_comp_mono _ _ (λ x, (1 + rsize (r, sval x)))).
           intros (x&?) => //=. rewrite /rsize.
           destruct r => //=; try nra.
           destruct x => //=; try nra.
        ** rewrite -(rvar_comp_comp _ (λ x, rsize (r, sval x))).
           rewrite Ex_fin_plus_l. rewrite Rplus_comm.
           apply Rplus_le_compat_r. rewrite -Ex_mbind_mret. apply Ex_h_aux.
      * apply Rmult_le_compat_l; first nra.
        etransitivity.
        ** rewrite (ldist_bind_ext _ (λ x, x' ← if sval x == 0%nat then mret (r, S (S (S n)))
                                                 else mret (r, sval x);
                                           mret (rsize x'))
                                     (λ x, x' ← mret (if sval x == 0%nat then (r, S (S (S n)))
                                                      else (r, sval x));
                                            mret (rsize x'))); last first.
           { intros. case: ifP; auto. }
           rewrite -ldist_assoc.
           rewrite ldist_fmap_bind.
           rewrite Ex_mbind_mret.
           apply (Ex_fin_comp_mono _ _ (λ x, (1 + rsize (if sval x == 0%nat then
                                                           (r, S (S n))
                                                         else
                                                           (r, sval x))))).
           { intros. rewrite /rsize; case: ifP => //=; destruct r; nra. }
        ** rewrite -(rvar_comp_comp _ _ (Rplus 1)).
           rewrite Ex_fin_plus_l. rewrite Rplus_comm.
           apply Rplus_le_compat_r. rewrite -Ex_mbind_mret.
           assert (S (S n) < S (S (S n)))%coq_nat as Hbound by auto.
           specialize (IH (S (S n)) Hbound (S r)).
           rewrite /h/fst/snd in IH.
           rewrite -(ldist_fmap_bind _ _ (λ x, mret (rsize x))) Ex_mbind_mret.
          rewrite -(ldist_bind_ext _ (λ x, if sval x == 0%nat then mret (r, (S (S n)))
                                           else mret (r, sval x))
                                     (λ x, mret (if sval x == 0%nat then (r, (S (S n)))
                                                      else (r, sval x)))); last first.
           { intros. case: ifP; auto. }
           apply IH.
    }
    rewrite ?S_INR /rsize/fst/snd ?S_INR.
    rewrite /m/rsize//=.
    specialize (pos_INR n).
    destruct (Rlt_dec) => //=; first nra.
    destruct (Rlt_dec) => //=; first nra.
    nra.
Qed.

Definition T := λ x, rvar_comp (rvar_of_ldist (leader_elect (fst x) (snd x)))
                               (λ y, INR (fst x - fst y)).
Definition a x :=
  match Rle_dec x 1 with
  | left _ => 0
  | _ =>
    match Rlt_dec x 2 with
    | left _ => (x - 1)
    | _ => 1
    end
  end.
Definition h' x := rvar_of_ldist (h x).

Lemma if_mret {A: eqType} (P: bool) (a b: A):
  (if P then (mret a : ldist A) else mret b) = (mret (if P then a else b)).
Proof.
  destruct P; auto.
Qed.

Lemma Rmult_le_0_inv_r r r1 r2:
  r >= 0 → (r ≠ 0 → r1 <= r2) → r * r1 <= r * r2.
Proof.
  intros Hge Hcase. inversion Hge.
  - apply Rmult_le_compat_l; first nra. apply Hcase. nra.
  - subst. nra.
Qed.

Lemma Trec:
  ∀ x r, (λ x, true) x → pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h' x))
                ((pr_eq (h' x) (sval x')) * pr_gt (rvar_comp (T (sval x')) (λ x, x)) (r - a (rsize x))).
Proof.
  intros (rounds, n).
  intros. destruct rounds.
  {
    rewrite /T -pr_gt_mbind_mret ldist_left_id pr_gt_mret_simpl.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' (O, n)) x' *
      pr_gt (rvar_comp (rvar_comp (rvar_of_ldist (leader_elect (fst x') (snd x')))
                                  (λ y, INR (fst x' - fst y))) (λ x, x))
            (r - a (rsize _))))).
    rewrite img_rvar_of_ldist /h'/h//=.
    rewrite big_cons big_nil Rplus_0_r//=.
    rewrite /a/rsize/size//=.
    destruct (Rlt_dec); last nra.
    destruct (Rle_dec); last nra.
    rewrite rvar_comp_comp //=.
            rewrite //=.
    specialize (pr_gt_mbind_mret (mret (O, n)) (ssrfun.id \o (λ _ : nat * nat, 0)) (r - 0)).
    rewrite ldist_left_id.
    rewrite //= => <-.
    rewrite !pr_mret_simpl !pr_gt_mret_simpl eq_refl /id //= Rminus_0_r Rmult_1_l; nra.
  }
  induction n as [| n].
  - intros. rewrite /T.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' (S rounds, O)) x' *
      pr_gt (rvar_comp (rvar_comp (rvar_of_ldist (leader_elect (fst x') (snd x')))
                                  (λ y, INR (fst x' - fst y))) ssrfun.id)
            (r - a (rsize (S rounds, O)))))).
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    simpl fst.  simpl snd.
    rewrite /a/rsize/size.  simpl fst. rewrite /snd.
    replace (INR 0) with 0 by auto.
    destruct (Rlt_dec); last nra.
    destruct (Rle_dec); last nra.
    rewrite rvar_comp_comp //=.
    specialize (pr_gt_mbind_mret (mret (S rounds, O)) (ssrfun.id \o (λ y, INR (S rounds - fst y)))
                                 (r - 0)).
    rewrite ldist_left_id //= => <-.
    specialize (pr_gt_mbind_mret (mret (S rounds, O)) (λ y, INR (S rounds - fst y)) (r)).
    rewrite ldist_left_id //= => <-.
    rewrite !pr_mret_simpl !pr_gt_mret_simpl eq_refl /id //=.
    rewrite Rminus_0_r.
    destruct (Rgt_dec);  nra.
  - intros. destruct n as [| n].
    {
      intros. rewrite /T.
      rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' (S rounds, S O)) x' *
      pr_gt (rvar_comp (rvar_comp (rvar_of_ldist (leader_elect (fst x') (snd x')))
                                  (λ y, INR (fst x' - fst y))) ssrfun.id)
            (r - a (rsize (S rounds, S O)))))).
    rewrite img_rvar_of_ldist /h.
    rewrite big_cons big_nil Rplus_0_r.
    simpl fst.  simpl snd.
    rewrite /a/rsize/size.  simpl fst. rewrite /snd.
    replace (INR 1) with 1 by auto.
    destruct (Rlt_dec); last nra.
    destruct (Rle_dec); last nra.
    rewrite rvar_comp_comp //=.
    specialize (pr_gt_mbind_mret (mret (S rounds, O)) (ssrfun.id \o (λ y, INR (S rounds - fst y)))
                                 (r - 0)).
    rewrite ldist_left_id //= => <-.
    specialize (pr_gt_mbind_mret (mret (S rounds, S O)) (λ y, INR (S rounds - fst y)) (r)).
    rewrite ldist_left_id //= => <-.
    rewrite !pr_mret_simpl !pr_gt_mret_simpl eq_refl /id //=.
    rewrite Rminus_0_r.
    destruct (Rgt_dec);  nra.
    }
    rewrite /T.
    transitivity
      (pr_gt (rvar_comp (rvar_of_ldist
         (surv ← h (S rounds, S (S n)); leader_elect (fst surv) (snd surv)))
          (λ x, 1 + (INR (rounds - fst x)))) r); last first.
    {
      rewrite /T.
    rewrite -(big_map _ (λ x, true)
     (λ x',
     (pr_eq (h' (S rounds, S (S n))) x' *
      pr_gt (rvar_comp (rvar_comp (rvar_of_ldist (leader_elect (fst x') (snd x')))
                       (λ y, INR (fst x' - fst y))) id)
            (r - a (rsize (S rounds, S (S n))))))).
    rewrite -pr_gt_mbind_mret ldist_assoc. rewrite pr_gt_mbind_ldist2.
    rewrite img_rvar_of_ldist.
      * eapply Rle_bigr. intros k ?.
        apply Rmult_le_0_inv_r; first apply pr_eq_ge_0.
        intros Hnon0.
        rewrite pr_gt_mbind_mret.
        rewrite rvar_comp_comp. rewrite {1}/pr_gt {1}[a in _ <= a]/pr_gt.
        rewrite ?pr_gt_alt_comp /id. eapply Rle_bigr => x ?. rewrite //=.
        cut ((fst k >= rounds)%coq_nat).
        {
          intros Hlt.
          destruct Rgt_dec as [Hc1|Hc1] => //=; try auto; try nra;
          destruct Rgt_dec as [Hc2|Hc2] => //=; try auto; try nra.
          ** exfalso. apply Hc2. rewrite /rsize/a.
             specialize (S_INR n) => /= => ->.
             specialize (pos_INR n). destruct (Rlt_dec) as [Hlt0|Hnlt]; first nra.
             destruct (Rle_dec); first nra.
             intros. assert (INR (rounds - fst (sval x)) > r - 1).
               { clear -Hc1. rewrite //= in Hc1. rewrite //=. nra. }
             eapply Rge_gt_trans; eauto.
             apply Rle_ge. apply le_INR. nify. clear -Hlt. destruct x => //=.
             destruct x, k => //=. simpl in Hlt. omega.
          ** apply Rge_le, pr_eq_ge_0.
        }
        assert ( k \in img (h' (S rounds, S (S n)))) as Himg.
        { apply pr_img. edestruct (pr_eq_ge_0 (h' (S rounds, S (S n)))); eauto.
          congruence. }
        apply img_alt in Himg.
        destruct Himg as (i&<-).
        rewrite /h'. apply fun_to_mspec.
        rewrite /h/fst/snd. tbind (λ x, true).
        { rewrite //=. }
        intros ??. case: ifP => ?; apply mspec_mret; auto.
    }
    rewrite /h/fst/snd.
    rewrite -?pr_gt_mbind_mret.
    rewrite leader_elect_unfold.
    rewrite ldist_assoc.
    rewrite -?pr_gt_mbind_mret.
    rewrite ?ldist_assoc.
    eapply le_dist_ldist_bind_ext => a.
    eapply le_dist_ldist_bind_ext => pv k.
    rewrite (if_mret (sval pv == 0)%nat (rounds, S (S n)) (rounds, sval pv)).
    rewrite ldist_left_id //=.
    case: ifP.
    * intros. rewrite //=. apply: le_dist_ldist_bind_ext => n'; clear k.
                intros k. rewrite ?pr_gt_mret_simpl.
                destruct (Rgt_dec) as [Hc1|Hc1] => //=; try nra;
                destruct (Rgt_dec) as [Hc2|Hc2] => //=; try nra.
                exfalso. apply Hc2. eapply Rge_gt_trans; eauto.
                replace 1 with (INR 1) by auto. rewrite -plus_INR.
                apply Rle_ge, le_INR. nify. omega.
    * intros. rewrite //=. apply: le_dist_ldist_bind_ext => n'; clear k.
                intros k. rewrite ?pr_gt_mret_simpl.
                destruct (Rgt_dec) as [Hc1|Hc1] => //=; try nra;
                destruct (Rgt_dec) as [Hc2|Hc2] => //=; try nra.
                exfalso. apply Hc2. eapply Rge_gt_trans; eauto.
                replace 1 with (INR 1) by auto. rewrite -plus_INR.
                apply Rle_ge, le_INR. nify. omega.
Qed.

Definition k := -/ ln(3/4).

Theorem bound x w:
    rsize x > 1 →
    pr_gt (T x) ((k * ln (rsize x) + 1) + INR w)
       ≤ (3/4)^w.
Proof.
  specialize (leader_rec.recurrence_leader.leader_bound _ _ _ _ T h' (λ x, true)).
  rewrite /size/rsize => Hrec. eapply Hrec; clear.
  - auto.
  - intros l ?. rewrite //=.
    rewrite /leader_rec.recurrence_leader.size/leader_rec.recurrence_leader.msr //= => Hgt.
    cut (∀ n, INR (fst ((rvar_of_ldist (h l) n))) <= INR (fst l) - 1); first by rewrite //=.
    intros n'. apply fun_to_mspec.
    rewrite /h.
    destruct l as (r, p). rewrite /fst/snd.
    destruct r as [| r].
    { move: Hgt.  rewrite //=. nra. }
    move: Hgt. rewrite /fst/snd.
      destruct p.
      * replace (INR 0) with 0 by auto; nra.
      * rewrite S_INR. destruct p.
        ** replace (INR 0) with 0 by auto; nra.
        ** intros. tbind (λ x, true); first by auto.
           intros. case: ifP; intros; apply mspec_mret => //=;
           destruct r; rewrite ?S_INR //=; nra.
  - intros l. rewrite //=.
    cut (∀ n, recurrence_leader.size ((rvar_of_ldist (h l) n)) <=
              recurrence_leader.size (l)); first by rewrite //=.
    intros n'. apply fun_to_mspec.
    rewrite /h.
    destruct l as (r, p). rewrite /fst/snd.
    destruct r as [| r].
    { apply mspec_mret. reflexivity.  }
    destruct p as [| p].
    { apply mspec_mret. reflexivity. }
    destruct p as [| p].
    { apply mspec_mret. rewrite /recurrence_leader.size. rewrite //=. nra. }
    tbind (λ x, (sval x <= (S (S p)))%coq_nat).
    { intros (x&?) _ => //=.  nify.  omega. }
    intros (pv&Hin) _.
    rewrite //=.
    case: ifP; intros; apply mspec_mret;
    rewrite /recurrence_leader.size;
    rewrite /sval; rewrite S_INR //=;
    destruct r, p; try nra;
    try specialize (pos_INR (S p)); try nra.
    * nify. apply le_INR in Hin. rewrite //= in Hin.
    * nify. apply le_INR in Hin. rewrite ?S_INR //= in Hin. rewrite ?S_INR. done.
  - intros l ? Hgt. rewrite //=.
    cut (∀ n, 0 <= recurrence_leader.size ((rvar_of_ldist (h l) n))); first by rewrite //=.
    intros n'. apply fun_to_mspec.
    intros (r&?) ?. rewrite /recurrence_leader.size => //=. destruct r; try nra. apply pos_INR.
  - intros x n Hle.
    rewrite /T.
    cut (INR (fst x - fst (rvar_of_ldist (leader_elect (fst x) (snd x)) n)) = 0);
      first by rewrite //=.
    apply fun_to_mspec.
    destruct x as (r, p).
    destruct r as [| r].
    { rewrite leader_elect_unfold //. }
    destruct p; [| destruct p].
    rewrite //=.
    * apply mspec_mret => //=. replace 0 with (INR 0) by auto. f_equal. nify. omega.
    * apply mspec_mret => //=. replace 0 with (INR 0) by auto. f_equal. nify. omega.
    * exfalso. move : Hle.
      rewrite /leader_rec.recurrence_leader.size/leader_rec.recurrence_leader.rec_solution.d//=.
      destruct p; first nra.
      specialize (pos_INR (S p)). nra.
  - intros. apply Trec; auto.
  - rewrite /leader_rec.recurrence_leader.size/leader_rec.recurrence_leader.rec_solution.d
            /leader_rec.recurrence_leader.rec_solution.m
            /leader_rec.recurrence_leader.count_factor.alpha.
    intros.
    etransitivity; first eapply Ex_h.
    rewrite /m/rsize/size/length. do 2 destruct Rlt_dec; try nra.
  - done.
Qed.

From Interval Require Import Tactic.
Remark concrete_512:
  ∀ n, pr_gt (rvar_comp (rvar_of_ldist (leader_elect (S n) 512)) (λ x, INR (S n - fst x))) (64)
        ≤ 1/(10^5).
Proof.
  intros n.
  transitivity (pr_gt (T (S n, 512%nat)) 64).
  { rewrite /T/fst/snd. reflexivity. }
  transitivity (pr_gt (T (S n, 512%nat)) ((k * ln (rsize (S n, 512%nat)) + 1) + 41)).
  - apply Rge_le, pr_gt_contra.
    rewrite /k. rewrite /rsize/fst/snd.
    replace (INR 512) with 512; last first.
    { vm_compute. nra. }
    interval.
  - replace 41 with (INR 41); last first.
    { vm_compute. nra. }
    etransitivity; first apply bound.
    { rewrite /rsize//=. nra. }
    interval.
Qed.

Remark concrete_huge:
  ∀ players n,
    INR players = 2^32 →
    pr_gt (rvar_comp (rvar_of_ldist (leader_elect (S n) players)) (λ x, INR (S n - fst x))) (128)
        ≤ 1/(10^6).
Proof.
  intros p n Hsize.
  transitivity (pr_gt (T (S n, p)) ((k * ln (rsize (S n, p)) + 1) + 49)).
  - apply Rge_le, pr_gt_contra.
    rewrite /k. rewrite /rsize/fst/snd.
    rewrite Hsize.
    interval.
  - replace 49 with (INR 49); last first.
    { vm_compute. nra. }
    etransitivity; first apply bound.
    { rewrite /rsize//=. nra. }
    interval.
Qed.


(**
Coq-Elpi Coq項のHOASについて
=====================

@suharahiromichi

2023/1/30

2023/2/18 ProofCafe

https://qiita.com/suharahiromichi/private/23ecf3c91204d43a8b81

https://github.com/suharahiromichi/coq/blob/master/elpi/coq_elpi_hoas.v

この文書は、

Coq項のHOASについてのチュートリアル

https://qiita.com/suharahiromichi/private/62359119f7f880f94d48

からの抜粋である。
*)

(**
# はじめに

Coqの項を抽象構文木で扱う方法を勉強します。Coqの項（Gallina項と呼ぶ場合もありますが、
ここでは、Coq項で統一します）は、ELPIからみて、``term``型のデータです。

Coq項、それが型を表すものであっても、値を表すものであっても、``term``であることに違いがありません。
Coq項なので、Coqとして解釈した場合の「型」は当然ありますが、それは1階上の話になるわけです。

Coqの文法を復習してみます。Coq項の構文木の「葉」になるのは、以下のものです。

- ``Define`` や ``Inductive`` で定義されたもの。global reference と呼ばれる。
  - constant
  - inductive type
  - inductive constructor

Moduleの中で定義された場合でも、Module名を前に付けてグローバルに定義されているとします。

- Coqにあらかじめ用意されている型 (ソート)
  - Prop
  - Set
  - Type

これらは定義できませんが、``Type``は内部的には、``Type_i``のレベルi（階層）を持っています。
*)

From elpi Require Import elpi.

Elpi Command tutorial_HOAS.

(**
# Global refernce

## 定義

```
kind gref       type.
type const      constant -> gref.
type indt       inductive -> gref.
type indc       constructor -> gref.

kind term       type.
type global     gref -> term.
```
*)

(**
|id       | (‡)  　　　  | gref      | gref         | term               | term       |
|:--------|:-----------|:-----------|:-------------|:-------------------|:-----------|
|"Nat.add"| «Nat.add»  |const «Nat.add» |{{:gref Nat.add}} | global (indt «Nat.add»)| {{Nat.add}}    |
| "nat"   | «nat»      |indt «nat»  |{{:gref nat}} | global (indt «nat»)| {{nat}}    |
| "O"     | «O»        |indc «O»    |{{:gref O}}   | global (indc «O»)  | {{O}}      |

(‡) constant, inductive, constructor

``{{ ... }}`` は ``{{:coq ... }}`` の略。
*)

(**
## ELPIの組込述語

```
typeabbrev id string.

pred coq.locate i:id, o:gref.
pred coq.env.typeof i:gref, o:term.
```

coq.locate は、idを環境から検索する。
*)

Elpi Query lp:{{
  coq.locate "Nat.add" Gadd,      /* Gadd = const «Nat.add» */
  coq.env.typeof Gadd Ty.
}}.
(**
```
Ty = prod `n` (global (indt «nat»))
       c0 \ prod `m` (global (indt «nat»))
       　　　c1 \ global (indt «nat»)
```

これは ``Π n:nat, Π m:nat, nat`` のことで、
``n``と``m``が出現しない（依存型ではない）ので、
``nat -> nat -> nat`` と書くことができる。
*)

Elpi Query lp:{{
  coq.locate "nat" Gnat,          /* Gnat = indt «nat» */
  coq.env.typeof Gnat Ty.         /* Ty = sort (typ «Set») */
}}.

Elpi Query lp:{{
  coq.locate "O" GO,              /* GO = indc «O» */
  coq.env.typeof GO Ty.           /* Ty = global (indt «nat» */
}}.

(**
# Sort

## 定義

```
kind sort       type.
type typ        univ -> sort.
type prop       sort.
type sprop      sort.

type sort       sort -> term.
```
*)

(**
| univ    　| sort          | term                | term       |
|:----------|:-------------|:---------------------|:-----------|
| «set»     | typ «set»     | sort (typ «set»)    | {{Set}}    |
| -         | prop          | sort prop           | {{Prop}}   |
| -         | sprop         | sort sprop          | {{SProp}}  |
| «tut.19»  | typ «tut.19»  | sort (typ «tut.19») | {{Type}}   |
*)

(**
補足説明： SPropとはイレバンスの成り立つ型
*)
Goal forall P : SProp, P -> P.
Proof.
  easy.
Qed.

Theorem irrelevance (A : SProp) (P : A -> Prop)
  : forall x : A, P x -> forall y : A, P y.
Proof.
  intros.
  easy.
Qed.

(**
## ELPIの組込述語

```
pred coq.sort.leq o:sort, o:sort.     (* <= *)
pred coq.sort.eq o:sort, o:sort.      (* = *)
pred coq.sort.sup o:sort, o:sort.     (* < *)
```
*)

(**
# Coq項を構成するELPIのコンストラクタ

``fun (x : T) => E`` などの、coq項を構成する構造は、ELPIのコンストラクタとして定義されます。
原則として、coq項からcoq項を組み立てるのですが、CoqのGoalを表示するための表示名としてnameをとるものもあります。
この表示名は、HOASの処理としては、機能しません。

```
type app        list term -> term.
type fun        name -> term -> (term -> term) -> term.
type prod       name -> term -> (term -> term) -> term.
type fix        name -> int -> term -> (term -> term) -> term.
type match      term -> term -> list term -> term.
type let        name -> term -> term -> (term -> term) -> term.
```
*)

(**
# Context

```
prod と同じだが、predとして実行される。
type @pi-decl   name -> term -> (term -> term) -> pred.

let と同じだが、predとして実行される。
type @pi-def    name -> term -> term -> (term -> term) -> pred.
```
*)

Elpi Query lp:{{
  T = {{ fun x : nat => x + 1 }},
  coq.typecheck T _ ok,
  T =  fun N Ty Bo,
                   /* ここの括弧は省略できる */
  @pi-decl N Ty (x\ coq.typecheck (Bo x) _ ok)
}}.

Elpi Query lp:{{
  T = {{ fun x : nat => x + 1 }},
  coq.typecheck T _ ok,
  T =  fun N Ty Bo,
                     /* ここの括弧は省略できる */
  @pi-def N Ty {{1}} (x\ coq.typecheck (Bo x) _ ok)
}}.

(**
# 次回の予習

Coqの``Difinition``や``Inductive``に関する事項は、``coq_elpi_command.v``で扱います。

Coqで定義された定義の中身を取り出すには、``coq.env.const`` を
つかいますが、これには、termやgrefではなく、constant を与えることに注意してください。

同様にInductiveで定義された定義の中身を取り出すには、``coq.env.indt-decl`` を
つかいます。inductive を与えます。
*)

Print Nat.add.
Elpi Query lp:{{
  coq.locate "Nat.add" (const F),
% {{:gref Nat.add}} = const F,
  coq.env.const F (some Bo) Ty,
  coq.say "Body=" Bo,
  coq.say "Type=" Ty
}}.

Print nat.
Elpi Query lp:{{
  coq.locate "nat" (indt Indt),
% {{:gref nat}} = indt Indt,
  coq.env.indt-decl Indt Decl,
  coq.say "Indt=" Indt,
  coq.say "Decl=" Decl
}}.

(**
# 練習問題

factrial を定義して、そのCoq項の HOASを取り出してください。
*)

Fixpoint f n :=
  match n with
  | 0 => 1
  | S n => S n * f n
 end.

 Elpi Query lp:{{
% coq.locate "f" (const F),
  {{f}} = global (const F),
  coq.env.const F (some Bo) Ty,
  coq.say "Body=" Bo,
  coq.say "Type=" Ty
}}.

(**
答え：
```
fix `f` 0 (prod `n` (global (indt «nat»)) c0 \ global (indt «nat»))
      c0 \ fun `n` (global (indt «nat»))
        c1 \ match c1 (fun `n` (global (indt «nat»)) c2 \ global (indt «nat»))
              [app [global (indc «S»), global (indc «O»)],    % 1st case
               fun `n` (global (indt «nat»))                  % 2nd case
                 c2 \ app [global (const «Nat.mul»),
                           app [global (indc «S»), c2],
                           app [c0, c2]]]
```
*)

(**
別の例：
*)
Inductive windrose := N | E | W | S.

Definition w (x : windrose) :=
  match x with | N => 0  | E => 1 | W => 2 | S => 3 end.
Elpi Query lp:{{
  coq.locate "w" (const F),
  coq.env.const F (some Bo) Ty
}}.

(* END *)


(* 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                                                     *)

(**********************************************************************
    Permutation.v

    Definition and properties of permutations

    Definition: permutation

                                    Laurent.Thery@inria.fr (2006)
 **********************************************************************)
Require Export List.
Require Export ListAux.
From Coq Require Export Permutation.

Section permutation.
Variable A : Set.

Hint Constructors Permutation : core.

(**************************************
 A transposition is a permutation
 **************************************)

Theorem perm_transposition :
  forall a b (l1 l2 l3 : list A),
    Permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3).
Proof.
  intros a b l1 l2 l3.
  apply Permutation_app; auto.
  change
    (Permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3)
                 ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *.
  repeat rewrite <- app_ass.
  apply Permutation_app; auto.
  apply perm_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto.
  apply Permutation_app_comm; auto.
  repeat rewrite app_ass.
  apply Permutation_app; auto.
  apply Permutation_app_comm; auto.
Qed.

(**************************************
 An element of a list can be put on top of the list to get a permutation
 **************************************)

Theorem in_permutation_ex :
  forall a l, In a l -> exists l1 : list A, Permutation (a :: l1) l.
Proof.
  intros a l; elim l; simpl in |- *; auto.
  intros H; case H; auto.
  intros a0 l0 H [H0| H0].
  exists l0; rewrite H0; auto.
  case H; auto; intros l1 Hl1; exists (a0 :: l1).
  apply perm_trans with (a0 :: a :: l1); auto.
Qed.

(**************************************
 Take a list and return tle list of all pairs of an element of the
 list and the remaining list
 **************************************)

Fixpoint split_one (l : list A) : list (A * list A) :=
  match l with
  | nil => nil (A:=A * list A)
  | a :: l1 =>
    (a, l1)
      :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1)
  end.

(**************************************
 The pairs of the list are a permutation
 **************************************)

Theorem split_one_permutation :
  forall (a : A) (l1 l2 : list A),
    In (a, l1) (split_one l2) -> Permutation (a :: l1) l2.
Proof.
  intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto.
  intros a l1 H1; case H1.
  intros a l H a0 l1 [H0| H0].
  injection H0; intros H1 H2; rewrite H2, H1; auto.
  generalize H H0; elim (split_one l); simpl in |- *; auto.
  intros H1 H2; case H2.
  intros a1 l0 H1 H2 [H3| H3]; auto.
  injection H3; intros H4 H5; (rewrite <- H4, <- H5).
  apply perm_trans with (a :: fst a1 :: snd a1); auto.
  apply perm_skip.
  apply H2; auto.
  case a1; simpl in |- *; auto.
Qed.

(**************************************
 All elements of the list are there
 **************************************)

Theorem split_one_in_ex :
  forall (a : A) (l1 : list A),
    In a l1 -> exists l2 : list A, In (a, l2) (split_one l1).
Proof.
  intros a l1; elim l1; simpl in |- *; auto.
  intros H; case H.
  intros a0 l H [H0| H0]; auto.
  exists l; left; f_equal; auto.
  case H; auto.
  intros x H1; exists (a0 :: x); right; auto.
  apply
    (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x));
    auto.
Qed.

(**************************************
 An auxiliary function to generate all permutations
 **************************************)

Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} :
  list (list A) :=
  match n with
  | O => nil :: nil
  | S n1 =>
    flat_map
      (fun p : A * list A =>
         map (cons (fst p)) (all_permutations_aux (snd p) n1)) (
        split_one l)
  end.
(**************************************
 Generate all the permutations
 **************************************)

Definition all_permutations (l : list A) := all_permutations_aux l (length l).

(**************************************
 All the elements of the list are permutations
 **************************************)

Lemma all_permutations_aux_permutation :
  forall (n : nat) (l1 l2 : list A),
    n = length l2 -> In l1 (all_permutations_aux l2 n) -> Permutation l1 l2.
Proof.
  intros n; elim n; simpl in |- *; auto.
  intros l1 l2; case l2.
  simpl in |- *; intros H0 [H1| H1].
  rewrite <- H1; auto.
  case H1.
  simpl in |- *; intros; discriminate.
  intros n0 H l1 l2 H0 H1.
  case in_flat_map_ex with (1 := H1).
  clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2).
  case in_map_inv with (1 := H2).
  simpl in |- *; intros y (H3, H4).
  rewrite H4; auto.
  apply perm_trans with (a1 :: l3); auto.
  apply perm_skip; auto.
  apply H with (2 := H3).
  apply eq_add_S.
  apply trans_equal with (1 := H0).
  change (length l2 = length (a1 :: l3)) in |- *.
  apply Permutation_length; auto.
  apply Permutation_sym; apply split_one_permutation; auto.
  apply split_one_permutation; auto.
Qed.

Theorem all_permutations_permutation :
  forall l1 l2 : list A, In l1 (all_permutations l2) -> Permutation l1 l2.
Proof.
  intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2);
    auto.
Qed.

(**************************************
 A permutation is in the list
 **************************************)

Lemma permutation_all_permutations_aux :
  forall (n : nat) (l1 l2 : list A),
    n = length l2 -> Permutation l1 l2 -> In l1 (all_permutations_aux l2 n).
Proof.
  intros n; elim n; simpl in |- *; auto.
  intros l1 l2; case l2.
  intros H H0; rewrite (Permutation_nil (Permutation_sym H0)); auto with datatypes.
  simpl in |- *; intros; discriminate.
  intros n0 H l1; case l1.
  intros l2 H0 H1;
    rewrite (Permutation_nil H1) in H0;
    discriminate.
  clear l1; intros a1 l1 l2 H1 H2.
  case (split_one_in_ex a1 l2); auto.
  apply Permutation_in with (1 := H2); auto with datatypes.
  intros x H0.
  apply in_flat_map with (b := (a1, x)); auto.
  apply in_map; simpl in |- *.
  apply H; auto.
  apply eq_add_S.
  apply trans_equal with (1 := H1).
  change (length l2 = length (a1 :: x)) in |- *.
  apply Permutation_length; auto.
  apply Permutation_sym; apply split_one_permutation; auto.
  apply Permutation_cons_inv with (a := a1).
  apply perm_trans with (1 := H2).
  apply Permutation_sym; apply split_one_permutation; auto.
Qed.

Theorem permutation_all_permutations :
  forall l1 l2 : list A, Permutation l1 l2 -> In l1 (all_permutations l2).
Proof.
  intros l1 l2 H; unfold all_permutations in |- *;
    apply permutation_all_permutations_aux; auto.
Qed.

(**************************************
 Permutation is decidable
 **************************************)

Definition permutation_dec :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {Permutation l1 l2} + {~ Permutation l1 l2}.
  intros H l1 l2.
  case (In_dec (list_eq_dec H) l1 (all_permutations l2)).
  intros i; left; apply all_permutations_permutation; auto.
  intros i; right; contradict i; apply permutation_all_permutations; auto.
Defined.

(* A more efficient version *)
Definition permutation_dec1 :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {Permutation l1 l2} + {~ Permutation l1 l2}.
intros dec; fix perm 1; intros l1; case l1.
intros l2; case l2.
left; auto.
intros a l3; right; intros H; generalize (Permutation_length H);
 discriminate.
intros a l3 l2.
case (In_dec1 dec a l2); intros H1.
case H1.
intros x; case x; simpl.
intros l4 l5 Hl4l5.
case (perm l3 (l4 ++ l5)); intros H2.
left; subst.
apply perm_trans with ((a::l5) ++ l4); auto.
simpl; apply perm_skip; auto.
apply perm_trans with (1 := H2); auto.
apply Permutation_app_comm.
apply Permutation_app_comm.
right; contradict H2.
apply Permutation_cons_inv with a.
apply perm_trans with (1 := H2).
rewrite Hl4l5.
apply perm_trans with ((a::l5) ++ l4); auto.
apply Permutation_app_comm.
simpl; apply perm_skip; auto.
apply Permutation_app_comm.
right; contradict H1.
apply Permutation_in with (1 := H1); auto with datatypes.
Defined.

End permutation.

(**************************************
   Hints
 **************************************)

Global Hint Resolve Permutation_app : core.
Global Hint Resolve Permutation_app_comm : core.

(**************************************
   Implicits
 **************************************)

Arguments permutation_dec1 [A].

(**************************************
  Permutation  of a map can be inverted
 *************************************)

Lemma Permutation_map_ex_aux :
  forall (A B : Set) (f : A -> B) l1 l2 l3,
    Permutation l1 l2 ->
    l1 = map f l3 -> exists l4, Permutation l4 l3 /\ l2 = map f l4.
Proof.
  intros A B f l1 l2 l3 H H0.
  assert (exists l4 : list A, l2 = map f l4 /\ Permutation l4 l3).
  {
    rewrite H0 in H.
    apply Permutation_sym in H.
    epose proof (Permutation_map_inv f _ H).
    destruct H1; auto.
    now exists x.
  }
  destruct H1.
  now exists x.
Qed.

Theorem Permutation_map_ex :
  forall (A B : Set) (f : A -> B) l1 l2,
    Permutation (map f l1) l2 ->
    exists l3, Permutation l3 l1 /\ l2 = map f l3.
Proof.
  intros A0 B f l1 l2 H; apply Permutation_map_ex_aux with (l1 := map f l1);
    auto.
Qed.

(**************************************
   Permutation is compatible with flat_map
 **************************************)

Theorem permutation_flat_map :
  forall (A B : Set) (f : A -> list B) l1 l2,
    Permutation l1 l2 -> Permutation (flat_map f l1) (flat_map f l2).
Proof.
  intros A B f l1 l2 H; elim H; simpl in |- *; auto.
  intros a b l; auto.
  repeat rewrite <- app_ass.
  apply Permutation_app; auto.
  intros k3 l4 l5 H0 H1 H2 H3; apply perm_trans with (1 := H1); auto.
Qed.


Lemma top_winning_strategy {p} {s : strategy top p}
 : winning_strategy s <-> p = player_P.
Proof.
  unfold winning_strategy.
  setoid_rewrite top_play_won_by.
  firstorder.
  eapply H.
  apply top_player_follows_strategy.
  Unshelve.
  exact trivial_play.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a}(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive color  :=
  | Blue : color
  | White : color
  | Red : color .
Axiom color_WhyType : WhyType color.
Existing Instance color_WhyType.

(* Why3 assumption *)
Definition monochrome(a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color): Prop :=
  forall (k:Z), ((i <= k)%Z /\ (k < j)%Z) -> ((map.Map.get a k) = c).

Parameter nb_occ: (map.Map.map Z color) -> Z -> Z -> color -> Z.

Axiom nb_occ_null : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  (j <= i)%Z -> ((nb_occ a i j c) = 0%Z).

Axiom nb_occ_add_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (c:color),
  ((i < j)%Z /\ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a i j
  c) = ((nb_occ a i (j - 1%Z)%Z c) + 1%Z)%Z).

Axiom nb_occ_add_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (c:color), ((i < j)%Z /\ ~ ((map.Map.get a (j - 1%Z)%Z) = c)) -> ((nb_occ a
  i j c) = (nb_occ a i (j - 1%Z)%Z c)).

Axiom nb_occ_split : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ a i k c) = ((nb_occ a i j
  c) + (nb_occ a j k c))%Z).

Axiom nb_occ_store_outside_up : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (k:Z) (c:color), ((i <= j)%Z /\ (j <= k)%Z) -> ((nb_occ (map.Map.set a k c)
  i j c) = (nb_occ a i j c)).

Axiom nb_occ_store_outside_down : forall (a:(map.Map.map Z color)) (i:Z)
  (j:Z) (k:Z) (c:color), ((k < i)%Z /\ (i <= j)%Z) -> ((nb_occ (map.Map.set a
  k c) i j c) = (nb_occ a i j c)).

Axiom nb_occ_store_eq_eq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z) (k:Z)
  (c:color), ((i <= k)%Z /\ (k < j)%Z) -> (((map.Map.get a k) = c) ->
  ((nb_occ (map.Map.set a k c) i j c) = (nb_occ a i j c))).

Open Scope Z_scope.
Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.95.2," timelimit 15.

(* Why3 goal *)
Theorem nb_occ_store_eq_neq : forall (a:(map.Map.map Z color)) (i:Z) (j:Z)
  (k:Z) (c:color), ((i <= k)%Z /\ (k < j)%Z) -> ((~ ((map.Map.get a
  k) = c)) -> ((nb_occ (map.Map.set a k c) i j c) = ((nb_occ a i j
  c) + 1%Z)%Z)).
intros a i j k c (Hik & Hkj) H.
rewrite nb_occ_split with (j:=k); auto with zarith.
rewrite nb_occ_store_outside_up; auto with zarith.
rewrite nb_occ_split with (i:=k) (j:=k+1); auto with zarith.
rewrite nb_occ_split with (i:=i) (j:=k) (k:=j); auto with zarith.
rewrite nb_occ_split with (i:=k) (j:=k+1) (k:=j); auto with zarith.
rewrite nb_occ_store_outside_down with (i:=k+1); auto with zarith.
ae.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Inductive TwoObj : Type := TwoX | TwoY.

Inductive TwoHom : TwoObj -> TwoObj -> Type :=
| TwoIdX : TwoHom TwoX TwoX
| TwoIdY : TwoHom TwoY TwoY
| TwoXY  : TwoHom TwoX TwoY.

Definition TwoHom_inv_t : forall x y, TwoHom x y -> Prop.
Proof. hammer_hook "Two" "Two.TwoHom_inv_t".
intros [] [] f.
exact (f = TwoIdX).
exact (f = TwoXY).
exact False.
exact (f = TwoIdY).
Defined.

Corollary TwoHom_inv x y f : TwoHom_inv_t x y f.
Proof. hammer_hook "Two" "Two.TwoHom_inv". destruct f; reflexivity. Qed.

Lemma TwoHom_Y_X_absurd : TwoHom TwoY TwoX -> False.
Proof. hammer_hook "Two" "Two.TwoHom_Y_X_absurd". inversion 1. Qed.

Hint Extern 4 => contradiction TwoHom_Y_X_absurd : two_laws.

Program Definition _2 : Category := {|
obj     := TwoObj;
hom     := TwoHom;
homset  := Morphism_equality;
id      := fun x => match x with
| TwoX => TwoIdX
| TwoY => TwoIdY
end;
compose := fun x y z (f : TwoHom y z) (g : TwoHom x y) =>
match x, y, z with
| TwoX, TwoX, TwoX => TwoIdX
| TwoY, TwoY, TwoY => TwoIdY
| TwoX, TwoX, TwoY => TwoXY
| TwoX, TwoY, TwoY => TwoXY
| _,    _,    _    => _
end
|}.
Next Obligation. destruct x, y, z; intuition. Qed.
Next Obligation.
destruct x, y, z; auto with two_laws;
intuition; discriminate.
Qed.
Next Obligation.
destruct x, y, z; auto with two_laws;
intuition; discriminate.
Qed.
Next Obligation.
destruct x, y, z; auto with two_laws;
intuition; discriminate.
Qed.
Next Obligation. destruct f; auto. Qed.
Next Obligation. destruct f; auto. Qed.
Next Obligation. destruct x, y, z, w; auto with two_laws; intuition. Qed.
Next Obligation. destruct x, y, z, w; auto with two_laws; intuition. Qed.

Require Import Category.Instance.Sets.

Program Definition _2_as_Set : _2 ⟶ Sets := {|
fobj := fun x =>
match x with
| TwoX => {| carrier := False |}
| TwoY => {| carrier := True |}
end;
fmap := fun x y f =>
match x, y with
| TwoY, TwoY => _
| _, _       => _
end
|}.
Next Obligation.
construct.
- repeat intro.
contradiction.
- equivalence.
Defined.
Next Obligation.
construct.
- repeat intro.
exact True.
- equivalence.
Defined.
Next Obligation.
construct; auto.
Defined.
Next Obligation.
construct; auto.
destruct x, y; simpl in *; auto with two_laws.
proper.
destruct x, y; simpl in *; auto with two_laws.
Qed.
Next Obligation.
destruct x; simpl in *; auto with two_laws.
contradiction.
Qed.
Next Obligation.
destruct x, y, z; simpl in *; auto with two_laws.
contradiction.
Qed.


(* 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)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  rat.v                                                                   *)
(*                                                                          *)
(*  Summary of rational arithmetic                                          *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                rat.v                                     *)
(****************************************************************************)

Require Import quotient.
Require Import subset.
Require Import intnumbers.
Require Export rational_defs.
Require Export PlusQ.
Require Export MultQ.
Require Import AC.
Require Import HS.

Section rat.

(*******************************************************************
PROPERTIES OF Q
********************************************************************

plusQ_sym     : (n,m:Q)                       n + m = m + n
plusQ_assoc_l : (n,m,p:Q)              n + (m + p) = (n + m) + p
plusQ_permute : (n,m,p:Q)              n + (m + p) = m + (n + p)
plusQ_assoc_r : (n,m,p:Q)              (n + m) + p = n + (m + p)
plusQ_plus_l  : (n,m,p:Q)               n + m = n + p =>  m = p

multQ_sym         : (n,m:Q)                   n*m = m*n
multQ_assoc_l     : (n,m,p:Q)             n*(m*p) = (n*m)*p
multQ_permute     : (n,m,p:Q)             n*(m*p) = m*(n*p)
multQ_assoc_r     : (n,m,p:Q)             (n*m)*p = n*(m*p)

distribQ_l : (n,m,p:Q)           (n + m)*p = (n*p) + (m*p)
distribQ   : (n,m,p:Q)           p*(n + m) = (p*n) + (p*m).

*********************************************************************)

(* Tactiques de d'ecision AC pour l'addition sur Q.*)

Open Scope RAT_scope.

Lemma plusQ_simpl_l : forall n m p : Q, m = p -> n + m = n + p.
intros. elim H. auto. Qed.

Lemma multQ_simpl_l : forall n m p : Q, m = p -> n * m = n * p.
intros. elim H. auto. Qed.

End rat.

Ltac CQa := intros; ac_of eq plusQ plusQ_sym plusQ_permute; auto.

Ltac AQa := intros; repeat elim plusQ_assoc_l.

Ltac ACQa :=
  intros; repeat elim plusQ_assoc_l; ac_of eq plusQ plusQ_sym plusQ_permute;
   auto.

Ltac HSQa := intros; hs_of eq plusQ plusQ_sym plusQ_permute plusQ_simpl_l.

(* Tactiques de d'ecision AC pour la multiplication sur Z.*)

Ltac CQm := intros; ac_of eq multQ multQ_sym multQ_permute; auto.

Ltac AQm := intros; repeat elim multQ_assoc_l.

Ltac ACQm :=
  intros; repeat elim multQ_assoc_l; ac_of eq multQ multQ_sym multQ_permute;
   auto.

Ltac HSQm := intros; hs_of eq multQ multQ_sym multQ_permute multQ_simpl_l.