Require Import Enumerable.
Require Import List.
Import ListNotations.
Require Import Monad.
Require Import ListEx.
Require Import EqDec.
Require Import Misc.
Require Import Graph.
Require Import Category.
Require Import Coq.
Require Import Co.

Set Universe Polymorphism.

Section Diagram.

Context `{Category}.

Class Diagram := {
  Vertex : Type;
  vertexObject : Vertex -> object;
  Arrow : Vertex -> Vertex -> Type;
  arrowMorphism {a b} : Arrow a b -> (vertexObject a) → (vertexObject b)
}.

Variable D:Diagram.
Context `{eqDec Vertex}.
Context `{enumerable Vertex}.
Context `{forall v v', enumerable (Arrow v v')}.

Instance diagramGraph : Graph := {|
  Graph.Vertex := Vertex;
  Graph.Edge := Arrow
|}.

Definition vertices := @enumerate Vertex _.
Definition edges v v' := @enumerate (Edge v v') _.

Fixpoint composePath {s d} (p:Path s d) : vertexObject s → vertexObject d :=
  match p in Path s d return vertexObject s → vertexObject d with
  | refl => id
  | step a p' => arrowMorphism a ∘ composePath p'
  end.

Definition listPaths s : list {d : Vertex & Path s d}.
  refine ((fix rec fuel := match fuel
  return forall v, list {d : Vertex & Path v d} with
  | 0 => fun _ => []
  | S fuel => fun v => _
  end) (List.length vertices) s).
  clear s.
  refine ([v & refl]::_).
  refine (d <- vertices;; _).
  refine (e <- edges v d;; _).
  refine (P <- rec fuel d;; _).
  refine (ret [projT1 P & step e (projT2 P)]).
Defined.

Definition groupBy {A C} `{eqDec A} `{enumerable A} {B:A->Type} (l:list (sigT B)) (f:forall a:A, list (B a) -> C) : list C.
  refine (a <- enumerate;; _).
  refine (ret (f a _)).
  refine (e <- l;; _).
  destruct e as [a' b].
  refine (if a =? a' then ret _ else []).
  subst.
  exact b.
Defined.

Definition nonsymmetricNonreflexiveCrossproduct {A} (l:list A) : list (A * A).
  refine ((fix rec l :=
    match l with
    | [] => []
    | a::l' => _ ++ rec l'
    end) l).
  refine ((fix rec' l :=
    match l with
    | [] => []
    | a'::l' => (a,a') :: rec' l'
    end) l').
Defined.

Definition denote : Prop.
  refine ((fix rec (l:list Prop) := match l with
    | [] => True
    | [h] => h
    | h::l' => h /\ rec l'
    end) _).
  refine (v <- @enumerate Vertex _;; _).
  refine (concat (groupBy (listPaths v) (fun v' ps => _))).
  refine (_ <$> nonsymmetricNonreflexiveCrossproduct ps).
  intros [P Q].
  refine (composePath P = composePath Q).
Defined.

Lemma denoteDiagramCommutative : denote <-> forall s d (P Q:Path s d), composePath P = composePath Q.
Admitted.

End Diagram.


Require Import Rsequence.
Require Import Rseries_def Rseries_base_facts Rseries_pos_facts Rseries_cv_facts.

Require Import Lra Rtactic.

Local Open Scope R_scope.
Local Open Scope Rseq_scope.

Lemma Rser_cv_square_inv : {l | Rser_cv (fun i => / (Rseq_shift INR i) ^ 2)%R l}.
Proof.
apply Rser_cv_sig_shift_rev.
apply Rser_pos_maj_cv with (/ (Rseq_shift INR * Rseq_shifts INR 2)).
 intro n ; left ; apply Rinv_0_lt_compat, pow_lt, lt_0_INR, lt_O_Sn.
 intro n ; left ; apply Rinv_0_lt_compat, Rmult_lt_0_compat ; apply lt_0_INR, lt_O_Sn.
 intro p ; unfold Rseq_shift, Rseq_shifts, Rseq_mult, Rseq_inv, pow ;
 rewrite Rmult_1_r, Rinv_mult_distr, Rinv_mult_distr ;
 try (now (apply Rgt_not_eq, lt_0_INR, lt_0_Sn)).
 apply Rmult_le_compat ; try (now (left ; apply Rinv_0_lt_compat, lt_0_INR, lt_0_Sn)).
  apply Rle_Rinv ; try (now (apply lt_0_INR, lt_O_Sn)) ; apply le_INR ; apply le_n_Sn.
  reflexivity.
 exists 1 ; apply Rseq_cv_eq_compat with (1 - (/ Rseq_shifts INR 2)).
  intro p ; unfold Rseq_minus, Rseq_constant ; induction p.
  unfold Rseq_mult, Rseq_inv, Rseq_shift, Rseq_shifts ; simpl ; field.
  rewrite Rseq_sum_simpl, IHp ; unfold Rseq_constant, Rseq_mult, Rseq_inv,
  Rseq_shifts, Rseq_shift, Rminus ; rewrite Rplus_assoc ; apply Rplus_eq_compat_l.
  simpl ; field ; split ; apply Rgt_not_eq.
  destruct p ; [| assert (H := lt_0_INR _ (lt_0_Sn p))] ; lra.
  destruct p ; [| assert (H := lt_0_INR _ (lt_0_Sn p))] ; lra.
  rewrite <- Rminus_0_r ; apply Rseq_cv_minus_compat ; [apply Rseq_constant_cv |].
   apply Rseq_cv_pos_infty_inv_compat ; eapply Rseq_cv_pos_infty_eq_compat ;
   [| eapply Rseq_cv_finite_plus_pos_infty_l ; [eapply (Rseq_poly_cv 1) |
   eexact (Rseq_constant_cv 2)]].
  intro p ; unfold Rseq_shifts, Rseq_poly, Rseq_plus, Rseq_constant, pow ;
   rewrite plus_INR ; simpl ; ring.
  apply lt_O_Sn.
Qed.

Lemma Rser_cv_inv_poly : forall d, (2 <= d)%nat -> {l | Rser_abs_cv (Rseq_inv_poly d) l}.
Proof.
intros d Hd.
unfold Rser_abs_cv.
cut ({l | Rser_cv (Rseq_inv_poly d) l}).
 intros [l Hl]; exists l.
 eapply Rser_cv_eq_compat; [|apply Hl]; intro i.
 destruct i; unfold Rseq_abs; symmetry; apply Rabs_right.
  apply Rle_refl.

  unfold Rseq_inv_poly.
  apply Rle_ge; apply pow_le.
  apply Rlt_le; apply Rinv_0_lt_compat; INR_solve.

apply Rser_pos_maj_cv_shift with (fun (i : nat) => (/ (INR (S i) ^ 2))%R).
 unfold Rseq_inv_poly; intro n; rewrite <- Rinv_pow; [|INR_solve].
 split.
  apply Rlt_le; apply Rinv_0_lt_compat; apply pow_lt; INR_solve.
  apply Rle_Rinv.
   unfold pow; INR_solve; simpl mult; apply lt_O_Sn.
   apply pow_lt; INR_solve.
  apply Rle_pow; auto; INR_solve.
apply Rser_cv_square_inv.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : lst) (x : lst) : lst := append (append x lf1) Nil.


Require Import primRec.
Require Import cPair.
Require Export Coq.Lists.List.
Require Import ListExt.
Require Import Arith.
Require Vector.
Require Import extEqualNat.
Require Import Compat815.

Definition codeLength : nat -> nat :=
  evalStrongRec 0
    (fun n Hrecs : nat =>
     switchPR n (S (codeNth (n - S (cPairPi2 (pred n))) Hrecs)) 0).

Lemma codeLengthCorrect :
 forall l : list nat, codeLength (codeList l) = length l.
Proof.
  induction l as [| a l Hrecl].
  - reflexivity.
  - simpl; unfold codeLength.
    set (f :=
           fun n Hrecs : nat =>
             switchPR n (S (codeNth (n - S (cPairPi2 (pred n))) Hrecs)) 0)
      in *.
    unfold evalStrongRec, evalComposeFunc, evalOneParamList, evalList.
    rewrite computeEvalStrongRecHelp.
    unfold compose2, evalComposeFunc, evalList, f.
    rewrite evalStrongRecHelp1; simpl.
    + rewrite cPairProjections1.
      apply eq_S.
      rewrite cPairProjections2; apply Hrecl; simpl.
    + apply Compat815.le_lt_n_Sm.
      generalize (cPair a (codeList l)); intro n.
      apply Nat.le_trans with (cPair (cPairPi1 n) (cPairPi2 n)).
      * apply cPairLe2.
      * rewrite cPairProjections; apply le_n.
Qed.

Lemma codeLengthIsPR : isPR 1 codeLength.
Proof.
  unfold codeLength in |- *.
  apply evalStrongRecIsPR.
  apply
    compose2_3IsPR
    with
    (f1 := fun n Hrecs : nat => n)
    (f2 := fun n Hrecs : nat =>
             S (codeNth (n - S (cPairPi2 (pred n))) Hrecs))
    (f3 := fun n Hrecs : nat => 0).
  - apply pi1_2IsPR.
  - apply compose2_1IsPR with
      (f := fun n Hrecs : nat =>
              codeNth (n - S (cPairPi2 (pred n))) Hrecs).
    + apply compose2_2IsPR with
        (f := fun n Hrecs : nat => n - S (cPairPi2 (pred n)))
        (g := fun n Hrecs : nat => Hrecs).
      * apply filter10IsPR with
          (g := fun n : nat => n - S (cPairPi2 (pred n))).
        apply compose1_2IsPR
          with (f := fun n : nat => n)
               (f' := fun n : nat => S (cPairPi2 (pred n))).
        -- apply idIsPR.
        -- apply compose1_1IsPR with
             (f := fun n : nat => cPairPi2 (pred n)).
           ++ apply compose1_1IsPR.
              apply predIsPR.
              apply cPairPi2IsPR.
           ++ apply succIsPR.
        -- apply minusIsPR.
      * apply pi2_2IsPR.
      * apply codeNthIsPR.
    + apply succIsPR.
  - apply filter10IsPR with (g := fun _ : nat => 0).
    apply const1_NIsPR.
  - apply switchIsPR.
Qed.

Definition codeApp : nat -> nat -> nat :=
  evalStrongRec 1
    (fun n Hrecs p1 : nat =>
       switchPR n
         (S
            (cPair (cPairPi1 (pred n))
               (codeNth (n - S (cPairPi2 (pred n))) Hrecs))) p1).

Lemma codeAppCorrect (l1 l2 : list nat):
 codeApp (codeList l1) (codeList l2) = codeList (l1 ++ l2).
Proof.
   unfold codeApp;
     set
       (f :=
          fun n Hrecs p1 : nat =>
            switchPR n
              (S
                 (cPair (cPairPi1 (pred n))
                    (codeNth (n - S (cPairPi2 (pred n))) Hrecs))) p1).
   induction l1 as [| a l1 Hrecl1].
   - unfold evalStrongRec; simpl.
     now rewrite cPairProjections1.
   - simpl; unfold evalStrongRec; unfold evalComposeFunc.
     unfold evalOneParamList; rewrite computeEvalStrongRecHelp.
     unfold f at 2 ; unfold pred.
     set (n := S (cPair a (codeList l1))) in *; simpl.
     repeat rewrite cPairProjections1 || rewrite cPairProjections2.
     replace (codeList (l1 ++ l2)) with
       (codeNth (cPair a (codeList l1) - codeList l1)
          (evalStrongRecHelp 1 f n (codeList l2))).
     + reflexivity.
     + assert
      (H: extEqual 1
         (evalComposeFunc 1 1
            (Vector.cons _ (evalStrongRecHelp 1 f n) 0 (Vector.nil _))
            (fun b : nat => codeNth (n - S (codeList l1)) b))
         (evalStrongRec 1 f (codeList l1))).
       { apply (evalStrongRecHelp2 1).
         unfold n in |- *.
         apply Compat815.le_lt_n_Sm.
         apply cPairLe2.
       }
       simpl in H; rewrite H; auto.
Qed.

Lemma codeAppIsPR : isPR 2 codeApp.
Proof.
  unfold codeApp; apply evalStrongRecIsPR.
  apply compose3_3IsPR   with
    (f1 := fun n Hrecs p1 : nat => n)
    (f2 := fun n Hrecs p1 : nat =>
             S
               (cPair (cPairPi1 (pred n))
                  (codeNth (n - S (cPairPi2 (pred n))) Hrecs)))
    (f3 := fun n Hrecs p1 : nat => p1).
  - apply pi1_3IsPR.
  - apply filter110IsPR with
      (g := fun n Hrecs : nat =>
              S
                (cPair (cPairPi1 (pred n))
                   (codeNth (n - S (cPairPi2 (pred n))) Hrecs))).
    apply compose2_1IsPR with
      (g := S)
      (f := fun n Hrecs : nat =>
              cPair (cPairPi1 (pred n))
                (codeNth (n - S (cPairPi2 (pred n))) Hrecs)).
    +  apply compose2_2IsPR with
         (h := cPair)
         (f := fun n Hrecs : nat => cPairPi1 (pred n))
         (g := fun n Hrecs : nat =>
                 codeNth (n - S (cPairPi2 (pred n))) Hrecs).
       * apply filter10IsPR with (g := fun n : nat => cPairPi1 (pred n)).
         apply compose1_1IsPR.
         -- apply predIsPR.
         -- apply cPairPi1IsPR.
       * apply compose2_2IsPR with
           (h := codeNth)
           (f := fun n Hrecs : nat => n - S (cPairPi2 (pred n)))
           (g := fun n Hrecs : nat => Hrecs).
         -- apply filter10IsPR with
              (g := fun n : nat => n - S (cPairPi2 (pred n))).
            apply compose1_2IsPR with
              (g := minus)
              (f := fun n : nat => n)
              (f' := fun n : nat => S (cPairPi2 (pred n))).
            ++ apply idIsPR.
            ++ apply compose1_1IsPR with
                 (g := S) (f := fun n : nat => cPairPi2 (pred n)).
               apply compose1_1IsPR.
               ** apply predIsPR.
               ** apply cPairPi2IsPR.
               ** apply succIsPR.
            ++ apply minusIsPR.
         -- apply pi2_2IsPR.
         -- apply codeNthIsPR.
       * apply cPairIsPR.
    + apply succIsPR.
  - apply pi3_3IsPR.
  - apply switchIsPR.
Qed.

Definition codeListRemove (a l : nat) : nat :=
  evalStrongRec 1
    (fun n Hrecs p1 : nat =>
     switchPR n
       (switchPR (charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1)
          (codeNth (n - S (cPairPi2 (pred n))) Hrecs)
          (S
             (cPair (cPairPi1 (pred n))
                (codeNth (n - S (cPairPi2 (pred n))) Hrecs))))
       (codeList nil)) l a.

Lemma codeListRemoveCorrect (a : nat) (l : list nat):
 codeListRemove a (codeList l) =
   codeList (List.remove  eq_nat_dec a l).
Proof.
  unfold codeListRemove;
    set
      (f :=
         fun n Hrecs p1 : nat =>
           switchPR n
             (switchPR (charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1)
                (codeNth (n - S (cPairPi2 (pred n))) Hrecs)
                (S
                   (cPair (cPairPi1 (pred n))
                      (codeNth (n - S (cPairPi2 (pred n))) Hrecs))))
             (codeList nil)) in *.
  induction l as [| a0 l Hrecl].
  - simpl; unfold evalStrongRec; simpl; reflexivity.
  - unfold evalStrongRec, evalComposeFunc, evalOneParamList.
    rewrite computeEvalStrongRecHelp.
    unfold f at 2 in |- *.
    unfold compose2 in |- *.
    set (n := codeList (a0 :: l)).
    set (A := n - S (cPairPi2 (pred n))).
    simpl;
      repeat rewrite cPairProjections1 || rewrite cPairProjections2.
    assert
      (H: extEqual 1
            (evalComposeFunc 1 1 (Vector.cons _
                                    (evalStrongRecHelp 1 f n) 0
                                    (Vector.nil _))
               (fun b : nat => codeNth (n - S (cPairPi2 (pred n))) b))
            (evalStrongRec 1 f (cPairPi2 (pred n)))).
    { apply (evalStrongRecHelp2 1); simpl; unfold n.
      rewrite cPairProjections2.
      simpl; apply Compat815.le_lt_n_Sm.
      apply cPairLe2.
    }
    simpl in H.
    induction (Nat.eq_dec a0 a) as [a1 | b].
    + rewrite a1, Nat.eqb_refl; simpl; unfold A.
      rewrite H; rewrite cPairProjections2; auto.
      destruct (Nat.eq_dec a a).
        * auto.
        * congruence.
    + rewrite nat_eqb_false; simpl.
      replace (codeList (List.remove eq_nat_dec a l)) with
        (codeNth A (evalStrongRecHelp 1 f n a)).
      * destruct  (Nat.eq_dec a a0).
        -- congruence.
        -- simpl. f_equal. f_equal. Search evalStrongRecHelp codeNth. rewrite <- Hrecl.
           rewrite cPairProjections2 in H.
           rewrite <- H. unfold A.
           simpl. now rewrite cPairProjections2.
      * unfold A; rewrite H; simpl; rewrite cPairProjections2; auto.
      * auto.
Qed.

Lemma codeListRemoveIsPR : isPR 2 codeListRemove.
Proof.
  unfold codeListRemove; apply swapIsPR; apply evalStrongRecIsPR.
  apply
    compose3_3IsPR
    with
    (g := switchPR)
    (f1 := fun n Hrecs p1 : nat => n)
    (f2 := fun n Hrecs p1 : nat =>
             switchPR (charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1)
               (codeNth (n - S (cPairPi2 (pred n))) Hrecs)
               (S
                  (cPair (cPairPi1 (pred n))
                     (codeNth (n - S (cPairPi2 (pred n))) Hrecs))))
    (f3 := fun n Hrecs p1 : nat => codeList nil).
  - apply pi1_3IsPR.
  - assert
      (H: isPR 3
            (fun n Hrecs p1 : nat =>
               codeNth (n - S (cPairPi2 (pred n))) Hrecs)).
    + apply filter110IsPR with
        (g := fun n Hrecs : nat =>
                codeNth (n - S (cPairPi2 (pred n))) Hrecs).
      apply compose2_2IsPR with
        (h := codeNth)
        (f := fun n Hrecs : nat => n - S (cPairPi2 (pred n)))
        (g := fun n Hrecs : nat => Hrecs).
      * apply filter10IsPR with
          (g := fun n : nat => n - S (cPairPi2 (pred n))).
        apply compose1_2IsPR with
          (g := minus)
          (f := fun n : nat => n)
          (f' := fun n : nat => S (cPairPi2 (pred n))).
        -- apply idIsPR.
        -- apply compose1_1IsPR with
             (f := fun n : nat => cPairPi2 (pred n)).
           ++ apply compose1_1IsPR.
              ** apply predIsPR.
              ** apply cPairPi2IsPR.
           ++ apply succIsPR.
        -- apply minusIsPR.
      * apply pi2_2IsPR.
      * apply codeNthIsPR.
    + apply compose3_3IsPR with
        (g := switchPR)
        (f1 := fun n Hrecs p1 : nat =>
                 charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1)
        (f2 := fun n Hrecs p1 : nat =>
                 codeNth (n - S (cPairPi2 (pred n))) Hrecs)
        (f3 := fun n Hrecs p1 : nat =>
                 S
                   (cPair (cPairPi1 (pred n))
                      (codeNth (n - S (cPairPi2 (pred n))) Hrecs))).
      * apply  filter101IsPR with
          (g := fun n p1 : nat =>
                  charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1).
        apply compose2_2IsPR with
          (f := fun n p1 : nat => cPairPi1 (pred n))
          (g := fun n p1 : nat => p1).
        -- apply filter10IsPR with (g := fun n : nat => cPairPi1 (pred n)).
           apply compose1_1IsPR.
           ++ apply predIsPR.
           ++ apply cPairPi1IsPR.
        -- apply pi2_2IsPR.
        -- apply eqIsPR.
      * apply H.
      * apply compose3_1IsPR with
          (g := S)
          (f := fun n Hrecs _ : nat =>
                  cPair (cPairPi1 (pred n))
                    (codeNth (n - S (cPairPi2 (pred n))) Hrecs)).
        -- apply compose3_2IsPR with
             (g := cPair)
             (f1 := fun n Hrecs _ : nat => cPairPi1 (pred n))
             (f2 := fun n Hrecs _ : nat =>
                      codeNth (n - S (cPairPi2 (pred n))) Hrecs).
           ++ apply filter100IsPR with (g := fun n : nat => cPairPi1 (pred n)).
              apply compose1_1IsPR.
              apply predIsPR.
              apply cPairPi1IsPR.
           ++ apply H.
           ++ apply cPairIsPR.
        -- apply succIsPR.
      * apply switchIsPR.
  - exists (composeFunc 3 0 (PRnil _) zeroFunc).
    simpl; auto.
- apply switchIsPR.
Qed.

Definition codeIn (a l : nat) : nat :=
  evalStrongRec 1
    (fun n Hrecs p1 : nat =>
     switchPR n
       (switchPR (charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1) 1
          (codeNth (n - S (cPairPi2 (pred n))) Hrecs)) 0) l a.

Lemma codeInCorrect (a : nat) (l : list nat) :
 codeIn a (codeList l) =
 match In_dec eq_nat_dec a l with
 | left _ => 1
 | right _ => 0
 end.
Proof.
  induction l as [| a0 l Hrecl]; simpl in |- *.
  - unfold codeIn, evalStrongRec; simpl; now rewrite cPairProjections1.
  - unfold codeIn, evalStrongRec; unfold evalComposeFunc, evalOneParamList.
    rewrite computeEvalStrongRecHelp.
    unfold evalList in |- *.
    set
      (f :=
         fun n Hrecs p1 : nat =>
           switchPR n
             (switchPR (charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1) 1
                (codeNth (n - S (cPairPi2 (pred n))) Hrecs)) 0)
      in *.
    set (m := cPairPi2 (pred (S (cPair a0 (codeList l))))) in *.
    set (n := S (cPair a0 (codeList l))) in *.
    simpl in |- *.
    repeat rewrite cPairProjections1.
    destruct (eq_nat_dec a0 a) as [a1 | b].
    + rewrite a1, Nat.eqb_refl; reflexivity.
    + rewrite nat_eqb_false; simpl.
      assert
        (H: extEqual _
              (evalComposeFunc 1 1
                 (Vector.cons _ (evalStrongRecHelp 1 f n) 0 (Vector.nil _))
                 (fun b : nat => codeNth (n - S m) b)) (evalStrongRec 1 f m)).
      { apply (evalStrongRecHelp2 1).
        unfold m, n; simpl. rewrite cPairProjections2.
        apply Compat815.le_lt_n_Sm.
        apply cPairLe2.
        }
        simpl in H; rewrite H.
      unfold codeIn in Hrecl.
      move f after Hrecl;  fold f in Hrecl.
      unfold m, n in |- *.
      simpl in |- *.
      rewrite cPairProjections2.
      rewrite Hrecl.
      clear H f Hrecl.
      induction (In_dec eq_nat_dec a l) as [a1 | ?]; try reflexivity.
      assumption.
Qed.

Lemma codeInIsPR : isPR 2 codeIn.
Proof.
  unfold codeIn; apply swapIsPR.
  apply evalStrongRecIsPR.
  apply compose3_3IsPR with
    (g := switchPR)
    (f1 := fun n Hrecs p1 : nat => n)
    (f2 := fun n Hrecs p1 : nat =>
             switchPR (charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1) 1
               (codeNth (n - S (cPairPi2 (pred n))) Hrecs))
    (f3 := fun n Hrecs p1 : nat => 0).
  - apply pi1_3IsPR.
  - apply compose3_3IsPR with
      (g := switchPR)
      (f1 := fun n Hrecs p1 : nat =>
               charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1)
      (f2 := fun n Hrecs p1 : nat => 1)
      (f3 := fun n Hrecs p1 : nat => codeNth (n - S (cPairPi2 (pred n))) Hrecs).
    + apply filter101IsPR with
        (g := fun n p1 : nat => charFunction 2 Nat.eqb (cPairPi1 (pred n)) p1).
      apply compose2_2IsPR with
        (h := charFunction 2 Nat.eqb)
        (f := fun n p1 : nat => cPairPi1 (pred n))
        (g := fun n p1 : nat => p1).
      * apply filter10IsPR with (g := fun n : nat => cPairPi1 (pred n)).
        apply compose1_1IsPR.
        -- apply predIsPR.
        -- apply cPairPi1IsPR.
      * apply pi2_2IsPR.
      * apply eqIsPR.
    + apply filter100IsPR with (g := fun _ : nat => 1).
      apply const1_NIsPR.
    + apply filter110IsPR with
        (g := fun n Hrecs : nat => codeNth (n - S (cPairPi2 (pred n))) Hrecs).
      apply compose2_2IsPR with
        (h := codeNth)
        (f := fun n Hrecs : nat => n - S (cPairPi2 (pred n)))
        (g := fun n Hrecs : nat => Hrecs).
      apply filter10IsPR with
        (g := fun n : nat => n - S (cPairPi2 (pred n))).
      * apply compose1_2IsPR with
          (g := minus)
          (f := fun n : nat => n)
          (f' := fun n : nat => S (cPairPi2 (pred n))).
        apply idIsPR.
        apply compose1_1IsPR with
          (g := S) (f := fun n : nat => cPairPi2 (pred n)).
        apply compose1_1IsPR.
        apply predIsPR.
        apply cPairPi2IsPR.
        apply succIsPR.
        apply minusIsPR.
      * apply pi2_2IsPR.
      * apply codeNthIsPR.
    + apply switchIsPR.
  - apply filter100IsPR with (g := fun _ : nat => 0).
    apply const1_NIsPR.
  - apply switchIsPR.
Qed.

Definition codeNoDup : nat -> nat :=
  evalStrongRec 0
    (fun l recs : nat =>
       switchPR l
         (switchPR
            (codeIn (cPairPi1 (pred l))
               (codeNth (l - S (cPairPi2 (pred l))) recs))
            (codeNth (l - S (cPairPi2 (pred l))) recs)
            (S
               (cPair (cPairPi1 (pred l))
                  (codeNth (l - S (cPairPi2 (pred l))) recs)))) 0).

Lemma codeNoDupCorrect (l : list nat) :
 codeNoDup (codeList l) = codeList (List.nodup eq_nat_dec l).
Proof.
  unfold codeNoDup;
    set
      (g :=
         fun l0 recs : nat =>
           switchPR l0
             (switchPR
                (codeIn (cPairPi1 (pred l0))
                   (codeNth (l0 - S (cPairPi2 (pred l0))) recs))
                (codeNth (l0 - S (cPairPi2 (pred l0))) recs)
                (S
                   (cPair (cPairPi1 (pred l0))
                      (codeNth (l0 - S (cPairPi2 (pred l0))) recs)))) 0)
    in *.
  induction l as [| a l Hrecl].
  - simpl in |- *.
    unfold evalStrongRec; simpl; now rewrite cPairProjections1.
  - simpl; unfold evalStrongRec;
      unfold evalComposeFunc, evalOneParamList, evalList.
    rewrite computeEvalStrongRecHelp.
    unfold compose2, evalComposeFunc, evalOneParamList, evalList in |- *.
    unfold g at 1 in |- *.
    repeat rewrite evalStrongRecHelp1; unfold pred in |- *.
    repeat rewrite cPairProjections1 || rewrite cPairProjections2.
    + rewrite Hrecl; rewrite codeInCorrect.
      destruct (In_dec Nat.eq_dec a (List.nodup Nat.eq_dec l)).
      destruct (in_dec Nat.eq_dec a l).
      * reflexivity.
      *     rewrite nodup_In in i; contradiction.
      * destruct (in_dec Nat.eq_dec a l).
     -- rewrite  nodup_In in n. contradiction.
     -- reflexivity.
    + simpl; apply Compat815.le_lt_n_Sm.
      apply cPairLe2A.
Qed.

Lemma codeNoDupIsPR : isPR 1 codeNoDup.
Proof.
  unfold codeNoDup; apply evalStrongRecIsPR.
  apply compose2_3IsPR with
    (f1 := fun l recs : nat => l)
    (f2 := fun l recs : nat =>
             switchPR
               (codeIn (cPairPi1 (pred l))
                  (codeNth (l - S (cPairPi2 (pred l))) recs))
               (codeNth (l - S (cPairPi2 (pred l))) recs)
               (S
                  (cPair (cPairPi1 (pred l))
                     (codeNth (l - S (cPairPi2 (pred l))) recs))))
    (f3 := fun l recs : nat => 0).
  - apply pi1_2IsPR.
  - assert (H: isPR 2
                 (fun l recs : nat =>
                    codeNth (l - S (cPairPi2 (pred l))) recs)).
    { apply callIsPR with (g := fun l : nat => cPairPi2 (pred l)).
      apply compose1_1IsPR.
      - apply predIsPR.
      - apply cPairPi2IsPR.
    }
    apply compose2_3IsPR with
      (f1 := fun l recs : nat =>
               codeIn (cPairPi1 (pred l))
                 (codeNth (l - S (cPairPi2 (pred l))) recs))
      (f2 := fun l recs : nat => codeNth (l - S (cPairPi2 (pred l))) recs)
      (f3 := fun l recs : nat =>
               S
                 (cPair (cPairPi1 (pred l))
                    (codeNth (l - S (cPairPi2 (pred l))) recs))).
    + apply compose2_2IsPR with
        (f := fun l recs : nat => cPairPi1 (pred l))
        (g := fun l recs : nat => codeNth (l - S (cPairPi2 (pred l))) recs).
      * apply filter10IsPR with (g := fun l : nat => cPairPi1 (pred l)).
        apply compose1_1IsPR.
        -- apply predIsPR.
        -- apply cPairPi1IsPR.
      * assumption.
      * apply codeInIsPR.
    + assumption.
    + apply compose2_1IsPR with
        (f := fun l recs : nat =>
                cPair (cPairPi1 (pred l))
                  (codeNth (l - S (cPairPi2 (pred l))) recs)).
      * apply compose2_2IsPR with
          (f := fun l recs : nat => cPairPi1 (pred l))
          (g := fun l recs : nat => codeNth (l - S (cPairPi2 (pred l))) recs).
        -- apply filter10IsPR with (g := fun l : nat => cPairPi1 (pred l)).
           apply compose1_1IsPR.
           ++ apply predIsPR.
           ++ apply cPairPi1IsPR.
        -- assumption.
        -- apply cPairIsPR.
      * apply succIsPR.
    + apply switchIsPR.
  - apply filter10IsPR with (g := fun _ : nat => 0).
    apply const1_NIsPR.
  - apply switchIsPR.
Qed.


Require Export Enumerated.

Section VERTEX.

  Inductive Vertex : Set :=
    Index : nat -> Vertex.

  Lemma V_eq_dec :
    forall x y : Vertex, {x = y} + {x <> y}.
  Proof.
    simple destruct x; simple destruct y; intros.
    case (eq_nat_dec n n0); intros.
    left; apply f_equal; trivial.
    right; injection; trivial.
  Qed.

  Definition V_list := list Vertex.
  Definition V_nil := nil(A := Vertex).
  Definition V_In_dec := U_in_dec Vertex V_eq_dec.
  Definition V_canon := U_canon Vertex.
  Definition V_sum := U_sum Vertex.
  Definition V_set := U_set Vertex.
  Definition V_set_eq := U_set_eq Vertex.
  Definition V_set_diff := U_set_diff Vertex.
  Definition V_eq_set := U_eq_set Vertex.
  Definition V_set_eq_commut := U_set_eq_commute Vertex.
  Definition V_set_diff_commut := U_set_diff_commute Vertex.
  Definition V_empty := Empty Vertex.
  Definition V_empty_nothing := Empty_nothing Vertex.
  Definition V_single := Single Vertex.
  Definition V_in_single := In_single Vertex.
  Definition V_single_equal := single_equal Vertex.
  Definition V_single_equal_single := Single_equal_single Vertex.
  Definition V_included := Included Vertex.
  Definition V_included_single := Included_single Vertex.
  Definition V_enumerable := U_enumerable Vertex.
  Definition V_enumerable_sum := U_enumerable_sum Vertex.
  Definition V_union := Union Vertex.
  Definition V_in_left := In_left Vertex.
  Definition V_in_right := In_right Vertex.
  Definition V_union_eq := Union_eq Vertex.
  Definition V_union_neutral := Union_neutral Vertex.
  Definition V_union_commut := Union_commut Vertex.
  Definition V_union_assoc := Union_assoc Vertex.
  Definition V_not_union := Not_union Vertex.
  Definition V_union_dec := Union_dec Vertex.
  Definition V_included_union := Included_union Vertex.
  Definition V_union_absorb := Union_absorb Vertex.
  Definition V_inter := Inter Vertex.
  Definition V_in_inter := In_inter Vertex.
  Definition V_inter_eq := Inter_eq Vertex.
  Definition V_inter_neutral := Inter_neutral Vertex.
  Definition V_inter_empty := Inter_empty Vertex.
  Definition V_inter_commut := Inter_commute Vertex.
  Definition V_inter_assoc := Inter_assoc Vertex.
  Definition V_not_inter := Not_inter Vertex.
  Definition V_included_inter := Included_inter Vertex.
  Definition V_inter_absorb := Inter_absorb Vertex.
  Definition V_differ := Differ Vertex.
  Definition V_differ_E_E := Differ_E_E Vertex.
  Definition V_differ_empty := Differ_empty Vertex.
  Definition V_union_differ_inter := Union_differ_inter Vertex.
  Definition V_distributivity_inter_union := Distributivity_inter_union Vertex.
  Definition V_distributivity_union_inter := Distributivity_union_inter Vertex.
  Definition V_union_inversion := Union_inversion Vertex.
  Definition V_union_inversion2 := Union_inversion2 Vertex.
  Definition V_single_disjoint := Single_disjoint Vertex.
  Definition V_single_single_disjoint := Single_single_disjoint Vertex.
  Definition V_union_single_single := Union_single_single Vertex.

End VERTEX.


(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
From mathcomp Require Import ssralg fintype fingroup perm.
From mathcomp Require Import matrix bigop zmodp mxalgebra.

Require Import gauss.
Import GRing.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section FieldRank.

Variable F : fieldType.
Local Open Scope ring_scope.

Fixpoint rank_elim {m n : nat} : 'M[F]_(m, n) -> nat :=
  if n is p.+1 then
    fun (M : 'M_(m, 1 + p)) =>
      if find_pivot M is Some k then
        let a := fun_of_matrix M k 0 in
        let u := rsubmx (row k M) in
        let R := row' k M in
        let v := a^-1 *: lsubmx R in
        let R := rsubmx R - v *m u in
        (1 + rank_elim R)%N
      else rank_elim (rsubmx M)
  else fun => 0%N.

Lemma rank_row0mx (m n p : nat) (M : 'M[F]_(m,n)) :
  \rank (row_mx (0: 'M[F]_(m,p)) M) = \rank M.
Proof. by rewrite -mxrank_tr tr_row_mx trmx0 -addsmxE adds0mx mxrank_tr. Qed.

Lemma rank_block0dl m n a Aur (Adr : 'M[F]_(m,n)) :
  a != 0 -> \rank (block_mx (a%:M : 'M_1) Aur 0 Adr) = (1 + \rank Adr)%N.
Proof.
move=> nz_a.
rewrite /block_mx -addsmxE mxrank_disjoint_sum.
  rewrite rank_row0mx rank_rV.
  have->//: row_mx a%:M Aur != 0.
    apply/eqP => /matrixP/(_ 0 0); rewrite !mxE.
    by case: splitP => // j _; rewrite ord1 !mxE; move/eqP: nz_a.
apply/eqP/rowV0P => v0; rewrite sub_capmx; case/andP=> /sub_rVP [k Hv0k].
rewrite Hv0k; case/submxP => D /matrixP/(_ 0 0); rewrite !mxE.
case: splitP => // j _; rewrite ord1 mxE mulr1n big1.
by move/eqP; rewrite mulf_eq0 (negbTE nz_a) orbF => /eqP ->; rewrite scale0r.
by move=> i _; rewrite !mxE; case: splitP=> // l _; rewrite mxE mulr0.
Qed.

Lemma row'_row_perm m n M k :
  row' k M = dsubmx (row_perm (lift_perm 0 k 1%g) M : 'M[F]_(1 + m, n)).
Proof.
by apply/matrixP=> i j; rewrite !mxE rshift1 lift_perm_lift perm1.
Qed.

Lemma row_row_perm m n (M : 'M[F]_(1 + m, n)) k :
  row k M = @usubmx _ 1 _ _ (row_perm (lift_perm 0 k 1%g) M).
Proof.
by apply/matrixP=> i j; rewrite !mxE ord1 lshift0 lift_perm_id.
Qed.

Lemma rank_elimP m n (M : 'M_(m, n)) : rank_elim M = \rank M.
Proof.
elim: n m M => [m M|n IHn m]; first by rewrite thinmx0 mxrank0.
rewrite -[n.+1]/(1 + n)%N => M /=.
rewrite /find_pivot.
have [|nz_Mk0] /= := pickP; last first.
  rewrite -{2}[M]hsubmxK.
  suff->: lsubmx M = 0 by rewrite rank_row0mx.
  apply/matrixP => i j; rewrite !mxE ord1 lshift0.
  by have /(_ i)/negbFE/eqP -> := nz_Mk0.
case: m M => [M []|m] //.
rewrite -[m.+1]/(1 + m)%N => M k /= nz_Mk0; rewrite IHn.
pose P : 'M[F]_(1 + m) := perm_mx (lift_perm 0 k 1%g).
have->: \rank M = \rank (P *m M).
  by rewrite eqmxMfull // row_full_unit unitmx_perm.
rewrite -row_permE.
set xM : 'M[F]_(1 + m, 1 + n) := row_perm _ _.
pose D : 'M[F]_(1 + m) := block_mx 1%:M 0 (- (M k 0)^-1 *: (dlsubmx xM)) 1%:M.
have hD : row_full D.
  by rewrite row_full_unit unitmxE !det_lblock !det1 !mul1r unitr1.
rewrite -(eqmxMfull xM hD) -[xM]submxK mulmx_block !mul1mx !mul0mx !addr0.
rewrite scaleNr mulNmx [ulsubmx xM]mx11_scalar !mxE !lshift0 lift_perm_id.
rewrite mul_mx_scalar scalerA divrr ?unitfE // scale1r addNr rank_block0dl //.
rewrite {3}/xM /drsubmx /dlsubmx -row'_row_perm addrC /ursubmx -row_row_perm.
by rewrite mulNmx.
Qed.

End FieldRank.


From Coq Require Import String List ZArith Lia.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.
From compcert Require Import Maps Values ClightBigstep Events Memory.

Require Import Clight.strlen.

Open Scope Z_scope.

(** * relational specification of strlen *)

Inductive strlen_rspec (m : mem) (b : block) (ofs : ptrofs) : nat -> Prop :=
| LengthZero:
    Mem.loadv Mint8signed m (Vptr b ofs) = Some (Vint Int.zero) ->
    strlen_rspec m b ofs 0
| LengthSucc:
    forall n c,
    Z.of_nat (S n) < Int.modulus ->
    Ptrofs.unsigned ofs + 1 < Ptrofs.modulus ->
    Mem.loadv Mint8signed m (Vptr b ofs)  = Some (Vint c) ->
    Int.eq c Int.zero = false ->
    strlen_rspec m b (Ptrofs.add ofs Ptrofs.one) n ->
    strlen_rspec m b ofs (S n).

(** * Helper lemmas and definitions *)

Definition ofs_of_nat (n : nat) := Ptrofs.repr (Z.of_nat n).

(* add more lemmas to ptrofs hints *)
Hint Resolve Ptrofs.mul_one Ptrofs.add_zero : ptrofs.

Ltac gso_simpl := rewrite PTree.gso by discriminate.
Ltac gss_simpl := rewrite PTree.gss.

(*
 * helper for pointer arithmetic
 * the first two requirements are technical:
 * true in all but corner cases
*)
Fact ofs_succ_l : forall ofs i,
  1 < Int.modulus ->
  Z.of_nat i < Int.modulus ->
  Ptrofs.add (Ptrofs.add ofs (ofs_of_nat i)) Ptrofs.one =
  Ptrofs.add ofs (ofs_of_nat (S i)).
Proof.
  intros.
  rewrite Ptrofs.add_assoc.
  f_equal.
  unfold ofs_of_nat, Ptrofs.one, Ptrofs.add, Ptrofs.mul.
  rewrite Nat2Z.inj_succ, Ptrofs.unsigned_repr_eq, Zmod_small.
  reflexivity.
  replace Ptrofs.modulus with Int.modulus by reflexivity.
  nia.
Qed.

Fact ofs_succ_r : forall ofs i,
  1 < Int.modulus ->
  Z.of_nat i < Int.modulus ->
  Ptrofs.add (Ptrofs.add ofs Ptrofs.one) (ofs_of_nat i) =
  Ptrofs.add ofs (ofs_of_nat (S i)).
Proof.
  intros.
  rewrite <-ofs_succ_l by assumption.
  rewrite Ptrofs.add_assoc, Ptrofs.add_assoc.
  f_equal.
  apply Ptrofs.add_commut.
Qed.

(*
 * if strlen on [b + ofs] is [len],
 * then strlen on [b + ofs + len] is 0
 *)
Lemma strlen_to_len_0 :
  forall len m b ofs,
    strlen_rspec m b ofs len ->
    strlen_rspec m b (Ptrofs.add ofs (ofs_of_nat len)) 0.
Proof.
  induction len; intros.
  - replace (ofs_of_nat 0) with Ptrofs.zero by reflexivity.
    replace (Ptrofs.add ofs Ptrofs.zero) with ofs by (auto with ptrofs).
    assumption.
  - inversion_clear H.
    rewrite <-ofs_succ_r by lia.
    apply IHlen.
    assumption.
Qed.

(*
 * if strlen on [b + ofs] is [len],
 * then all chars on [b + ofs + i], [i < len] are non-nil
 *)
Lemma strlen_to_mem :
  forall len m b ofs, strlen_rspec m b ofs len -> forall i, (i < len)%nat ->
         exists c,
           Int.eq c Int.zero = false /\
           Mem.loadv Mint8signed m (Vptr b (Ptrofs.add ofs (ofs_of_nat i))) = Some (Vint c).
Proof.
  induction len; intros.
  - lia.
  - intros.
    destruct i; inversion_clear H.
    + exists c.
      split; [try assumption |].
      rewrite Ptrofs.add_zero.
      assumption.
    + specialize IHlen with (ofs := (Ptrofs.add ofs Ptrofs.one)).
      replace (Ptrofs.add ofs (ofs_of_nat (S i)))
        with (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) (ofs_of_nat i)).
      apply IHlen; [assumption | lia].
      rewrite ofs_succ_r by lia.
      reflexivity.
Qed.

Fact ptr_max_signed_lower_bound :
  2147483647 <= Ptrofs.max_signed.
Proof.
  unfold Ptrofs.max_signed, Ptrofs.half_modulus, Ptrofs.modulus,
    Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  destruct Archi.ptr64; simpl; lia.
Qed.

Fact ptr_zwordsize_lower_bound :
 32 <= Ptrofs.zwordsize.
Proof.
  unfold Ptrofs.zwordsize, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  destruct Archi.ptr64; simpl; lia.
Qed.

(** * correctness *)

(* loop isolated *)
Definition f_strlen_loop :=
  (Sloop
    (Sifthenelse (Ederef (Etempvar _s (tptr tschar)) tschar) Sskip Sbreak)
    (Sset _s
      (Ebinop Oadd (Etempvar _s (tptr tschar))
        (Econst_int (Int.repr 1) tint) (tptr tschar)))).

(*
 * correctness of the loop in isolation.
 * in addition to proving correctness of result
 * we also prove preservation of [str]:
 * that is required because [str] is used again in the return statement
 *)
Lemma f_strlen_loop_correct :
  forall len ge e m b ofs ste i,
    strlen_rspec m b ofs (len + i) ->
    exists t rte,
      ste ! _str = Some (Vptr b ofs) ->
      ste ! _s = Some (Vptr b (Ptrofs.add ofs (ofs_of_nat i))) ->

      exec_stmt ge e ste m f_strlen_loop t rte m Out_normal
      /\
      rte ! _s = Some (Vptr b (Ptrofs.add ofs (ofs_of_nat (len + i))))
      /\
      rte ! _str = ste ! _str.
Proof.
  induction len; intros.
  - (** iBase *)
    apply strlen_to_len_0 in H; inversion_clear H.
    repeat eexists.
    eapply exec_Sloop_stop1.
    repeat econstructor.
    all: try eassumption.
    all: try econstructor.
  - (** iStep *)
    (** introduce properties of [strlen_rspec] *)
    assert (T : (i < S len + i)%nat) by lia;
      pose proof strlen_to_mem _ _ _ _ H _ T as HM;
      clear T;
      destruct HM as [c HM]; destruct HM as [HM1 HM2].
    pose proof strlen_to_len_0 _ _ _ _ H as HO.

    (** prepare the induction hypothesis for use *)
    (* cannot work with [S len] but can with [S i] *)
    replace (S len + i)%nat with (len + S i)%nat in * by lia.
    (* this is the starting state of the iteration on the induction step *)
    remember (PTree.set _s (Vptr b (Ptrofs.add (Ptrofs.add ofs (ofs_of_nat i)) Ptrofs.one)) ste)
      as sIte.
    pose proof IHlen ge e m b ofs sIte (S i) H as IH;
      clear IHlen;
      destruct IH as [t IH]; destruct IH as [rIte IH].

    eexists; eexists; intros.

    (* split induction hypothesis *)
    destruct IH as [IH1 IH];
      [subst; gso_simpl; assumption
      | subst; gss_simpl; inversion H; rewrite ofs_succ_l by lia; reflexivity
      |].
    destruct IH as [IH2 IH3].

    split.
    + (* statment execution *)
      eapply exec_Sloop_loop.
      repeat econstructor.
      eassumption.
      eassumption.
      econstructor.
      rewrite HM1.
      econstructor.
      constructor.
      repeat econstructor.
      eassumption.
      econstructor.

      fold f_strlen_loop.
      replace (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar)) (ptrofs_of_int Signed (Int.repr 1)))
        with Ptrofs.one
        by (auto with ptrofs).
      subst.
      eassumption.
    + (* execution result *)
      split.
      assumption.
      rewrite IH3; subst; gso_simpl; reflexivity.
Qed.

(* full correctness *)
Lemma f_strlen_correct :
  forall len ge e m b ofs ste,
    strlen_rspec m b ofs len ->
    ste ! _str = Some (Vptr b ofs) ->
    exists t rte,
      exec_stmt ge e ste m (fn_body f_strlen) t rte m
                (Out_return (Some (Vptrofs (ofs_of_nat len), tint))).
Proof.
  intros.

  (* introduce the gneralized correctness lemma *)
  pose proof f_strlen_loop_correct len ge e m b ofs (PTree.set _s (Vptr b ofs) ste) 0 as GC.
  replace (len + 0)%nat with len in * by lia.
  specialize (GC H).
  destruct GC as [t GC]; destruct GC as [le' GC].

  repeat eexists.

  (* make loop correctness lemma usable *)
  destruct GC as [GC1 GC];
    [gso_simpl; assumption
    |gss_simpl; rewrite Ptrofs.add_zero; reflexivity
    |].
  destruct GC as [GC2 GC3].

  (* split body into three parts *)
  econstructor. econstructor.
  - (* set *)
    repeat econstructor.
    eassumption.
  - (* loop *)
    eassumption.
  - (* return *)
    repeat econstructor.
    eassumption.
    rewrite GC3; gso_simpl; eassumption.
    cbn.
    destruct eq_block; [| contradiction].
    unfold proj_sumbool.
    destruct zle;
      [| pose proof ptr_max_signed_lower_bound; lia].
    rewrite Ptrofs.divs_one;
      [| pose proof ptr_zwordsize_lower_bound; lia].
    rewrite Ptrofs.sub_add_l, Ptrofs.sub_idem, Ptrofs.add_zero_l.
    reflexivity.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_differenceofparts.
Require Import ProofCheckingEuclid.lemma_extension.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_ABD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_BCD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABD_BCD_ACD.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_outerconnectivity :
	forall A B C D,
	BetS A B C ->
	BetS A B D ->
	~ BetS B C D ->
	~ BetS B D C ->
	eq C D.
Proof.
	intros A B C D.
	intros BetS_A_B_C.
	intros BetS_A_B_D.
	intros nBetS_B_C_D.
	intros nBetS_B_D_C.

	pose proof (lemma_betweennotequal _ _ _ BetS_A_B_C) as (_ & _ & neq_A_C).
	pose proof (lemma_betweennotequal _ _ _ BetS_A_B_D) as (_ & _ & neq_A_D).
	pose proof (lemma_extension _ _ _ _ neq_A_C neq_A_D) as (E & BetS_A_C_E & Cong_CE_AD).
	pose proof (lemma_extension _ _ _ _ neq_A_D neq_A_C) as (F & BetS_A_D_F & Cong_DF_AC).

	pose proof (axiom_betweennesssymmetry _ _ _ BetS_A_D_F) as BetS_F_D_A.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_A_B_D) as BetS_D_B_A.
	pose proof (lemma_orderofpoints_ABD_BCD_ACD _ _ _ _ BetS_F_D_A BetS_D_B_A) as BetS_F_B_A.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_F_B_A) as BetS_A_B_F.
	pose proof (cn_congruencereverse F D) as Cong_FD_DF.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_FD_DF Cong_DF_AC) as Cong_FD_AC.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_CE_AD) as Cong_AD_CE.
	pose proof (cn_congruencereverse D A) as Cong_DA_AD.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_DA_AD Cong_AD_CE) as Cong_DA_CE.
	pose proof (
		cn_sumofparts _ _ _ _ _ _ Cong_FD_AC Cong_DA_CE BetS_F_D_A BetS_A_C_E
	) as Cong_FA_AE.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_FA_AE) as (_ & Cong_AF_AE & _).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AF_AE) as Cong_AE_AF.

	pose proof (cn_congruencereflexive A B) as Cong_AB_AB.
	pose proof (lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_A_B_C BetS_A_C_E) as BetS_A_B_E.
	pose proof (
		lemma_differenceofparts _ _ _ _ _ _ Cong_AB_AB Cong_AE_AF BetS_A_B_E BetS_A_B_F
	) as Cong_BE_BF.
	pose proof (lemma_extensionunique _ _ _ _ BetS_A_B_E BetS_A_B_F Cong_BE_BF) as eq_E_F.

	assert (BetS A D E) as BetS_A_D_E by (rewrite eq_E_F; exact BetS_A_D_F).

	pose proof (lemma_orderofpoints_ABC_ACD_BCD _ _ _ _ BetS_A_B_C BetS_A_C_E) as BetS_B_C_E.
	pose proof (lemma_orderofpoints_ABC_ACD_BCD _ _ _ _ BetS_A_B_D BetS_A_D_E) as BetS_B_D_E.
	pose proof (axiom_connectivity _ _ _ _ BetS_B_C_E BetS_B_D_E nBetS_B_C_D nBetS_B_D_C) as eq_C_D.
	exact eq_C_D.
Qed.

End Euclid.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

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

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

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

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

Lemma lem : forall (x : lst) (y : natural), eq (rev (append x (Cons y Nil))) (Cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst) (z : natural), eq (rev (append x (append y (Cons z Nil)))) (Cons z (rev (append x y))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. simpl. lfind. Admitted.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Permutation.

Set Implicit Arguments.

(* * Intuitionistic Multiplicative Sub-Exponential Linear Logic

      derived from  https://doi.org/10.1017/S0960129516000293 *)

Local Infix "~p" := (@Permutation _) (at level 70).

Reserved Notation "A ⊸ B" (at level 51, right associativity, format "A ⊸ B").
Reserved Notation "'![' m ']' x" (at level 52, format "![ m ] x").
Reserved Notation "‼ x" (at level 60, format "‼ x").

Section IMSELL.

  Variables (var bang : Type)
            (bang_le : bang -> bang -> Prop)   (* a pre-order on modalities *)
            (bang_U : bang -> Prop)            (* universal modalities have structural rules *)
            .

  Notation Λ := bang.

  Inductive imsell_form : Type :=
    | imsell_var  : var -> imsell_form
    | imsell_ban  : Λ -> imsell_form -> imsell_form
    | imsell_imp  : imsell_form -> imsell_form -> imsell_form.

  Infix "⊸" := imsell_imp.
  Notation "![ m ] x" := (imsell_ban m x).
  Notation "£" := imsell_var.

  Definition imsell_lban := map (fun '(m,A) => ![m]A).

  Notation "‼ Γ" := (imsell_lban Γ).
  Notation "u ≼ l" := (forall '(v,A), In (v,A) l -> bang_le u v) (at level 70).
  Notation U := bang_U.

  Reserved Notation "l ⊢ x" (at level 70, no associativity).

  (* We consider the (![.],-o) fragment of IMSELL without cut *)

  Inductive S_imsell : list imsell_form -> imsell_form -> Prop :=

    | in_imsell_ax A :                        A::nil ⊢ A          (* [identity] *)

    | in_imsell_perm Γ Δ A :  Γ ~p Δ ->            Γ ⊢ A
                                    (*-----------------------------  [permutation] *)
                                ->                 Δ ⊢ A

    | in_imsell_limp_l Γ Δ A B C :      Γ ⊢ A      ->   B::Δ ⊢ C
                                    (*-----------------------------  [⊸L] *)
                                ->          A⊸B::Γ++Δ ⊢ C

    | in_imsell_limp_r Γ A B :                   A::Γ ⊢ B
                                    (*-----------------------------  [⊸R] *)
                                ->                  Γ ⊢ A⊸B

    | in_imsell_bang_l Γ m A B :                 A::Γ ⊢ B
                                    (*-----------------------------  [!L] *)
                                ->           ![m]A::Γ ⊢ B

    | in_imsell_bang_r Γ m A : m ≼ Γ ->            ‼Γ ⊢ A
                                    (*-----------------------------  [!R] *)
                                ->                 ‼Γ ⊢ ![m]A

    | in_imsell_weak Γ u A B : U u ->               Γ ⊢ B
                                    (*-----------------------------  [weakening] *)
                                ->           ![u]A::Γ ⊢ B

    | in_imsell_cntr Γ u A B : U u -> ![u]A::![u]A::Γ ⊢ B
                                    (*-----------------------------  [contraction] *)
                                ->           ![u]A::Γ ⊢ B

  where "Γ ⊢ A" := (S_imsell Γ A).

End IMSELL.

Infix "⊸" := imsell_imp.
Notation "![ m ] x" := (imsell_ban m x).
Notation "£" := imsell_var.
Notation "‼ Γ" := (imsell_lban Γ).

(* An IMSELL signature is a type of modalities pre-ordered
    and an upper-closed subset of exponentials *)

Record IMSELL_sig : Type :=
  { IMSELL_Λ :> Type;
    IMSELL_le : IMSELL_Λ -> IMSELL_Λ -> Prop;
    IMSELL_refl : forall m, IMSELL_le m m;
    IMSELL_trans : forall u v w, IMSELL_le u v -> IMSELL_le v w -> IMSELL_le u w;
    IMSELL_U : IMSELL_Λ -> Prop;
    IMSELL_clos : forall u v, IMSELL_U u -> IMSELL_le u v -> IMSELL_U v
  }.

Section imsell3.

  (* The minimal signature for this undecidability proof

     3 modalities {a,b,∞} with a,b < ∞ and ∞ is the only
     universal modality *)

  Let bang := option bool.

  Let bang_le (u v : bang) :=
    match v with
      | None   => True
      | Some _ => u = v
    end.

  Let bang_U := @eq bang None.

  Definition imsell3 : IMSELL_sig.
  Proof.
    exists bang bang_le bang_U; trivial.
    all: repeat intros [[]|]; now simpl.
  Defined.

End imsell3.

Local Infix "≤" := (@IMSELL_le _) (at level 70).
Local Notation "u ≰ v" := (~ u ≤ v) (at level 70).
Local Notation U := (@IMSELL_U _).

Definition IMSELL_sig3 :=
  { S : IMSELL_sig | exists a b i : S, a ≤ i /\ b ≤ i /\ a ≰ b /\ b ≰ a
                                    /\ ~ U a /\ ~ U b /\ U i }.

Definition IMSELL_problem (S : IMSELL_sig) :=
  let F := imsell_form nat (IMSELL_Λ S) in (list F * F)%type.

Definition IMSELL_problem3 (S : IMSELL_sig3) := IMSELL_problem (proj1_sig S).

(* Cut-free provability over an IMSELL signature *)

Definition IMSELL_cf_PROVABILITY S (P : IMSELL_problem S) :=
  let (Γ,A) := P in S_imsell (IMSELL_le S) (IMSELL_U S) Γ A.

Definition IMSELL_cf_PROVABILITY3 S (P : IMSELL_problem3 S) := IMSELL_cf_PROVABILITY P.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job.
Require Import prosa.classic.model.schedule.uni.schedule.

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

(** * Definitions for Abstract Response-Time Analysis *)
(** In this module, we propose a set of definitions for the general framework for response-time analysis (RTA)
    of uniprocessor scheduling of real-time tasks with arbitrary arrival models. *)
Module AbstractRTADefinitions.

  Import Job UniprocessorSchedule.

  (* In this section, we introduce all the abstract notions required by the analysis. *)
  Section Definitions.

    Context {Task: eqType}.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any uniprocessor schedule of this arrival sequence. *)
    Variable sched: schedule Job.

    (* Let tsk be any task that is to be analyzed *)
    Variable tsk: Task.

    (* For simplicity, let's define some local names. *)
    Let job_scheduled_at := scheduled_at sched.
    Let job_completed_by := completed_by job_cost sched.

    (* Recall that a job j is pending_earlier_and_at a time instant t iff job
       j arrived before time t and is still not completed by time t. *)
    Let job_pending_earlier_and_at := pending_earlier_and_at job_arrival job_cost sched.

    (* We are going to introduce two main variables of the analysis:
       (a) interference, and (b) interfering workload. *)

    (** a) Interference *)
    (* Execution of a job may be postponed by the environment and/or the system due to different
       factors (preemption by higher-priority jobs, jitter, black-out periods in hierarchical
       scheduling, lack of budget, etc.), which we call interference.

       Besides, note that even the n’th activation of a task can suffer from interference at
       the beggining of its busy interval (despite the fact that this job hasn’t even arrived
       at that moment!). Thus, it makes more sense (at least for the current busy-interval
       analysis) to think about interference of a job as any interference within the
       corresponding busy interval, and not after release of the job.

       Based on that, assume a predicate that expresses whether a job j under consideration
       incurs interference at a given time t (in the context of the schedule under consideration).
       This will be used later to upper-bound job j's response time. Note that a concrete
       realization of the function may depend on the schedule, but here we do not require this
       for the sake of simplicity and generality. *)
    Variable interference: Job -> time -> bool.

    (** b) Interfering Workload *)
    (* In addition to interference, the analysis assumes that at any time t, we know an upper
       bound on the potential cumulative interference that can be incurred in the future by any
       job (i.e., the total remaining potential delays). Based on that, assume a function
       interfering_workload that indicates for any job j, at any time t, the amount of potential
       interference for job j that is introduced into the system at time t. This function will be
       later used to upper-bound the length of the busy window of a job.
       One example of workload function is the "total cost of jobs that arrive at time t and
       have higher-or-equal priority than job j". In some task models, this function expresses
       the amount of the potential interference on job j that "arrives" in the system at time t. *)
    Variable interfering_workload: Job -> time -> time.

    (* In order to bound the response time of a job, we must to consider the cumulative
       interference and cumulative interfering workload. *)
    Definition cumul_interference j t1 t2 := \sum_(t1 <= t < t2) interference j t.
    Definition cumul_interfering_workload j t1 t2 := \sum_(t1 <= t < t2) interfering_workload j t.

    (** Definition of Busy Interval *)
    (* Further analysis will be based on the notion of a busy interval. The overall idea of the
       busy interval is to take into account the workload that cause a job under consideration to
       incur interference. In this section, we provide a definition of an abstract busy interval. *)
    Section BusyInterval.

      (* We say that time instant t is a quiet time for job j iff two conditions hold.
         First, the cumulative interference at time t must be equal to the cumulative
         interfering workload, to indicate that the potential interference seen so far
         has been fully "consumed" (i.e., there is no more higher-priority work or other
         kinds of delay pending). Second, job j cannot be pending at any time earlier
         than t _and_ at time instant t (i.e., either it was pending earlier but is no
         longer pending now, or it was previously not pending and may or may not be
         released now), to ensure that the busy window captures the execution of job j. *)
      Definition quiet_time (j: Job) (t: time) :=
        cumul_interference j 0 t = cumul_interfering_workload j 0 t /\
        ~~ job_pending_earlier_and_at j t.

      (* Based on the definition of quiet time, we say that interval [t1, t2) is
         a (potentially unbounded) busy-interval prefix w.r.t. job j iff the
         interval (a) contains the arrival of job j, (b) starts with a quiet
         time and (c) remains non-quiet. *)
      Definition busy_interval_prefix (j: Job) (t1 t2: time) :=
        t1 <= job_arrival j < t2 /\
        quiet_time j t1 /\
        (forall t, t1 < t < t2 -> ~ quiet_time j t).

      (* Next, we say that an interval [t1, t2) is a busy interval iff
         [t1, t2) is a busy-interval prefix and t2 is a quiet time. *)
      Definition busy_interval (j: Job) (t1 t2: time) :=
        busy_interval_prefix j t1 t2 /\
        quiet_time j t2.

      (* Note that the busy interval, if it exists, is unique. *)
      Lemma busy_interval_is_unique:
        forall j t1 t2 t1' t2',
          busy_interval j t1 t2 ->
          busy_interval j t1' t2' ->
          t1 = t1' /\ t2 = t2'.
      Proof.
        intros ? ? ? ? ? BUSY BUSY'.
        have EQ: t1 = t1'.
        { apply/eqP.
          apply/negPn/negP; intros CONTR.
          move: BUSY => [[IN [QT1 NQ]] _].
          move: BUSY' => [[IN' [QT1' NQ']] _].
          move: CONTR; rewrite neq_ltn; move => /orP [LT|GT].
          { apply NQ with t1'; try done; clear NQ.
            apply/andP; split; first by done.
            move: IN IN' => /andP [_ T1] /andP [T2 _].
              by apply leq_ltn_trans with (job_arrival j).
          }
          { apply NQ' with t1; try done; clear NQ'.
            apply/andP; split; first by done.
            move: IN IN' => /andP [T1 _] /andP [_ T2].
              by apply leq_ltn_trans with (job_arrival j).
          }
        }
        subst t1'.
        have EQ: t2 = t2'.
        { apply/eqP.
          apply/negPn/negP; intros CONTR.
          move: BUSY => [[IN [_ NQ]] QT2].
          move: BUSY' => [[IN' [_ NQ']] QT2'].
          move: CONTR; rewrite neq_ltn; move => /orP [LT|GT].
          { apply NQ' with t2; try done; clear NQ'.
            apply/andP; split; last by done.
            move: IN IN' => /andP [_ T1] /andP [T2 _].
              by apply leq_ltn_trans with (job_arrival j).
          }
          { apply NQ with t2'; try done; clear NQ.
            apply/andP; split; last by done.
            move: IN IN' => /andP [T1 _] /andP [_ T2].
              by apply leq_ltn_trans with (job_arrival j).
          }
        }
        subst t2'.
          by done.
      Qed.

    End BusyInterval.

    (* In this section, we introduce some assumptions about the
       busy interval that are fundamental for the analysis. *)
    Section BusyIntervalProperties.

      (* We say that a schedule is "work_conserving" iff for any job j from task tsk and
         at any time t within a busy interval, there are only two options:
         either (a) interference(j, t) holds or (b) job j is scheduled at time t. *)
      Definition work_conserving :=
        forall j t1 t2 t,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          job_cost j > 0 ->
          busy_interval j t1 t2 ->
          t1 <= t < t2 ->
          ~ interference j t <-> job_scheduled_at j t.

      (* Next, we say that busy intervals of task tsk are bounded by L iff, for any job j of task
         tsk, there exists a busy interval with length at most L. Note that the existence of such a
         bounded busy interval is not guaranteed if the schedule is overloaded with work.
         Therefore, in the later concrete analyses, we will have to introduce an additional
         condition that prevents overload. *)
      Definition busy_intervals_are_bounded_by L :=
        forall j,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          job_cost j > 0 ->
          exists t1 t2,
            t1 <= job_arrival j < t2 /\
            t2 <= t1 + L /\
            busy_interval j t1 t2.

      (* Although we have defined the notion of cumulative interference of a job, it is still hard to be
         used in a response-time analysis because of the variability of job parameters. To address this
         issue, we define the notion of an interference bound. Note that according to the definition of
         a work conserving schedule, interference does _not_ include execution of a job itself. Therefore,
         an interference bound is not obliged to take into account the execution of this job. We say that
         the job interference is bounded by an interference_bound_function (IBF) iff for any job j of
         task tsk the cumulative interference incurred by j in the subinterval [t1, t1 + delta) of busy
         interval [t1, t2) does not exceed interference_bound_function(tsk, A, delta), where A is a
         relative arrival time of job j (with respect to time t1).
         Let's examine this definition in more detail. First, the IBF bounds the interference only
         within the interval [t1, t1 + delta) (see a.1, a.2 below). Second, the IBF bounds the
         interference only until the job is completed, after which the function can behave
         arbitrarily (see b). And finally, the IBF function might depend not only on the length
         of the interval, but also on the relative arrival time of job j (see c).
         While (a.1), (a.2) and (b) are useful for discarding excessive cases, (c) adds
         flexibility to the IBF, which is important, for instance, when analyzing EDF scheduling. *)
      Definition job_interference_is_bounded_by (interference_bound_function: Task -> time -> time -> time) :=
        forall t1 t2 delta j,
          busy_interval j t1 t2 ->                                                                        (* (a.1) *)
          t1 + delta < t2 ->                                                                              (* (a.2) *)
          arrives_in arr_seq j ->
          job_task j = tsk ->
          ~~ job_completed_by j (t1 + delta) ->                                                           (* (b) *)
          let offset := job_arrival j - t1 in
          cumul_interference j t1 (t1 + delta) <= interference_bound_function tsk offset delta  (* (c) *).

    End BusyIntervalProperties.

  End Definitions.

End AbstractRTADefinitions.


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both
    generally and in the theory of programming languages in
    particular; we're going to need them in many places in the coming
    chapters.  They also make a nice case study using ideas we've seen
    in previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

(** Documentation for the standard library can be found at
    https://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types. See [Lists] for a reminder of how
    to use it. *)

(** If you want to find out how or where a notation is defined, the
    [Locate] command is useful.  For example, where is the natural
    addition operation defined in the standard library? *)

Locate "+".

(** There are several uses for that notation, but only one for
    naturals. *)

Print Init.Nat.add.

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  In [Lists.v] we introduced a fresh type [id] for a similar
    purpose; here and for the rest of _Software Foundations_ we will
    use the [string] type from Coq's standard library. *)

(** To compare strings, we define the function [eqb_string], which
    internally uses the function [string_dec] from Coq's string
    library. *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
    If you check the result type of [string_dec], you'll see that it
    does not actually return a [bool], but rather a type that looks
    like [{x = y} + {x <> y}], called a [sumbool], which can be
    thought of as an "evidence-carrying boolean."  Formally, an
    element of [{x = y} + {x <> y}] is either a proof that [x] and [y] are equal
    or a proof that they are unequal, together with a tag indicating
    which.  But for present purposes you can think of it as just a
    fancy [bool].) *)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

(** Two strings are equal according to [eqb_string] iff they
    are equal according to [=].  So [=] is reflected in [eqb_string],
    in the sense of "reflection" as discussed in [IndProp]. *)

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
   - rewrite Hs_eq. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. exfalso. apply Hs_not_eq. apply H.
Qed.

(** Similarly: *)

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This corollary follows just by rewriting: *)

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A : Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some new notations to facilitate working
    with maps. *)

(** First, we will use the following notation to create an empty
    total map with a default value. *)
Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation because it is just
    function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
    you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which is discussed in the [Logic] chapter.) *)

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

    First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  intros. unfold t_empty. reflexivity.
Qed.

(** [] *)

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

    Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update.
  rewrite <- eqb_string_refl.
  reflexivity.
Qed.
(** [] *)

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

    On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  intros. unfold t_update.
  rewrite <- eqb_string_false_iff in H. rewrite H. reflexivity.
Qed.

(** [] *)

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

    If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality. intro.
  destruct (string_dec x x0).
  - (* x = x0 *)
    apply eqb_string_true_iff in e.
    rewrite e.
    reflexivity.
  - (* x <> x0 *)
    apply eqb_string_false_iff in n.
    rewrite n.
    reflexivity.
Qed.

(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on strings with the boolean function [eqb_string]. *)

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

    Use the proof of [eqbP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros.
  apply iff_reflect. split.
  - (* -> *)
    intro. subst. symmetry. apply eqb_string_refl.
  - (* <- *)
    intros. apply eqb_string_true_iff in H.
    apply H.
Qed.

(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the tactic
    [destruct (eqb_stringP x1 x2)] to simultaneously perform case
    analysis on the result of [eqb_string x1 x2] and generate
    hypotheses about the equality (in the sense of [=]) of [x1]
    and [x2]. *)

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

    With the example in chapter [IndProp] as a template, use
    [eqb_stringP] to prove the following theorem, which states that
    if we update a map to assign key [x] the same value as it already
    has in [m], then the result is equal to [m]: *)

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros.
  apply functional_extensionality. intro.
  destruct (eqb_stringP x x0).
  - (* x = x0 *)
    subst. apply t_update_eq.
  - (* x <> x0 *)
    apply t_update_neq. apply n.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard, especially useful (t_update_permute)

    Use [eqb_stringP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros.
  apply functional_extensionality.
  intro.
  destruct (eqb_stringP x x1); destruct (eqb_stringP x x2).
  - (* x = x1; x = x2 contradiction *)
    subst. exfalso. apply H. reflexivity.
  - (* x = x1; x <> x2 *)
    subst.
    rewrite t_update_eq.
    rewrite t_update_neq; try rewrite t_update_eq.
    + reflexivity.
    + apply H.
  - (* x <> x1; x = x2 *)
    subst.
    rewrite t_update_eq.
    rewrite t_update_neq; try rewrite t_update_eq.
    + reflexivity.
    + intro. subst. apply H. reflexivity.
  - (* x <> x1; x <> x2 *)
    repeat rewrite t_update_neq.
    reflexivity.
    (* simple inequality cases that can all be found in assumption.
       can be solved by tactics. I'll skip them with auto.
     *)
    auto. auto. auto. auto.
Qed.

(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

(** Finally, for partial maps we introduce a notion of map inclusion,
    stating that one map includes another:  *)

Definition inclusion {A : Type} (m m' : partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

(** We show that map update preserves map inclusion, that is: *)

Lemma inclusion_update : forall (A : Type) (m m': partial_map A)
                              x vx,
  inclusion m m' ->
  inclusion (x |-> vx ; m) (x |-> vx ; m').
Proof.
  unfold inclusion.
  intros A m m' x vx H.
  intros y vy.
  destruct (eqb_stringP x y) as [Hxy | Hxy].
  - rewrite Hxy.
    rewrite update_eq. rewrite update_eq. intro H1. apply H1.
  - rewrite update_neq. rewrite update_neq.
    + apply H.
    + apply Hxy.
    + apply Hxy.
Qed.

(** This property is useful for reasoning about the lambda-calculus,
where maps are used to keep track of which program variables are
defined at a given point. *)

(* 2020-09-09 20:51 *)


Inductive vector A : nat -> Type :=
| nil : vector A 0
| cons : A -> forall n, vector A n -> vector A (S n).


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* a type class and other definitions for decidable equality *)

Set Implicit Arguments.
Require Import Bvector.
Require Import Arith.

Definition eq_dec(A : Set) := forall (a1 a2 : A), {a1 = a2} + {a1 <> a2}.

Class EqDec (A : Set) := {
  eqb : A -> A -> bool ;
  eqb_leibniz : forall x y, eqb x y = true <-> x = y
}.

Infix "?=" := eqb (at level 70) : eq_scope.
Infix "!=" := (fun x y => negb (eqb x y)) (at level 70) : eq_scope.

Theorem eqb_refl : forall (A : Set)(pf : EqDec A)(a : A),
  eqb a a = true.

  intuition.
  eapply eqb_leibniz.
  trivial.
Qed.

Theorem eqb_symm :
  forall (A : Set){eqd : EqDec A}(x y : A),
    eqb x y = eqb y x.

  intuition.
  case_eq (eqb x y); intuition.
  rewrite eqb_leibniz in H.
  subst.
  rewrite eqb_refl.
  trivial.

  case_eq (eqb y x); intuition.
  rewrite eqb_leibniz in H0; subst.
  rewrite eqb_refl in H.
  discriminate.

Qed.

Theorem EqDec_dec : forall A,
  EqDec A ->
  forall (a b : A), {a = b} + {a <> b}.

  intuition.
  remember (eqb a b) as x.
  destruct x.
  left.
  eapply eqb_leibniz.
  auto.

  right.
  intuition.
  subst.
  assert (eqb b b = true -> False).
  intuition.
  congruence.
  eapply H0.
  eapply eqb_leibniz.
  trivial.
Qed.

Theorem dec_EqDec : forall (A : Set)(eqd : eq_dec A),
  EqDec A.

  intuition.
  eapply (Build_EqDec (fun a1 a2 => if (eqd a1 a2) then true else false)).
  intuition.
  destruct (eqd x y); trivial.
  discriminate.

  destruct (eqd x y); trivial.
  congruence.

Qed.

Lemma vector_0 : forall (A : Set)(v : Vector.t A 0),
  v = Vector.nil A.

  intuition.
  eapply (Vector.case0 (fun v => v = [])).
  trivial.
Qed.

Lemma vector_S : forall (A : Set)(n : nat)(v : Vector.t A (S n)),
  exists a : _, exists v' : _,
    v = Vector.cons _ a _ v'.

  intuition.
  induction n, v using Vector.rectS.
  econstructor. econstructor. eauto.

  econstructor. econstructor. eauto.

Qed.

Definition eqb_vector(A : Set)(eqd : EqDec A)(n : nat)(v1 v2 : Vector.t A n) :=
  Vector.fold_left2 (fun b a1 a2 => b && (eqb a1 a2)) true v1 v2.

Theorem eqb_vector_refl :
  forall (A : Set)(eqd : EqDec A)(n : nat)(v : Vector.t A n),
    eqb_vector _ v v = true.

  induction n; intuition; simpl in *.
  rewrite (vector_0 v).
  unfold eqb_vector.
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  subst.
  unfold eqb_vector.
  simpl.
  rewrite eqb_refl.
  eapply IHn.

Qed.

Theorem vector_fold_false :
  forall (A : Set)(f : A -> A -> bool)(n : nat)(v1 v2 : Vector.t A n),
    Vector.fold_left2 (fun b a1 a2 => b && (f a1 a2)) false v1 v2 = false.

  induction n; intuition; simpl in *.
  rewrite (vector_0 v1).
  rewrite (vector_0 v2).
  simpl.
  trivial.

  destruct (vector_S v1).
  destruct (vector_S v2).
  destruct H.
  destruct H0.
  subst.
  simpl.
  eapply IHn.

Qed.

Theorem eqb_vector_leibniz:
  forall (A : Set)(eqd : EqDec A)(n : nat)(v1 v2 : Vector.t A n),
    eqb_vector _ v1 v2 = true -> v1 = v2.

  induction n; intuition; simpl in *.
  rewrite (vector_0 v1).
  rewrite (vector_0 v2).
  trivial.

  destruct (vector_S v1).
  destruct (vector_S v2).
  destruct H0.
  destruct H1.
  subst.
  unfold eqb_vector in H.
  simpl in *.
  case_eq (eqb x x0); intuition.
  rewrite eqb_leibniz in H0.
  subst.
  f_equal.
  rewrite eqb_refl in H.
  eapply IHn.
  eapply H.

  rewrite H0 in H.
  rewrite vector_fold_false in H.
  discriminate.
Qed.

Section Vector_EqDec.

  Variable A : Set.
  Context `{eqd_A : EqDec A}.

  Instance Vector_EqDec :
    forall (n : nat),
      EqDec (Vector.t A n).

  intuition.
  eapply (Build_EqDec (@eqb_vector A eqd_A n)).
  intuition.
  eapply eqb_vector_leibniz.
  trivial.
  subst.
  apply eqb_vector_refl.

  Qed.
End Vector_EqDec.

(*
Fixpoint BvIsZero n (v : Bvector n) : bool  :=
  match v with
    | Vector.nil => true
    | Vector.cons b _ v' =>
      (andb (if (bool_dec b false) then true else false) (BvIsZero v'))
  end.
*)

Instance unit_EqDec : EqDec unit := {eqb := (fun x y => true)}.

intuition.
destruct x.
destruct y.
trivial.

Qed.

Instance bool_EqDec : EqDec bool := {eqb := Bool.eqb}.
eapply eqb_true_iff.
Qed.

(* Bvector decidable equality was added before Vector.t decidable equality.  Definitions remain for compatibility. *)
Definition eqbBvector n (v1 v2 : Bvector n) : bool :=
  (eqb_vector _ v1 v2).

Theorem eqbBvector_sound : forall n (v1 v2 : Bvector n),
  eqbBvector v1 v2 = true -> v1 = v2.

  intuition.
  unfold eqbBvector in *.
  eapply eqb_vector_leibniz.
  trivial.
Qed.

Theorem eqbBvector_complete : forall n (v : Bvector n),
  eqbBvector v v = true.

  intuition.
  unfold eqbBvector.
  apply eqb_vector_refl.
Qed.

Instance Bvector_EqDec : forall n, EqDec (Bvector n) := {eqb := (@eqbBvector n)}.
intuition.
eapply eqbBvector_sound; auto.
intuition.
subst.
eapply eqbBvector_complete; eauto.
Defined.

Instance nat_EqDec : EqDec nat := {eqb := (fun x y => (leb x y) && (leb y x))}.

intuition.
apply andb_true_iff in H.
intuition.
eapply le_antisym;
eapply leb_iff; eauto.

apply andb_true_iff.
intuition;
eapply leb_iff; subst; eapply le_refl.
Qed.

Definition eqbPair (A B : Set)(dA : EqDec A)(dB : EqDec B)(p1 p2 : (A*B)) :=
  (eqb (fst p1) (fst p2)) && (eqb (snd p1) (snd p2)).

Instance pair_EqDec : forall (A B : Set)(dA : EqDec A)(dB : EqDec B), EqDec (prod A B) := {eqb := (@eqbPair A B dA dB)}.

intuition; unfold eqbPair in *; simpl in *.
apply andb_true_iff in H.
intuition.
f_equal;
eapply eqb_leibniz; trivial.

inversion H; subst; clear H.
apply andb_true_iff; intuition;
eapply eqb_leibniz; trivial.
Defined.

Definition eqbOption (A : Set)(dA : EqDec A)(o1 o2 : option A) :=
  match o1 with
    | None =>
      match o2 with
        | None => true
        | Some _ => false
      end
    | Some a1 =>
      match o2 with
        | None => false
        | Some a2 => (eqb a1 a2)
      end
  end.

Instance option_EqDec : forall (A : Set)(dA : EqDec A), EqDec (option A) := {eqb := (@eqbOption A dA )}.

intuition; unfold eqbOption in *; simpl in *.
destruct x.
destruct y.
f_equal.
eapply eqb_leibniz; trivial.
discriminate.
destruct y.
discriminate.
trivial.

subst.

destruct y.
eapply eqb_leibniz; trivial.
trivial.
Qed.

Local Open Scope list_scope.
Fixpoint eqbList(A : Set)(eqd : EqDec A)(ls1 ls2 : list A) :=
  match ls1 with
    | nil =>
      match ls2 with
        | nil => true
        | _ :: _ => false
      end
    | a1 :: ls1' =>
      match ls2 with
        | nil => false
        | a2 :: ls2' =>
          (eqb a1 a2) && (eqbList _ ls1' ls2')
      end
  end.

Lemma eqbList_correct1 : forall (A : Set)(eqd : EqDec A) ls1 ls2,
  eqbList eqd ls1 ls2 = true ->
  ls1 = ls2.

  induction ls1; destruct ls2; intuition; simpl in *; try discriminate.
  apply andb_true_iff in H.
  intuition.
  f_equal.
  eapply eqb_leibniz.
  trivial.
  eauto.
Qed.

Lemma eqbList_correct2 : forall (A : Set)(eqd : EqDec A) ls1 ls2,
  ls1 = ls2 ->
  eqbList eqd ls1 ls2 = true.

  induction ls1; destruct ls2; intuition; simpl in *; try discriminate.
  inversion H; clear H; subst.

  apply andb_true_iff.
  intuition.
  eapply eqb_leibniz.
  trivial.
Qed.

Instance list_EqDec : forall (A : Set)(dA : EqDec A), EqDec (list A) := {eqb := (@eqbList A dA )}.

intuition.
eapply eqbList_correct1; trivial.
eapply eqbList_correct2; trivial.
Qed.

Theorem eqb_false_iff :
  forall (A : Set)(eqd : EqDec A)(a1 a2 : A),
    eqb a1 a2 = false <->
    a1 <> a2.

  intuition.
  subst.
  rewrite eqb_refl in H.
  discriminate.

  case_eq (eqb a1 a2); intuition.
  rewrite eqb_leibniz in H0.
  intuition.

Qed.

Theorem eqbPair_symm :
  forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B) (p1 p2 : (A * B)),
    eqbPair _ _ p1 p2 = eqbPair _ _ p2 p1.

  intuition.
  unfold eqbPair in *.
  simpl.
  rewrite eqb_symm.
  rewrite (eqb_symm b b0).
  trivial.

Qed.


(** Yooooosh! Avec un peu de retard, voici mon petit tutoriel sur SSReflect.
* Je t'y partage un peu de tout ce que j'ai appris, en esperant que ce ne soit pas trop confus et assez ordone
* Donc commencons sans plus attendre ^^ *)

Require Export ssreflect.
Require Import ssrnat.
Require Import ssrbool.
Require Import ssrfun.
Require Import seq.
Require Import Permutation.
Require Import eqtype.
(*TODO: Reecrire les bibliotheques dans le bon ordre*)

(****** La gestion de la stack *****)
(** Comme je t'expliquais, SSReflect permet de manipuler la stack de facon tres fluide. Prenons par exemple: *)

Lemma Test_move_stack A B C: (A -> B -> C) -> (A -> B) -> A -> C.
move => Habc Hab Ha.
(** On voit la notre premier symbole chelou. => permet de poper de la stack de preuve un objet*)
move : Habc.
(** Et voici notre second. : lui push un objet sur la stack. Bien entendu on peut les combiner: *)
move : Hab => Hba.
(** A ton avis que c'est il passe? Vi, on a renomme Hab en Hba. En gros, l'ordre a retenir pour l'instant c'est que : arrive avant la tactique et => apres. Ca veut notamment dire qu'on ne peut pas ecrire cela:
* move => Hba : Ha.
* Car l'ordre ne serait pas respecte. Cette question d'ordre assure une certaine coherence en SSReflect ainsi que des lignes de codes relativement courtes.*)
apply.
(** Voila une seconde tactique. Apply prend l'hypothese du haut de la pile et essaie de l'appliquer au but. Presque toute les tactiques de SSR ne prennent pas d'argument et fonctionne plutot sur l'hyppothese en debut de pile *)
apply: Ha.
apply: Hba.
apply: Ha.
Qed.

(*Bien sur, on aurait pu combiner le tout et donner une version de la preuve plus fluide:*)
Lemma Test2 A B C: (A -> B -> C) -> (A -> B) -> A -> C.
move => Habc Hab Ha.
apply: (Habc Ha (Hab Ha)).
Qed.

(*En fait, plutot que apply, on aurait plus utiliser exact. Exact est ce qu'on appelle un terminateur. Ce sont certaines tactiques comme done et by qui  finissent la preuve. C'est une bonne pratique d'utiliser ceux ci en fin de preuve*)

(*Lemma Test_final A B C: (A

apply: Habc.
apply: Ha.

pply: Hab.
apply: Ha.
Qed.*)

(* Tu t'en doutes, cette façon de proceder est assez fastidieuse. En fait, ce genre de tactique peut bient *)

Section ABR.
        Variable T: eqType.
        Hypotheses (R: rel T).
                   (* (R_trans: transitive R)
                      (R_total: total R)
                      (R_antisym: antisymmetric R).*)

Inductive Arbre : Type :=
|Leaf
|Node of T & Arbre & Arbre.

Inductive in_Arbre (a: T) (arb: Arbre) : Prop:=
|in_now l r of arb = Node a l r
|in_left b l r of arb = Node b l r & in_Arbre a l
|in_right b l r of arb = Node b l r & in_Arbre a r.
Implicit Arguments in_now [a arb].

Implicit Arguments in_right [a arb].

Fixpoint naive_in_b (a: T) (arb : Arbre) := match arb with
|Leaf => false
|Node b l r =>  (b == a) || naive_in_b a l || naive_in_b a r
end.

Lemma naive_in_bP arb a: reflect (in_Arbre a arb) (naive_in_b a arb).
elim: arb;
    first by apply: ReflectF; case.
move => s l HreflectL r HreflectR.
rewrite /naive_in_b -/naive_in_b.
case eqas: (s == a).
    by move /eqP : eqas <-; apply: ReflectT; apply (in_now l r).
case inl : (naive_in_b a l) => /=.
    by apply: ReflectT; apply: (in_left s l r) => //; apply /HreflectL : inl.
case inr : (naive_in_b a r) => /=.
    by apply: ReflectT; apply: (in_right s l r) => //; apply /HreflectR : inr.
apply: ReflectF.
case.
    by move /eqP: eqas; move => eqas _ _ [] //.
    by move /HreflectL: inl; move => inl _ _ _ [_ <- _] //.
    by move /HreflectR: inr; move => inr _ _ _ [_ _ <-] //.
Qed.

Inductive ABR (arb: Arbre) :Prop :=
|ABR_intro s l r of arb = Node s l r & ABR l & ABR r &
                   (forall a, in_Arbre a l -> R a s) &
                   (forall b, in_Arbre b r -> ~~(R b s)).

Definition singleton a := Node a Leaf Leaf.

Inductive insert_at_leaf a arb res : Prop :=
|insert_leaf of arb = Leaf & res = singleton a

Inductive in_Arbre (a: T) (arb: Arbre) : Prop:=
|in_now l r of arb = Node a l r
|in_left b l r of arb = Node b l r & in_Arbre a l
|in_right b l r of arb = Node b l r & in_Arbre a r.
Implicit Arguments in_now [a arb].
Implicit Arguments in_right [a arb].

Fixpoint naive_in_b (a: T) (arb : Arbre) := match arb with
|Leaf => false
|Node b l r =>  (b == a) || naive_in_b a l || naive_in_b a r
end.

Lemma naive_in_bP arb a: reflect (in_Arbre a arb) (naive_in_b a arb).
elim: arb;
    first by apply: ReflectF; case.
move => s l HreflectL r HreflectR.
rewrite /naive_in_b -/naive_in_b.
case eqas: (s == a).
    by move /eqP : eqas <-; apply: ReflectT; apply (in_now l r).
case inl : (naive_in_b a l) => /=.
    by apply: ReflectT; apply: (in_left s l r) => //; apply /HreflectL : inl.
case inr : (naive_in_b a r) => /=.
    by apply: ReflectT; apply: (in_right s l r) => //; apply /HreflectR : inr.
apply: ReflectF.
case.
    by move /eqP: eqas; move => eqas _ _ [] //.
    by move /HreflectL: inl; move => inl _ _ _ [_ <- _] //.
    by move /HreflectR: inr; move => inr _ _ _ [_ _ <-] //.
Qed.

Inductive ABR (arb: Arbre) :Prop :=
|ABR_intro s l r of arb = Node s l r & ABR l & ABR r &
                   (forall a, in_Arbre a l -> R a s) &
                   (forall b, in_Arbre b r -> ~~(R b s)).

Definition singleton a := Node a Leaf Leaf.

Inductive insert_at_leaf a arb res : Prop :=
|insert_leaf of arb = Leaf & res = singleton a
|insert_left b r of arb = Node b Leaf r & res = Node b (singleton a) r
|insert_right b l of arb = Node b l Leaf & res = Node b l (singleton a).
Implicit Arguments insert_leaf [a arb res].
Implicit Arguments insert_left [a arb res].
Implicit Arguments insert_right [a arb res].

Lemma ABR_left a l r : ABR (Node a l r) -> ABR l.
by move => [] _ _ _ [] <- <- <-.
Qed.
Lemma ABR_right a l r: ABR (Node a l r) -> ABR r.
by move => [] _ _ _ [] <- <- <-.
Qed.
Program Fixpoint insert a arb (h: ABR arb): {res | insert_at_leaf a arb res /\ ABR res}
                := match arb with
|Leaf => Node a Leaf Leaf
|Node b l r => if (R a b) then Node b (insert a l (ABR_left b l r h)) r else Node b l (insert a r (ABR_right b l r h))
                end.
Proof.
        Next Obligation.
split.
by apply: insert_leaf.
exists a Leaf Leaf => //.
by move => ? [].
by move => ? [].
Qed.
    Next Obligation.
split.
case: (R a b).
case: i0 => [-> ->| |].
by apply: (insert_left b r).
move => ? ? -> ->.
by apply: (insert_
done.

Inductive in_ABR a (arb: Arbre): Prop :=
|in_ABR_now l r of arb = Node a l r
|in_ABR_left b l r of arb = Node b l r & R a b & in_ABR a l
|in_ABR_right b l r of arb = Node b l r & ~~(R a b) & in_ABR a r.
Implicit Arguments in_ABR_now [a arb].
Implicit Arguments in_ABR_left [a arb].
Implicit Arguments in_ABR_right [a arb].

Lemma in_ABR_in_equiv (arb: Arbre) a : ABR arb -> (in_ABR a arb <-> in_Arbre a arb).
move => HARB.
split.

- elim.
      by move => _ l r ->; apply: (in_now l r).
      by move => _ b l r -> _ _; apply: (in_left b l r).
      by move => _ b l r -> _ _; apply: (in_right b l r).

- move => Hin.
  elim: Hin HARB.
      by move => _ l r -> _; apply (in_ABR_now l r).
  move => _ b l r -> HinArbre HinABR.
  move => [] // _ _ _ [] <- <- <- HABRl _ Hinf _.
  apply: (in_ABR_left b l r) => //.
      by apply: Hinf => //.
      by apply: HinABR.
  move => _ b l r -> HinArbre HinABR.
  move => [] // _ _ _ [] <- <- <- _ HABRr _ Hsup.
  apply: (in_ABR_right b l r) => //.
      by apply: Hsup => //.
      by apply: HinABR.
Qed.

Fixpoint in_b_abr a arb := match arb with
|Leaf => false
|Node b l r => (b == a) || (if R a b then in_b_abr a l else in_b_abr a r)
end.

Lemma in_b_abr_P a arb : reflect (in_ABR a arb) (in_b_abr a arb).
elim: arb.
    by apply: ReflectF; case.
move => s l HrefL r HrefR.
rewrite /in_b_abr -/in_b_abr.
case eqas: (s == a).
    by move /eqP : eqas <-; apply: ReflectT; apply (in_ABR_now l r).
case Ras: (R a s).
case inl: (in_b_abr a l).
    apply: ReflectT.
    apply: (in_ABR_left s l r) => //; apply /HrefL : inl.
    apply: ReflectF.
    case.
|xor_gt of n > m : xor_le_gt n m false true.

Lemma xor_P n m: xor_le_gt n m (n <= m) (n > m).
Proof.
        rewrite ltnNge.
case X : (n <= m).
  + constructor => //.
  + constructor by rewrite ltnNge X.
Qed.

Lemma not_le_gt n m: (n <= m) -> (n > m) -> False.
by case: xor_P.
move => Hnm Hmn.
move : (conj Hnm Hmn).
move /andP.
by case: xor_P.
Qed.

Section Perm.
Variable T: eqType.

Fixpoint Occurence a (l: seq T) := if l is b::l' then ((a == b) + Occurence a l') else O.

Lemma Occurence_cons a l : Occurence a (a :: l) = (Occurence a l) .+1.
Proof. by rewrite /Occurence eq_refl. Qed.
Lemma Occurence_ignore b l a: (a == b) = false -> Occurence a (b :: l) = Occurence a l.
Proof. by move => /= ->. Qed.

Definition Permutation_Occ l l' := nosimpl (forall a, Occurence a l = Occurence a l').

Lemma PO_sym l l' : Permutation_Occ l l' -> Permutation_Occ l' l.
Proof. by move => PO z. Qed.

Lemma PO_cons a l l': Permutation_Occ (a::l) (a::l') -> Permutation_Occ l l'.
Proof.
move => PO z.
move /(_ z) : PO.
rewrite !/Occurence.
case (z == a); [by move => [] | done].
Qed.

Lemma PO_nil l : Permutation_Occ nil l -> l = nil.
Proof.
case: l.
    done.
move => a ? /(_ a) /=.
by rewrite eq_refl.
Qed.

Lemma PO_singleton a l : Permutation_Occ [::a] l -> l = [::a].
Proof.
case: l => [/PO_sym /PO_nil | b l].
    done.
case X : (b == a).
    by move /eqP : X => -> /PO_cons /PO_nil ->.
move / (_ b).
rewrite Occurence_cons Occurence_ignore => //.
Qed.

Fixpoint insert_at (a: T) n s := match n, s with
|S m, b::s' => b :: (insert_at a m s')
|_, _ => a::s
end.

Lemma insert_nil a n : insert_at a n [::] = [:: a].
Proof. by case : n. Qed.
Lemma insert_zero a l : insert_at a 0 l = a :: l.
Proof. done. Qed.
Lemma insert_cons a n b l : insert_at a n.+1 (b::l) = b::(insert_at a n l).
Proof. done. Qed.

Lemma Occurence_insert_cons a l n: (Occurence a (insert_at a n l)) = (Occurence a l) .+1.
Proof.
elim: n a l => [| n Hrec] a l.
    by rewrite Occurence_cons.
case: l => [| b l] /=.
    by rewrite eq_refl.
    by rewrite Hrec.
Qed.

Lemma Occurence_insert_ignore a l n z: (z == a) = false -> (Occurence z (insert_at a n l)) = Occurence z l.
elim: n a l z => [|n Hrec] a l z.
    by move => /= ->.
case: l => [/= -> | b l Hneq /=].
    done.
by rewrite Hrec.
Qed.

Lemma Permutation_insert_swap n a l: Permutation (insert_at a n l) (insert_at a n.+1l).
Proof.
elim: n a l => [| m Hrec] a l.
    case: l => *.
        by rewrite !insert_nil; exact: Permutation_refl.
        exact: perm_swap.
case: l => [|b l].
    by rewrite !insert_nil; exact: Permutation_refl.
rewrite !insert_cons.
apply: perm_skip.
apply: Hrec.
Qed.

Lemma Permutation_insert_double n m a l : Permutation (insert_at a n l) (insert_at a m l).
Proof.
wlog : n m /(n <= m).
    by case: (leqP n m) => [| /ltnW] X /(_ _ _ X) => //; exact: Permutation_sym.
move => /leP Hle.
elim: Hle a l => [|m' Hle Hrec] a l.
    exact: Permutation_refl.
apply: (Permutation_trans (Hrec _ _)).
exact: Permutation_insert_swap.
Qed.

Lemma Permutation_insert_head a n l l': Permutation l l' -> Permutation (a::l) (insert_at a n l').
Proof.
elim: n l l' a => [| m Hrec] l l' a PO.
    exact : perm_skip.
case: l' PO => [/Permutation_sym /Permutation_nil -> | b l' PO].
    by rewrite insert_nil; exact: Permutation_refl.
apply: (Permutation_trans (Hrec _ (b :: l') _ _)) => //.
exact: Permutation_insert_double.
Qed.

Lemma PO_insert_inv a n l l' : Permutation_Occ (a::l) (insert_at a n l') -> Permutation_Occ l l'.
Proof.
move => PO z.
case X: (z == a); last first.
    by rewrite -(Occurence_ignore a _ _ X) -(Occurence_insert_ignore a l' n) => //.
move : X => /eqP ->.
apply /eq_add_S.
rewrite -(Occurence_insert_cons a l' n) -Occurence_cons.
exact: PO.
Qed.

CoInductive insert_spec a : seq T -> Type :=
    insert_spec_intro l n: insert_spec a (insert_at a n l).

Lemma extract_insert a: forall l, 0 < Occurence a l -> insert_spec a l.
Proof.
elim => [| b l Hrec] Hocc.
    done.
case X: (a == b).
    by move : X => /eqP ->; rewrite -insert_zero; split.
move: Hrec => [|l' n].
    by rewrite -(Occurence_ignore b).
rewrite -insert_cons.
by split.
Qed.

Inductive insert_permutation: seq T -> seq T -> Type :=
|Perm_nil : insert_permutation nil nil
|Perm_add a n l l' of insert_permutation l l' : insert_permutation (a::l) (insert_at a n l').

Lemma Extract_perm: forall l l', Permutation_Occ l l' -> insert_permutation l l'.
Proof.
elim => [_ /PO_nil -> | a l Hrec l' PO].
     exact: Perm_nil.
move:(extract_insert a l') (PO) => [|tl' n POtl'].
    by move : PO => /(_ a) /= <-; rewrite eq_refl.
apply: Perm_add.
apply: Hrec.
exact: (PO_insert_inv a n).
Qed.

Lemma Instanciate_perm l l' : insert_permutation l l' -> Permutation l l'.
elim => *.
    by exact: perm_nil.
    by exact: Permutation_insert_head.
Qed.

Lemma Permutation_Occ_Permutation l l': Permutation_Occ l l' -> Permutation l l'.
Proof.
move => /(Extract_perm).
exact: Instanciate_perm.
Qed.

Lemma Permutation_Permutation_Occ l l': Permutation l l' -> Permutation_Occ l l'.
Proof.
elim => [| x l_ l_' _ PO /=| x y l_| l_ l_' l_'' _ eq1 _ eq2] z /=.
    done.
    by move : PO => /(_ z) ->.
    by ring.
    by move : eq1 eq2 => /(_ z) eq1 /(_ z) eq2; transitivity (Occurence z l_').
Qed.

Lemma Permutation_equiv l l' : Permutation l l' <-> Permutation_Occ l l'.
split.
    exact: Permutation_Permutation_Occ.
    exact: Permutation_Occ_Permutation.
Qed.