(* An operation that returns a (uniformly distributed) random element from a list *)

Set Implicit Arguments.

Require Import FCF.

Section RndListElem.

  Variable A : Set.
  Hypothesis eqd : EqDec A.

  Local Open Scope list_scope.

  Definition rndListElem(ls : list A) : Comp (option A) :=
    match (length ls) with
      | O => ret None
      | S _ =>
        i <-$ [0 .. (length ls));
          ret (nth_option ls i)
    end.

  Theorem rndListElem_wf :
    forall (ls : list A),
      well_formed_comp (rndListElem ls).

    intuition.
    unfold rndListElem.
    case_eq (length ls); intuition; wftac.
  Qed.

End RndListElem.

Local Open Scope list_scope.

Lemma rndListElem_support:
      forall (A : Set)(eqd : EqDec A)(ls : list A) a,
        In a ls <->
        In (Some a) (getSupport (rndListElem eqd ls)).

      intuition.
      unfold rndListElem.
      case_eq (length ls); intuition.
      exfalso.
      destruct ls; simpl in *; intuition.

      eapply getSupport_In_Seq.

      eapply in_getSupport_RndNat.

      Fixpoint firstIndexOf(A : Set)(eqd : eq_dec A)(ls : list A)(a : A)(def : nat) :=
        match ls with
            | nil => def
            | a' :: ls' =>
              if (eqd a a') then O else (S (firstIndexOf eqd ls' a def))
        end.

      Theorem firstIndexOf_in_lt :
        forall (A : Set)(eqd : eq_dec A)(ls : list A)(a : A)(def : nat),
          In a ls ->
          firstIndexOf eqd ls a def < length ls.

        induction ls; intuition; simpl in *;
        intuition.

        subst.
        destruct (eqd a0 a0); subst.
        omega.
        intuition.

        destruct (eqd a0 a); subst.
        omega.

        eapply lt_n_S.
        eauto.

      Qed.

      Theorem nth_firstIndexOf :
        forall (A : Set)(eqd : eq_dec A)(ls : list A)(a : A)(def : nat),
          In a ls ->
          nth_option ls (firstIndexOf eqd ls a def) = Some a.

        induction ls; intuition; simpl in *.
        intuition.

        intuition.
        subst.
        destruct (eqd a0 a0); subst; intuition.

        destruct (eqd a0 a); subst; intuition.

      Qed.

      rewrite <- H0.
      eapply firstIndexOf_in_lt; eauto.
      simpl.
      left.

      eapply nth_firstIndexOf; trivial.

      unfold rndListElem in *.
      repeat simp_in_support.
      discriminate.

      Theorem nth_option_In :
        forall (A : Set)(ls : list A)(a : A) i,
          nth_option ls i = Some a ->
          In a ls.

        induction ls; intuition; simpl in *.
        discriminate.

        destruct i.
        inversion H; clear H; subst.
        intuition.
        right.
        eapply IHls.
        eauto.

      Qed.

      eapply nth_option_In; eauto.

      Grab Existential Variables.
      apply O.
      unfold eq_dec.
      eapply (EqDec_dec eqd).
    Qed.

 Theorem rndListElem_uniform :
   forall (A : Set)(eqd : EqDec A)(ls : list A)(a1 a2 : option A),
     NoDup ls ->
     In a1 (getSupport (rndListElem _ ls)) ->
     In a2 (getSupport (rndListElem _ ls)) ->
     evalDist (rndListElem _ ls) a1 ==
     evalDist (rndListElem _ ls) a2.

   intuition.

   destruct a1.
   destruct a2.

   rewrite <- rndListElem_support in *.

   unfold rndListElem.
   case_eq (length ls); intuition.
   destruct ls; simpl in *. intuition. omega.

   eapply comp_spec_impl_eq.

   eapply comp_spec_seq.
   apply (Some a).
   apply (Some a).
   eapply eq_impl_comp_spec.
   eapply well_formed_RndNat.
   omega.
   eapply well_formed_RndNat.
   omega.
   eapply RndNat_uniform.
   Focus 3.
   intros.
   simpl in H5.

   eapply comp_spec_ret.
   assert (a1 = (firstIndexOf (EqDec_dec _) ls a 0) <->
     b = (firstIndexOf (EqDec_dec _) ls a0 0)).
   eapply H5.
   clear H5.
   intuition; subst.

   rewrite H5.
   eapply nth_firstIndexOf; trivial.

   Theorem nth_firstIndexOf_if :
     forall (A : Set)(eqd : eq_dec A)(ls : list A) n a,
       nth_option ls n = Some a ->
       NoDup ls ->
       firstIndexOf eqd ls a 0 = n.

     induction ls; intuition; simpl in *.
     discriminate.
     inversion H0; clear H0; subst.
     destruct n.
     inversion H; clear H; subst.
     destruct (eqd a0 a0); subst; intuition.

     destruct (eqd a0 a); subst; intuition.
     exfalso.
     eapply H3.

     eapply nth_option_In.
     eauto.

   Qed.

   symmetry.
   eapply nth_firstIndexOf_if; intuition.

   rewrite H7.
   eapply nth_firstIndexOf; trivial.
   symmetry.
   eapply nth_firstIndexOf_if; intuition.

   rewrite <- H2.
   apply firstIndexOf_in_lt; trivial.

   rewrite <- H2.
   apply firstIndexOf_in_lt; trivial.

   apply rndListElem_support in H0.

   Theorem nth_option_some :
     forall (A : Set)(ls : list A) n,
       n < length ls ->
       exists a, nth_option ls n = Some a.

     induction ls; intuition; simpl in *.
     omega.

     destruct n.
     econstructor; eauto.

     destruct (IHls n).
     omega.

     econstructor; eauto.

   Qed.

   Theorem rndListElem_support_None :
     forall (A : Set) eqd (ls : list A),
       In None (getSupport (rndListElem eqd ls)) <->
       ls = nil.

     intuition.
     unfold rndListElem in *.
     case_eq (length ls); intuition.
     destruct ls; simpl in *; trivial; discriminate.

     rewrite H0 in H.
     repeat simp_in_support.
     apply RndNat_support_lt in H1.

     edestruct (nth_option_some ls); eauto.
     rewrite H0.
     eauto.
     congruence.

     subst.
     simpl.
     intuition.

   Qed.

   Show.

   apply rndListElem_support_None in H1.
   subst.
   simpl in *.
   intuition.

   destruct a2.
   apply rndListElem_support in H1.
   apply rndListElem_support_None in H0.
   subst.
   simpl in *.
   intuition.

   intuition.

Qed.

      Theorem nth_firstIndexOf_None :
        forall (A : Set)(eqd : eq_dec A)(ls : list A),
          NoDup ls ->
          forall (a a' : A) i,
          In a ls ->
          i <> firstIndexOf eqd ls a O ->
          nth_option ls i = Some a' ->
          a <> a'.

        induction 1; intuition; simpl in *.
        intuition; subst.
        destruct (eqd a' a'); subst; intuition.

        destruct i; intuition.

        Lemma not_in_nth_option :
          forall (A : Set)(ls : list A)(a : A)(i : nat),
            (~In a ls) ->
            nth_option ls i = Some a ->
            False.

          induction ls; intuition; simpl in *.
          discriminate.

          destruct i.
          inversion H0; clear H0; subst.
          intuition.

          eapply IHls; eauto.

        Qed.

        eapply not_in_nth_option; eauto.

        destruct i; intuition.
        inversion H3; clear H3; subst.
        destruct (eqd a' a'); subst; intuition.

        destruct (eqd a' x); subst; intuition.
        eapply IHNoDup; eauto.
      Qed.

        Lemma nth_option_not_None :
          forall (A : Set)(ls : list A)(i : nat),
            i < length ls ->
            nth_option ls i = None ->
            False.

          induction ls; intuition; simpl in *.
          omega.

          destruct i.
          discriminate.
          assert (i < length ls).
          omega.
          eauto.

        Qed.

    Theorem rndListElem_uniform_gen :
      forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(ls1 : list A)(ls2 : list B)(a1 :  A)(a2 : B),
        NoDup ls1 ->
        NoDup ls2 ->
        length ls1 = length ls2 ->
        In a1 ls1 ->
        In a2 ls2 ->
        comp_spec
          (fun x y => x = Some a1 <-> y = Some a2)
          (rndListElem _ ls1) (rndListElem _ ls2).

      intuition.

      unfold rndListElem.
      case_eq (length ls1); intuition.
      rewrite <- H1.
      rewrite H4.

      eapply comp_spec_ret; intuition.
      discriminate.
      discriminate.

      rewrite <- H1.
      rewrite H4.

      eapply comp_spec_seq; try eapply None.
      eapply eq_impl_comp_spec.
      eapply well_formed_RndNat; omega.
      eapply well_formed_RndNat; omega.
      eapply (@RndNat_uniform  (firstIndexOf (EqDec_dec _) ls1 a1 O) (firstIndexOf (EqDec_dec _) ls2 a2 O)).

      rewrite <- H4.
      apply firstIndexOf_in_lt; trivial.
      rewrite <- H4.
      rewrite H1.
      apply firstIndexOf_in_lt; trivial.

      intuition.
      eapply comp_spec_ret.
      intuition.

      destruct (eq_nat_dec a (firstIndexOf (EqDec_dec _) ls1 a1 O)).
      subst.
      assert (b = firstIndexOf (EqDec_dec _) ls2 a2 0); intuition.
      subst.
      repeat rewrite nth_firstIndexOf; intuition.

      assert (b <> firstIndexOf (EqDec_dec _) ls2 a2 0).
      intuition.

      exfalso.
      eapply nth_firstIndexOf_None.
      eapply H.
      eapply H2.
      eapply n0.
      eauto.
      intuition.

      destruct (eq_nat_dec a (firstIndexOf (EqDec_dec _) ls1 a1 O)).
      subst.
      assert (b = firstIndexOf (EqDec_dec _) ls2 a2 0); intuition.
      subst.
      repeat rewrite nth_firstIndexOf; intuition.

      assert (b <> firstIndexOf (EqDec_dec _) ls2 a2 0).
      intuition.

      exfalso.
      eapply nth_firstIndexOf_None.
      eapply H0.
      eapply H3.
      eapply H10.
      eauto.
      intuition.
    Qed.

     Theorem rndListElem_support_exists :
      forall (A : Set)(eqd : EqDec A)(ls : list A),
        exists x,
          In x (getSupport (rndListElem eqd ls)).

      destruct ls; intuition.
      econstructor.
      left.
      eauto.

      unfold rndListElem.
      unfold length.
      econstructor.
      eapply getSupport_In_Seq.

      eapply (@in_getSupport_RndNat O).
      omega.
      simpl.
      intuition.
    Qed.

    (*

    Theorem rndListElem_uniform_remove_eq :
      forall (A : Set)(eqd : EqDec A)(ls : list A)(a1 a2 : A),
        NoDup ls ->
        evalDist (rndListElem _ (removeFirst (EqDec_dec _) ls a1)) (Some a1) == 0.

      intuition.
      eapply getSupport_not_In_evalDist.
      intuition.
      rewrite <- rndListElem_support in H0.
      eapply removeFirst_NoDup_not_in; eauto.
    Qed.

    Notation "$ c1 " := (rndListElem _ c1%comp)
                          (right associativity, at level 89, c1 at next level) : comp_scope.

 Theorem rndListElem_support_exists :
      forall (A : Set)(eqd : EqDec A)(ls : list A),
        exists x,
          In x (getSupport (rndListElem eqd ls)).

      destruct ls; intuition.
      econstructor.
      left.
      eauto.

      unfold rndListElem.
      unfold length.
      econstructor.
      eapply getSupport_In_Seq.

      eapply (@in_getSupport_RndNat O).
      omega.
      simpl.
      intuition.
    Qed.

*)


Definition HYP (P Q : Prop) : Prop := (P->Q) /\ P.

Definition THM := forall P Q : Prop, HYP P Q -> Q.

Theorem thm_proof : THM.
Show Proof.
intros p q.
Show Proof.
intro conj.
Show Proof.
destruct conj as [imp pp].
Show Proof.
apply imp.
Show Proof.
apply pp.
Qed.

Definition hypfun (P Q : Prop) (hyp : HYP P Q) : Q :=
match hyp with
| conj imp pp => imp pp
end.

Definition thmfun : THM := hypfun.

Definition identity_nat : nat -> nat.
intro n.
apply n.
Qed.

Definition zero_nat : nat -> nat.
intro n.
apply O.
Qed.

Definition successor_nat : nat -> nat.
intro n.
apply S.
apply n.
Qed.

Print identity_nat.
Print zero_nat.
Print successor_nat.


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

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

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 drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
  + intros. reflexivity.
  + destruct n2.
    * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
    * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
  + intros. destruct n. reflexivity. reflexivity.
  + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (u : natural) (v : natural) (w : natural) (x : natural) (y : natural) (z : lst),
  eq (drop (Succ u) (drop v (drop (Succ w) (Cons x (Cons y z))))) (drop (Succ u) (drop v (drop w (Cons x z)))).
Proof.
intros.
rewrite lem.
rewrite lem.
lfind.
Admitted.


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.
Require Export Iron.Language.SystemF2Effect.Store.Bind.

(********************************************************************)
(* Small Step Evaluation (pure rules)
   These are pure transitions that don't depend on the store. *)
Inductive StepP : exp  -> exp -> Prop :=

 (* Value application. *)
 | SpAppSubst
   :  forall t11 x12 v2
   ,  StepP (XApp (VLam t11 x12) v2)
            (substVX 0 v2 x12)

 (* Type application. *)
 | SpAPPSubst
   :  forall k11 x12 t2
   ,  StepP (XAPP (VLAM k11 x12) t2)
            (substTX 0 t2 x12)

 (* Take the successor of a natural. *)
 | SpSucc
   :  forall n
   ,  StepP (XOp1 OSucc (VConst (CNat n)))
            (XVal (VConst (CNat (S n))))

 (* Test a natural for zero. *)
 | SpIsZero
   :  forall n
   ,  StepP (XOp1 OIsZero (VConst (CNat n)))
            (XVal (VConst (CBool (beq_nat n 0)))).

Hint Constructors StepP.

(********************************************************************)
(* Preservation for pure single step rules. *)
Lemma stepp_preservation
 :  forall se sp x x' t e
 ,  StepP  x x'
 -> Forall ClosedT se
 -> TypeX  nil nil se sp x  t e
 -> TypeX  nil nil se sp x' t e.
Proof.
 intros se sp x x' t e HS HC HT. gen t e.
 induction HS; intros; inverts_type; rip.

 Case "SpAppSubst".
  eapply subst_val_exp; eauto.

 Case "SpAPPSubst".
  rrwrite (TBot KEffect = substTT 0 t2 (TBot KEffect)).
  have HTE: (nil = substTE 0 t2 nil).
  have HSE: (se  = substTE 0 t2 se) by (symmetry; auto).
  rewrite HTE. rewrite HSE.
  eapply subst_type_exp; eauto.
   rrwrite (liftTE 0 se = se).
   snorm.

 Case "SpSucc".
  snorm. inverts H5. auto.

 Case "SpIsZero".
  snorm. inverts H5. auto.
Qed.


Require Export Coq.Unicode.Utf8.
Require Export FExistsProd.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _    => True
    | tabs _     => True
    | pack _ t _ => Value t
    | prod x y   => Value x ∧ Value y
    | _          => False
  end.

Inductive Match : Pat → Tm → Tm → Tm → Prop :=
  | M_Var {T v t} :
      Match (pvar T) v t (substTm X0 v t)
  | M_Prod {p1 p2 v1 v2 t t' t''} :
      Match p2 (weakenTm v2 (bindPat p1)) t t' →
      Match p1 v1 t' t'' →
      Match (pprod p1 p2) (prod v1 v2) t t''.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | tapptabs {T2 t11} :
      red (tapp (tabs t11) T2) (tsubstTm X0 T2 t11)
  | E_UnpackPack {T11 v12 T1 t2} :
      Value v12 →
      red (unpack (pack T11 v12 (texist T1)) t2)
          (tsubstTm X0 T11 (substTm X0 (tshiftTm C0 v12) t2))
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tapp t1 T2) (tapp t1' T2)
  | E_pack {T11 t12 t12' T1} :
      red t12 t12' → red (pack T11 t12 T1) (pack T11 t12' T1)
  | E_unpack {t1 t1' t2} :
      red t1 t1' → red (unpack t1 t2) (unpack t1' t2)
  | prodl {t1 t1' t2} :
      red t1 t1' → red (prod t1 t2) (prod t1' t2)
  | prodr {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (prod t1 t2) (prod t1 t2')
  | casep {p t1 t1' t2} :
      red t1 t1' → red (case t1 p t2) (case t1' p t2)
  | casev {p t1 t3 t2} :
      Value t1 → Match p t1 t2 t3 → red (case t1 p t2) t3.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.Head.

Local Open Scope Z_scope.

Module Z.
  Definition eq_dec_cps {T} (x y : Z) (f : {x = y} + {x <> y} -> T) : T
    := f (Z.eq_dec x y).
  Definition eq_dec_cps_correct {T} x y f : @eq_dec_cps T x y f = f (Z.eq_dec x y)
    := eq_refl.
  Hint Rewrite @eq_dec_cps_correct : uncps.

  Definition eqb_cps {T} (x y : Z) (f : bool -> T) : T
    := f (Z.eqb x y).
  Definition eqb_cps_correct {T} x y f : @eqb_cps T x y f = f (Z.eqb x y)
    := eq_refl.
  Hint Rewrite @eqb_cps_correct : uncps.

  Local Ltac prove_cps_correct _ :=
    try match goal with
        | [ |- ?lhs ?f = ?f ?rhs ]
          => let l := head lhs in
             let r := head rhs in
             cbv [l r] in *
        end;
    repeat first [ reflexivity
                 | progress cbv [Decidable.dec Decidable.dec_eq_Z] in *
                 | progress Z.ltb_to_lt
                 | congruence
                 | progress autorewrite with uncps
                 | break_innermost_match_step ].

  Definition get_carry_cps {T} (bitwidth : Z) (v : Z) (f : Z * Z -> T) : T
    := f (Z.get_carry bitwidth v).
  Definition get_carry_cps_correct {T} bitwidth v f
    : @get_carry_cps T bitwidth v f = f (Z.get_carry bitwidth v)
    := eq_refl.
  Hint Rewrite @get_carry_cps_correct : uncps.
  Definition add_with_get_carry_cps {T} (bitwidth : Z) (c : Z) (x y : Z) (f : Z * Z -> T) : T
    := f (Z.add_with_get_carry bitwidth c x y).
  Definition add_with_get_carry_cps_correct {T} bitwidth c x y f
    : @add_with_get_carry_cps T bitwidth c x y f = f (Z.add_with_get_carry bitwidth c x y)
    := eq_refl.
  Hint Rewrite @add_with_get_carry_cps_correct : uncps.
  Definition add_get_carry_cps {T} (bitwidth : Z) (x y : Z) (f : Z * Z -> T) : T
    := f (Z.add_get_carry bitwidth x y).
  Definition add_get_carry_cps_correct {T} bitwidth x y f
    : @add_get_carry_cps T bitwidth x y f = f (Z.add_get_carry bitwidth x y)
    := eq_refl.
  Hint Rewrite @add_get_carry_cps_correct : uncps.

  Definition get_borrow_cps {T} (bitwidth : Z) (v : Z) (f : Z * Z -> T)
    := f (Z.get_borrow bitwidth v).
  Definition get_borrow_cps_correct {T} bitwidth v f
    : @get_borrow_cps T bitwidth v f = f (Z.get_borrow bitwidth v)
    := eq_refl.
  Hint Rewrite @get_borrow_cps_correct : uncps.
  Definition sub_with_get_borrow_cps {T} (bitwidth : Z) (c : Z) (x y : Z) (f : Z * Z -> T) : T
    := f (Z.sub_with_get_borrow bitwidth c x y).
  Definition sub_with_get_borrow_cps_correct {T} (bitwidth : Z) (c : Z) (x y : Z) (f : Z * Z -> T)
    : @sub_with_get_borrow_cps T bitwidth c x y f = f (Z.sub_with_get_borrow bitwidth c x y)
    := eq_refl.
  Hint Rewrite @sub_with_get_borrow_cps_correct : uncps.
  Definition sub_get_borrow_cps {T} (bitwidth : Z) (x y : Z) (f : Z * Z -> T) : T
    := f (Z.sub_get_borrow bitwidth x y).
  Definition sub_get_borrow_cps_correct {T} (bitwidth : Z) (x y : Z) (f : Z * Z -> T)
    : @sub_get_borrow_cps T bitwidth x y f = f (Z.sub_get_borrow bitwidth x y)
    := eq_refl.
  Hint Rewrite @sub_get_borrow_cps_correct : uncps.

  (* splits at [bound], not [2^bitwidth]; wrapper to make add_getcarry
  work if input is not known to be a power of 2 *)
  Definition add_get_carry_full_cps {T} (bound : Z) (x y : Z) (f : Z * Z -> T) : T
    := eqb_cps
         (2 ^ (Z.log2 bound)) bound
         (fun eqb
          => if eqb
             then add_get_carry_cps (Z.log2 bound) x y f
             else f ((x + y) mod bound, (x + y) / bound)).
  Lemma add_get_carry_full_cps_correct {T} (bound : Z) (x y : Z) (f : Z * Z -> T)
    : @add_get_carry_full_cps T bound x y f = f (Z.add_get_carry_full bound x y).
  Proof. prove_cps_correct (). Qed.
  Hint Rewrite @add_get_carry_full_cps_correct : uncps.
  Definition add_with_get_carry_full_cps {T} (bound : Z) (c x y : Z) (f : Z * Z -> T) : T
    := eqb_cps
         (2 ^ (Z.log2 bound)) bound
         (fun eqb
          => if eqb
             then add_with_get_carry_cps (Z.log2 bound) c x y f
             else f ((c + x + y) mod bound, (c + x + y) / bound)).
  Lemma add_with_get_carry_full_cps_correct {T} (bound : Z) (c x y : Z) (f : Z * Z -> T)
    : @add_with_get_carry_full_cps T bound c x y f = f (Z.add_with_get_carry_full bound c x y).
  Proof. prove_cps_correct (). Qed.
  Hint Rewrite @add_with_get_carry_full_cps_correct : uncps.
  Definition sub_get_borrow_full_cps {T} (bound : Z) (x y : Z) (f : Z * Z -> T) : T
    := eqb_cps
         (2 ^ (Z.log2 bound)) bound
         (fun eqb
          => if eqb
             then sub_get_borrow_cps (Z.log2 bound) x y f
             else f ((x - y) mod bound, -((x - y) / bound))).
  Lemma sub_get_borrow_full_cps_correct {T} (bound : Z) (x y : Z) (f : Z * Z -> T)
    : @sub_get_borrow_full_cps T bound x y f = f (Z.sub_get_borrow_full bound x y).
  Proof. prove_cps_correct (). Qed.
  Hint Rewrite @sub_get_borrow_full_cps_correct : uncps.
  Definition sub_with_get_borrow_full_cps {T} (bound : Z) (c x y : Z) (f : Z * Z -> T) : T
    := eqb_cps
         (2 ^ (Z.log2 bound)) bound
         (fun eqb
          => if eqb
             then sub_with_get_borrow_cps (Z.log2 bound) c x y f
             else f ((x - y - c) mod bound, -((x - y - c) / bound))).
  Lemma sub_with_get_borrow_full_cps_correct {T} (bound : Z) (c x y : Z) (f : Z * Z -> T)
    : @sub_with_get_borrow_full_cps T bound c x y f = f (Z.sub_with_get_borrow_full bound c x y).
  Proof. prove_cps_correct (). Qed.
  Hint Rewrite @sub_with_get_borrow_full_cps_correct : uncps.

  Definition mul_split_at_bitwidth_cps {T} (bitwidth : Z) (x y : Z) (f : Z * Z -> T) : T
    := dlet xy := x * y in
        f (match bitwidth with
           | Z.pos _ | Z0 => Z.land xy (Z.ones bitwidth)
           | Z.neg _ => xy mod 2^bitwidth
           end,
           match bitwidth with
           | Z.pos _ | Z0 => Z.shiftr xy bitwidth
           | Z.neg _ => xy / 2^bitwidth
           end).
  Definition mul_split_at_bitwidth_cps_correct {T} (bitwidth : Z) (x y : Z) (f : Z * Z -> T)
    : @mul_split_at_bitwidth_cps T bitwidth x y f = f (Z.mul_split_at_bitwidth bitwidth x y)
    := eq_refl.
  Hint Rewrite @mul_split_at_bitwidth_cps_correct : uncps.
  Definition mul_split_cps {T} (s x y : Z) (f : Z * Z -> T) : T
    := eqb_cps
         s (2^Z.log2 s)
         (fun b
          => if b
             then mul_split_at_bitwidth_cps (Z.log2 s) x y f
             else f ((x * y) mod s, (x * y) / s)).
  Lemma mul_split_cps_correct {T} (s x y : Z) (f : Z * Z -> T)
    : @mul_split_cps T s x y f = f (Z.mul_split s x y).
  Proof. prove_cps_correct (). Qed.
  Hint Rewrite @mul_split_cps_correct : uncps.

  Definition mul_split_cps' {T} (s x y : Z) (f : Z * Z -> T) : T
    := eqb_cps
         s (2^Z.log2 s)
         (fun b
          => if b
             then f (Z.mul_split_at_bitwidth (Z.log2 s) x y)
             else f ((x * y) mod s, (x * y) / s)).
  Lemma mul_split_cps'_correct {T} (s x y : Z) (f : Z * Z -> T)
    : @mul_split_cps' T s x y f = f (Z.mul_split s x y).
  Proof. prove_cps_correct (). Qed.
  Hint Rewrite @mul_split_cps'_correct : uncps.
End Z.


Require Import Modal.
Require Import occ_in_phi.
Require Import Bool.
Require Import PeanoNat Nat Compare_dec.

(* is_pos *)

Fixpoint is_pos_pre (phi : Modal) (i : nat) : bool :=
  match phi with
  | atom p => EqNat.beq_nat 1 i
  | mneg psi => negb (is_pos_pre psi i)
  | mconj psi1 psi2 => if le_dec i (length (pv_in psi1)) then is_pos_pre psi1 i
                          else is_pos_pre psi2 (i-(length (pv_in psi1)))
  | mdisj psi1 psi2 => if le_dec i (length (pv_in psi1)) then is_pos_pre psi1 i
                          else is_pos_pre psi2 (i-(length (pv_in psi1)))
  | mimpl psi1 psi2 => if le_dec i (length (pv_in psi1)) then negb (is_pos_pre psi1 i)
                          else is_pos_pre psi2 (i-(length (pv_in psi1)))
  | box psi => is_pos_pre psi i
  | dia psi => is_pos_pre psi i
  end.

Inductive is_pos phi i : Prop :=
| occ_pos : occ_in_modal phi i -> is_pos_pre phi i = true -> is_pos phi i.

(* ----------------------------------------------------------------- *)

(* is_neg *)

Fixpoint is_neg_pre (phi : Modal) (i : nat) : bool :=
  match phi with
  | atom p => false
  | mneg psi => negb (is_neg_pre psi i)
  | mconj psi1 psi2 => if le_dec i (length (pv_in psi1)) then is_neg_pre psi1 i
                          else is_neg_pre psi2 (i-(length (pv_in psi1)))
  | mdisj psi1 psi2 => if le_dec i (length (pv_in psi1)) then is_neg_pre psi1 i
                          else is_neg_pre psi2 (i-(length (pv_in psi1)))
  | mimpl psi1 psi2 => if le_dec i (length (pv_in psi1)) then negb (is_neg_pre psi1 i)
                          else is_neg_pre psi2 (i-(length (pv_in psi1)))
  | box psi => is_neg_pre psi i
  | dia psi => is_neg_pre psi i
  end.

Inductive is_neg phi i : Prop :=
  | occ_neg : occ_in_modal phi i -> is_neg_pre phi i = true -> is_neg phi i.


Require Import Lia.
Require Import Coq.Vectors.Vector.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.Classical_Prop.
Import VectorNotations.

(**
I found myself looking for analogous functions as what could be found in the
[List] standard library. I sadly found none. This forced me to implement
my own. And here they are!
*)

Section Vector.
Hint Constructors Vector.Exists : core.
Lemma Vector_Exists_cons {A} (P : A -> Prop) (x : A) {n} (l : Vector.t A n):
      Vector.Exists P (x::l)%vector <-> P x \/ Vector.Exists P l.
Proof.
  split.
  - intros. inversion H. apply inj_pair2_eq_dec in H3. left; assumption.
    decide equality. apply inj_pair2_eq_dec in H3. 2: decide equality. right. rewrite H3 in H2. assumption.
  - intros. destruct H. auto. auto.
Qed.

Lemma Vector_Exists_nil {A} (P : A -> Prop): Vector.Exists P []%vector <-> False.
Proof. split; inversion 1. Qed.

Lemma Vector_Forall_cons_iff  {A} (P : A -> Prop) :
  forall (a:A) {n} (l : Vector.t A n), Vector.Forall P (a :: l)%vector <-> P a /\ Vector.Forall P l.
Proof.
intros. split.
- intro H; inversion H.
  apply inj_pair2_eq_dec in H2. 2: decide equality. rewrite H2 in H4. split.
  apply H3. apply H4.
- constructor. destruct H. apply H.  destruct H. apply H0.
Qed.

Lemma vector_de_morgan {A : Type} {n} : forall  (P : A -> Prop) (l : Vector.t A n),
  ~(Vector.Exists P l) <-> Vector.Forall (fun a => ~(P a)) l.
Proof.
  intros; split.
  - intros. simpl; auto. induction l. apply Vector.Forall_nil.
    assert (Vector.Exists P (h :: l)%vector <-> P h \/ Vector.Exists P l). { apply Vector_Exists_cons. }
    rewrite H0 in H.
    apply Decidable.not_or in H.
    apply Vector_Forall_cons_iff. split. destruct H. assumption.
    destruct H. apply IHl in H1. assumption.
  - intros. induction l.
  + assert (Vector.Exists P []%vector <-> False). { apply Vector_Exists_nil. } rewrite H0. simpl; auto.
  + assert (Vector.Exists P (h :: l)%vector <-> P h \/ Vector.Exists P l). { apply Vector_Exists_cons. }
    rewrite H0.
    set (notP0 := (fun (a : A) => ~ P a)).
    apply (Vector_Forall_cons_iff) in H. destruct H. apply IHl in H1 as IH.
    apply and_not_or. split. assumption. assumption.
Qed.
End Vector.


Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Families.
Require Export FiniteTypes.
Require Export IndexedFamilies.

Inductive finite_intersections {X:Type} (S:Family X) : Family X :=
  | intro_full: In (finite_intersections S) Full_set
  | intro_S: forall U:Ensemble X, In S U -> In (finite_intersections S) U
  | intro_intersection: forall U V:Ensemble X,
    In (finite_intersections S) U -> In (finite_intersections S) V ->
    In (finite_intersections S) (Intersection U V).

Lemma finite_intersection_is_finite_indexed_intersection:
  forall {X:Type} (S:Family X) (U:Ensemble X),
  In (finite_intersections S) U -> exists J:Type, FiniteT J /\
  exists V:J->Ensemble X,
  (forall j:J, In S (V j)) /\ U = IndexedIntersection V.
Proof.
intros.
induction H.
exists False.
split.
constructor.
exists (False_rect _).
split.
destruct j.
symmetry; apply empty_indexed_intersection.

exists True.
split.
exact True_finite.
exists (True_rect U).
split.
destruct j.
simpl.
trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct a; simpl.
trivial.
destruct H0.
exact (H0 I).
destruct IHfinite_intersections as [J0 [? [W []]]].
destruct IHfinite_intersections0 as [J1 [? [W' []]]].
exists ((J0+J1)%type).
split.
apply finite_sum; trivial.
exists (fun s:J0+J1 => match s with
  | inl j => W j
  | inr j => W' j
end).
split.
destruct j; auto.
apply Extensionality_Ensembles; split; red; intros.
destruct H7.
rewrite H3 in H7; destruct H7.
rewrite H6 in H8; destruct H8.
constructor.
destruct a as [j|j]; auto.
destruct H7.
constructor.
rewrite H3; constructor.
intro j.
exact (H7 (inl _ j)).
rewrite H6; constructor.
intro j.
exact (H7 (inr _ j)).
Qed.

Lemma finite_indexed_intersection_is_finite_intersection:
  forall {X:Type} (S:Family X) (J:Type) (V:J->Ensemble X),
  FiniteT J -> (forall j:J, In S (V j)) ->
  In (finite_intersections S) (IndexedIntersection V).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
constructor.

assert (IndexedIntersection V = Intersection
  (IndexedIntersection (fun j:T => V (Some j)))
  (V None)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
constructor.
constructor.
trivial.
trivial.
destruct H1.
constructor.
destruct H1.
destruct a as [j|]; trivial.
rewrite H1.
constructor 3; auto.
constructor 2; trivial.

destruct H1 as [g].
assert (IndexedIntersection V =
  IndexedIntersection (fun x:X0 => V (f x))).
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
constructor.
trivial.
destruct H3.
constructor.
intro.
rewrite <- (H2 a).
trivial.
rewrite H3; auto.
Qed.


Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Le.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.omega.Omega.
Require Import Bool.Sumbool.
Require Import Bool.Bool.
Require Import Coq.Logic.ConstructiveEpsilon.
Require Import Coq.ZArith.ZArith.
Import ListNotations.
Open Scope Z.

Notation "'existsT' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'") : type_scope.

(* all_pairs computes all the pairs of candidates in l *)
Fixpoint all_pairs {A: Type} (l: list A): list (A * A) :=
  match l with
  | [] => []
  | c::cs => (c, c) :: (all_pairs cs)
                   ++  (map (fun x => (c, x)) cs)
                   ++ (map (fun x => (x, c)) cs)
  end.

(* maxlist return the maximum number in list l. 0 in case of empty list *)
Fixpoint maxlist (l : list Z) : Z :=
  match l with
  | [] => 0%Z
  | [h] => h
  | h :: t => Z.max h (maxlist t)
  end.

(* give two numbers m and n with proof that m < n then it return the
   proof that maximum of m and n is n *)
Lemma max_two_integer : forall (m n : Z), m < n -> Z.max m n = n.
Proof.
  intros m n H; apply Z.max_r; omega.
Qed.

(* Shows the prop level existence of element x in list l >=  s if maximum element of
   list l >= s  *)
Lemma max_of_nonempty_list :
  forall (A : Type) (l : list A) (H : l <> nil) (H1 : forall x y : A, {x = y} + {x <> y}) (s : Z) (f : A -> Z),
    maxlist (map f l) >= s <-> exists (x:A), In x l /\ f x >= s.
Proof.
  split; intros. generalize dependent l.
  induction l; intros. specialize (H eq_refl). inversion H.
  pose proof (list_eq_dec H1 l []).
  destruct H2. exists a. rewrite e. intuition. rewrite e in H0.
  simpl in H0. auto.
  assert (Hm : {f a >= maxlist (map f l)} + {f a < maxlist (map f l)}) by
      apply (Z_ge_lt_dec (f a) (maxlist (map f l))).
  destruct Hm. rewrite map_cons in H0.
  pose proof (exists_last n).  destruct X as [l1 [x l2]].
  assert (maxlist (f a :: map f l) = Z.max (f a) (maxlist (map f l))).
  { destruct l1. simpl in l2. rewrite l2. simpl. auto.
    rewrite l2. simpl. auto. }
  pose proof (Z.ge_le _ _ g). pose proof (Z.max_l _ _ H3).
  rewrite H2 in H0. rewrite H4 in H0. exists a. intuition.
  rewrite map_cons in H0. pose proof (exists_last n). destruct X as [l1 [x l2]].
  assert (maxlist (f a :: map f l) = Z.max (f a) (maxlist (map f l))).
  { destruct l1. simpl in l2. rewrite l2. simpl. auto.
    rewrite l2. simpl. auto. }
  rewrite H2 in H0. pose proof (max_two_integer _ _ l0). rewrite H3 in H0.
  specialize (IHl n H0). destruct IHl. exists x0. intuition.
  destruct H0 as [x [H2 H3]].
  induction l. specialize (H eq_refl). inversion H.
  pose proof (list_eq_dec H1 l []). destruct H0.
  (* empty list *)
  subst. simpl in *. destruct H2. subst. auto. inversion H0.
  (* not empty list *)
  rewrite map_cons. pose proof (exists_last n). destruct X as [l1 [x0 H4]].
  assert (maxlist (f a :: map f l) = Z.max (f a) (maxlist (map f l))).
  { destruct l1. simpl in H4. rewrite H4. simpl. auto.
    rewrite H4. simpl. auto. }
  rewrite H0. unfold Z.max. destruct (f a ?= maxlist (map f l)) eqn:Ht.
  destruct H2. subst. auto. pose proof (proj1 (Z.compare_eq_iff _ _) Ht).
  specialize (IHl n H2). rewrite H5. auto.
  destruct H2. subst.
  pose proof (proj1 (Z.compare_lt_iff _ _) Ht). omega.
  apply IHl. assumption. assumption.
  destruct H2. subst. assumption. specialize (IHl n H2).
  pose proof (proj1 (Z.compare_gt_iff _ _) Ht).  omega.
Qed.

(* minimum of two integers m and n is >= s then both numbers are
   >= s *)
Lemma z_min_lb : forall m n s, Z.min m n >= s <-> m >= s /\ n >= s.
Proof.
  split; intros. unfold Z.min in H.
  destruct (m ?= n) eqn:Ht.
  pose proof (proj1 (Z.compare_eq_iff _ _) Ht). intuition.
  pose proof (proj1 (Z.compare_lt_iff _ _) Ht). intuition.
  pose proof (proj1 (Z.compare_gt_iff _ _) Ht). intuition.
  destruct H as [H1 H2].
  unfold Z.min. destruct (m ?= n) eqn:Ht; auto.
Qed.

(* if length of list l >= 1 then  l is nonempty *)
Lemma exists_list : forall (A : Type) (l : list A) (n : nat),
    (length l >= S n)%nat -> exists a ls, l = a :: ls.
Proof.
  intros A l. destruct l eqn: Ht; intros; simpl in H. inversion H.
  exists a, l0. reflexivity.
Qed.

(* If a in list l and x in not in list l then x <> a *)
Lemma not_equal_elem : forall (A : Type) (a x : A) (l : list A),
    In a l -> ~ In x l -> x <> a.
Proof.
  intros A a x l H1 H2.
  induction l. inversion H1.
  specialize (proj1 (not_in_cons x a0 l) H2); intros.
  simpl in H1. destruct H as [H3 H4]. destruct H1.
  subst. assumption. apply IHl. assumption. assumption.
Qed.

(* all the elements appearing in l also appears in list c *)
Definition covers (A : Type) (c l : list A) := forall x : A, In x l -> In x c.

(* split the list l at duplicate elements given the condition that c covers l *)
Lemma list_split_dup_elem : forall (A : Type) (n : nat) (c : list A) (H1 : forall x y : A, {x = y} + {x <> y}),
    length c = n -> forall (l : list A) (H : (length l > length c)%nat),
      covers A c l -> exists (a : A) l1 l2 l3, l = l1 ++ (a :: l2) ++ (a :: l3).
Proof.
  intros A n. induction n; intros. unfold covers in H1. rewrite H in H0.
  unfold covers in H2. pose proof (proj1 (length_zero_iff_nil c) H).
  rewrite H3 in H2. simpl in H2. pose proof (exists_list _ _ _ H0).
  destruct H4 as [a [ls H4]]. rewrite H4 in H2. specialize (H2 a (in_eq a ls)). inversion H2.
  rewrite H in H0. pose proof (exists_list _ _ _ H0).
  destruct H3 as [l0 [ls H3]].
  pose proof (in_dec H1 l0 ls). destruct H4.
  pose proof (in_split l0 ls i). destruct H4 as [l1 [l2 H4]].
  rewrite H4 in H3. exists l0, [], l1, l2. simpl. auto.
  unfold covers in H2. rewrite H3 in H2.
  pose proof (H2 l0 (in_eq l0 ls)).
  pose proof (in_split l0 c H4). destruct H5 as [l1 [l2 H5]].
  rewrite H5 in H. rewrite app_length in H. simpl in H.
  assert (Ht : (length l1 + S (length l2))%nat = (S (length l1 + length l2))%nat) by omega.
  rewrite Ht in H. clear Ht. inversion H. clear H.
  rewrite <- app_length in H7.
  assert ((length ls > length (l1 ++ l2))%nat).
  { rewrite H7. rewrite H3 in H0. simpl in H0. omega. }
  specialize (IHn (l1 ++ l2) H1 H7 ls H).
  assert (covers A (l1 ++ l2) ls).
  { unfold covers. intros x Hin.
    specialize (not_equal_elem _ x l0 ls Hin n0); intros.
    specialize (H2 x (or_intror Hin)).
    rewrite H5 in H2.
    pose proof (in_app_or l1 (l0 :: l2) x H2). destruct H8.
    apply in_or_app. left. assumption.
    simpl in H8. destruct H8. contradiction.
    apply in_or_app. right. assumption. }
  specialize (IHn H6). destruct IHn as [a [l11 [l22 [l33 H10]]]].
  exists a, (l0 :: l11), l22, l33.  simpl. rewrite H10 in H3. assumption.
Qed.

(* if maximum of two numbers m, n >= s then either m >= s or
   n >= s *)
Lemma z_max_lb : forall m n s, Z.max m n >= s <-> m >= s \/ n >= s.
Proof.
  split; intros. unfold Z.max in H. destruct (m ?= n) eqn : Ht.
  left. auto. right. auto. left. auto.
  destruct H. unfold Z.max. destruct (m ?= n) eqn: Ht.
  auto. pose proof (proj1 (Z.compare_lt_iff _ _) Ht). omega. omega.
  unfold Z.max. destruct (m ?= n) eqn:Ht.
  pose proof (proj1 (Z.compare_eq_iff _ _) Ht). omega.
  omega. pose proof (proj1 (Z.compare_gt_iff _ _) Ht). omega.
Qed.

(* if length of list l is > n then there is a natural number
   p such that p + n = length of list l *)
Lemma list_and_num : forall (A : Type) (n : nat) (l : list A),
    (length l > n)%nat -> exists p, (length l = p + n)%nat.
Proof.
  intros A n l H. induction l. inversion H.
  simpl in *. apply gt_S in H. destruct H. specialize (IHl H). destruct IHl as [p IHl].
  exists (S p). omega. exists 1%nat. omega.
Qed.

(* if forallb f l returns false then existance of element x in list l
   such that f x = false, and if x is in list l and f x = false then
   forallb f l will evaluate to false *)
Lemma forallb_false : forall (A : Type) (f : A -> bool) (l : list A),
    forallb f l = false <-> (exists x, In x l /\ f x = false).
Proof.
  intros A f l. split. intros H. induction l. simpl in H. inversion H.
  simpl in H. apply andb_false_iff in H. destruct H.
  exists a. split. simpl. left. auto. assumption.
  pose proof IHl H. destruct H0. exists x. destruct  H0 as [H1 H2].
  split. simpl. right. assumption. assumption.
  intros. destruct H as [x [H1 H2]]. induction l. inversion H1.
  simpl. apply andb_false_iff. simpl in H1. destruct H1.
  left. congruence. right. apply IHl. assumption.
Qed.

(*  Shows the type level existence of element x in list l >=  s if maximum element of
   list l >= s *)
Lemma max_of_nonempty_list_type :
  forall (A : Type) (l : list A) (H : l <> nil) (H1 : forall x y : A, {x = y} + {x <> y})
    (s : Z) (f : A -> Z), maxlist (map f l) >= s -> existsT (x:A), In x l /\ f x >= s.
Proof.
  intros A.
  assert (Hm : forall (a b : A) (l : list A) (f : A -> Z),
             maxlist (f a :: map f (b :: l)) = Z.max (f a) (maxlist (map f (b :: l)))) by auto.
  refine (fix F l {struct l} :=
            fun H H1 s f =>
              match l as l0 return (l = l0 -> l0 <> [] ->
                                    maxlist (map f l0) >= s ->
                                    existsT (x : A), In x l0 /\ f x >= s) with
              | [] => fun _ H =>  match H eq_refl with end
              | h :: t =>
                fun Heq Hn =>
                  match t as t0 return (t = t0 -> (h :: t0) <> [] ->
                                        maxlist (map f (h :: t0)) >= s ->
                                        existsT (x : A), In x (h :: t0) /\ f x >= s) with
                  | [] => fun _ H1 H2 => existT _ h (conj (in_eq h []) H2)
                  | h1 :: t1 =>
                    let Hmax := (Z_ge_lt_dec (f h) (maxlist (map f (h1 :: t1)))) in
                    match Hmax with
                    | left e => fun H1 H2 H3 => _
                    | right r => fun H1 H2 H3 => _
                    end
                  end eq_refl Hn
            end eq_refl H).

  rewrite map_cons in H3. rewrite Hm in H3.
  apply Z.ge_le in e. pose proof (Z.max_l _ _ e) as Hmx.
  rewrite Hmx in H3.
  exists h. intuition.

  rewrite map_cons in H3. rewrite Hm in H3.
  pose proof (max_two_integer _ _ r) as Hmx.
  rewrite Hmx in H3.
  assert (Ht : [] <> h1 :: t1) by apply nil_cons.
  apply not_eq_sym in Ht.
  rewrite <- H1 in H2, H3, Hmx, Ht.
  specialize (F _ Ht H0 s f H3).
  destruct F as [x [Fin Fx]]. rewrite <- H1.
  exists x. intuition.
Defined.

(* if forallb f l returns false then type level existance of element x in list l
   such that f x = false *)
Lemma forallb_false_type : forall (A : Type) (f : A -> bool) (l : list A),
    forallb f l = false -> existsT x, In x l /\ f x = false.
Proof.
  refine (fun A f =>
            fix F l :=
            match l as l0 return (forallb f l0 = false ->
                                  existsT x, In x l0 /\ f x = false) with
            | [] => fun H => match (diff_true_false H) with end
            | h :: t =>
              fun H => match f h as v return (f h = v -> existsT x, In x (h :: t) /\ f x = false) with
                    | false => fun H1 => existT _ h (conj (in_eq h t) H1)
                    | true => fun H1 => _
                    end eq_refl
            end).

  simpl in H. rewrite H1 in H. simpl in H. pose proof (F t H) as Ft.
  destruct Ft as [x [Fin Fx]]. exists x. intuition.
Defined.
(* End of List Lemma file *)


Set Implicit Arguments.
Require Import List.

(** * The Functor Type Class *)

Local Notation "f ∘ g" := (fun x => f (g x)) (at level 40, left associativity).

Class Functor (f : Type -> Type) : Type :=
{ fmap         : forall {A B}, (A -> B) -> f A -> f B }.
Class Functor_Correct (f : Type -> Type) `{F : Functor f} :=
{ fmap_id      : forall A, fmap (fun (x:A)=> x) = (fun x => x);
  fmap_compose : forall A B C (g : A -> B) (f : B -> C),
                 fmap (f ∘ g) = fmap f ∘ fmap g
}.
Class Applicative (f : Type -> Type) `{F : Functor f} : Type :=
{ pure : forall {A}, A -> f A;
  liftA : forall {A B}, f (A -> B) -> f A -> f B
}.
Notation "f <*> a" := (liftA f a) (left associativity, at level 25).

Class Applicative_Correct (f : Type -> Type) `{Applicative f} :=
{ applicative_id : forall A, liftA (pure (fun  (x:A) => x)) = (fun  x => x);
  applicative_composition : forall {A B C} (u : f (B -> C)) (v : f (A -> B)) (w : f A),
    pure (fun  x => fun  y => x ∘ y) <*> u <*> v <*> w = u <*> (v <*> w);
  applicative_homomorphism : forall {A B} (f : A -> B) (x : A),
    pure f <*> pure x = pure (f x);
  applicative_interchange : forall {A B} (u : f (A -> B)) (y : A),
    u <*> pure y = pure (fun x => x y) <*> u
}.

Class Monad (m: Type -> Type) `{M : Applicative m} : Type :=
{ bind: forall {A}, m A -> forall {B}, (A -> m B) -> m B
}.
Definition return_ {m : Type -> Type} `{M : Monad m} {A : Type} : A -> m A := pure.
Notation "a >>= f" := (bind a f) (at level 50, left associativity).

Hint Unfold bind return_ : monad_db.

Class Monad_Correct (m : Type -> Type) `{M : Monad m} := {
  bind_right_unit: forall A (a: m A), a = a >>= return_;
  bind_left_unit: forall A (a: A) B (f: A -> m B),
             f a = return_ a >>= f;
  bind_associativity: forall A (ma: m A) B f C (g: B -> m C),
                 bind ma (fun  x=> f x >>= g) = (ma >>= f) >>= g
}.

Arguments Functor f : assert.
Arguments Functor_Correct f {F}.
Arguments Applicative f [F].
Arguments Applicative_Correct f {F} {A} : rename.
Arguments Monad m [F] [M].
Arguments Monad_Correct m [F] [A] [M] : rename.

Section monadic_functions.
 Variable m : Type -> Type.
 Variable F : Functor m.
 Variable A : Applicative m.
 Variable M : Monad m.

 Definition wbind {A: Type} (ma: m A) {B: Type} (mb: m B) :=
 ma >>= fun  _=>mb.

 Definition liftM {A B: Type} (f: A->B) (ma: m A): m B :=
 ma >>= (fun  a => return_ (f a)).

 Definition join {A: Type} (mma: m (m A)): m A :=
 mma >>= (fun  ma => ma).

End monadic_functions.

Notation "a >> f" := (wbind _ a f) (at level 50, left associativity).
Notation "'do' a ← e ; c" := (e >>= (fun  a => c)) (at level 60, right associativity).

Fixpoint foldM {A B m} `{Monad m}
               (f : B -> A -> m B) (b : B) (ls : list A) : m B :=
  match ls with
  | nil      => return_ b
  | x :: ls' => do y ← f b x;
                foldM f y ls'
  end.
Hint Unfold foldM : monad_db.

About fmap_compose.
Lemma fmap_compose' {f} (F : Functor f) `{Functor_Correct f} :
    forall {A B C} (g : A -> B) (h : B -> C) (a : f A),
    fmap h (fmap g a) = fmap (h ∘ g) a.
Proof.
  intros.
  rewrite (fmap_compose g h).
  reflexivity.
Qed.

Require Import Program.
Lemma bind_eq : forall {A B m} `{Monad m} (a a' : m A) (f f' : A -> m B),
      a = a' ->
      (forall x, f x = f' x) ->
      bind a f = bind a' f'.
Proof.
  intros. subst.
  f_equal.
  apply functional_extensionality.
  auto.
Qed.

Ltac simplify_monad_LHS :=
  repeat match goal with
  | [ |- bind (return_ _) _ = _ ] => rewrite <- bind_left_unit
  | [ |- bind (bind _ _) _ = _ ]  => rewrite <- bind_associativity
  | [ |- _ = _ ]                  => reflexivity
  | [ |- bind ?a ?f = _ ]         => erewrite bind_eq; intros;
                                     [ | simplify_monad_LHS | simplify_monad_LHS ]
  end.

Ltac simplify_monad :=
  simplify_monad_LHS;
  apply eq_sym;
  simplify_monad_LHS;
  apply eq_sym.

Ltac simpl_m :=
  repeat (try match goal with
  [ |- bind ?a _ = bind ?a _ ] => apply bind_eq; [ reflexivity | intros ]
  end; simplify_monad).

Proposition test : forall {m} `{Monad m} `{Monad_Correct m} (a b c : m unit),
        do x ← a; do y ← b;  c
      = do y ← (do x ← a; b); c.
Proof. intros.
simplify_monad.
Abort.

(** * Some classic Monads *)

(** ** The list monad *)

Open Scope list_scope.
(*
Definition list_fmap {A B} (f : A -> B) :=
  fix map (l : list A) : list B :=
  match l with
  | nil => nil
  | a :: t => f a :: map t
  end.
*)
Definition list_fmap := map.
Hint Unfold list_fmap : monad_db.
(*
Fixpoint list_fmap {A B} (f : A -> B) (ls : list A) : list B :=
  match ls with
  | nil => nil
  | a :: ls' => f a :: list_fmap f ls'
  end.  *)

(*
Fixpoint concat {A} (xs : list (list A)) : list A :=
  match xs with
  | nil => nil
  | ys :: xs' => ys ++ concat xs'
  end.
*)

Definition list_liftA {A B} (fs : list (A -> B)) (xs : list A) : list B :=
  let g := fun a => list_fmap (fun f => f a) fs
  in
  concat (list_fmap g xs).
Hint Unfold list_liftA : monad_db.

Fixpoint list_bind {A} (xs : list A) {B} (f : A -> list B) : list B :=
  match xs with
  | nil => nil
  | a :: xs' => f a ++ list_bind xs' f
  end.
Hint Unfold list_bind : monad_db.

Instance listF : Functor list := { fmap := @list_fmap }.
Instance listA : Applicative list := { pure := fun _ x => x :: nil
                                     ; liftA := @list_liftA }.
Instance listM : Monad list :=
  { bind := @list_bind }.

Instance listF_correct : Functor_Correct list.
Proof.
  constructor.
  * intros. simpl. apply functional_extensionality; intros x.
    induction x; simpl; auto.
    rewrite IHx; auto.
  * intros. simpl. apply functional_extensionality; intros x.
    induction x; simpl; auto.
    rewrite IHx.
    auto.
Qed.

Instance listA_correct : Applicative_Correct list.
Proof.
  constructor.
  * intros. simpl. apply functional_extensionality; intros l.
    induction l; simpl; auto.
    unfold list_liftA in *. simpl in *.
    rewrite IHl; easy.
Abort.

Instance listM_correct : Monad_Correct list.
Abort.

Lemma fmap_app : forall {A B} (f : A -> B) ls1 ls2,
      fmap f (ls1 ++ ls2) = fmap f ls1 ++ fmap f ls2.
Proof.
  induction ls1; intros; simpl; auto.
  rewrite IHls1. auto.
Qed.

(** ** The Maybe monad (using option type) *)

Definition option_fmap {A B} (f : A -> B) (x : option A) : option B :=
  match x with
  | None => None
  | Some a => Some (f a)
  end.
Definition option_liftA {A B} (f : option (A -> B)) (x : option A) : option B :=
  match f, x with
  | Some f', Some a => Some (f' a)
  | _, _ => None
  end.
Instance optionF : Functor option := { fmap := @option_fmap}.
Instance optionA : Applicative option := { pure := @Some;
                                           liftA := @option_liftA}.
Instance optionM : Monad option :=
  { bind := fun  A m B f => match m with None => None | Some a => f a end
  }.
Instance optionM_Laws : Monad_Correct option.
Proof. split.
  - destruct a; auto.
  - intros; auto.
  - destruct ma; intros; auto.
Defined.

(* Monad Transformer *)
Class MonadTrans (t : (Type -> Type) -> (Type -> Type)) :=
  { liftT : forall {m} `{Monad m} {A}, m A -> t m A }.

(** Option monad transformer *)
Definition optionT m (A : Type) : Type := m (option A).

Definition optionT_liftT {m} `{Monad m} {A} (x : m A) : optionT m A.
Proof.
  unfold optionT.
  refine (do a ← x; return_ (Some a)).
Defined.
Instance optionT_T : MonadTrans optionT := {liftT := @optionT_liftT}.

Definition optionT_fmap {f} `{Functor f}
                        {A B} (g : A -> B) (x : optionT f A) : optionT f B :=
  @fmap f _ _ _ (fmap g) x.
Definition optionT_liftA {f} `{Applicative f}
                         {A B} (g : optionT f (A -> B)) (x : optionT f A)
                       : optionT f B.
(*  @liftA f _ _ _ _ (fmap liftA g) x.*)
Proof.
  unfold optionT in *.
  exact (fmap liftA g <*> x).
Defined.
Definition optionT_pure {f} `{Applicative f}
                        {A} (a : A) : optionT f A := @pure f _ _ _ (pure a).
Definition optionT_bind {m} `{Monad m}
                        {A} (ma : optionT m A) {B} (f : A -> optionT m B)
                        : optionT m B.
  unfold optionT in *.
  exact (do oa ← ma;
         match oa with
         | None => pure None
         | Some a => f a
         end
  ).
Defined.

Instance optionT_F {f} `{Functor f} : Functor (optionT f) :=
    {fmap := @optionT_fmap f _}.
Instance optionT_A {f} `{Applicative f} : Applicative (optionT f) :=
  { pure := @optionT_pure f _ _;
    liftA := @optionT_liftA f _ _ }.
Instance optionT_M {m} `{Monad m} : Monad (optionT m) :=
  { bind := @optionT_bind m _ _ _ }.

(** The Reader monad *)
Axiom Eta: forall A (B: A -> Type) (f: forall a, B a), f = fun  a=>f a.

Definition Reader (E : Type) := fun  X => E -> X.
Definition reader_fmap E A B (f : A -> B) (r : Reader E A) : Reader E B :=
  fun x => f (r x).
Definition reader_liftA E A B (f : Reader E (A -> B)) (r : Reader E A) :=
  fun x => (f x) (r x).
Definition reader_bind E A (r : Reader E A) B (f : A -> Reader E B) : Reader E B :=
  fun x => f (r x) x.

Instance readerF E : Functor (Reader E) :=
 { fmap := @reader_fmap E }.
Instance readerA E : Applicative (Reader E) :=
 { pure := fun  A (a:A) e=> a;
   liftA := @reader_liftA E }.
Instance readerM (E : Type): Monad (Reader E) :=
 { bind := @reader_bind E }.
(*
(* Checking the 3 laws *)
 - (* unit_left *)
   intros; apply Eta.
 - (* unit_right *)
   intros; apply Eta.
 - (* associativity *)
   reflexivity.
Defined.
*)
(** ** The State monad *)

Require Import Program.
Section State.
(*Axiom Ext: forall A (B: A->Type) (f g: forall a, B a), (forall a, f a = g a) -> f = g.*)

  Variable S : Type.

  Definition State (A : Type) := S -> A * S.
  Definition state_fmap A B (f : A -> B) (st : State A) : State B :=
    fun  s => let (a,s) := st s in (f a,s).
  Definition state_liftA A B (st_f : State (A -> B)) (st_a : State A) :=
    fun  s => let (f,s) := st_f s in
              let (a,s) := st_a s in
              (f a,s).
  Definition state_bind A (st_a : State A) B  (f : A -> State B) :=
    fun  s => let (a,s) := st_a s in
              f a s.

  Definition put (x : S) : State () :=
    fun _ => (tt,x).
  Definition get : State S :=
    fun x => (x,x).
  Definition runState  {A} (op : State A) : S -> A * S := op.
  Definition evalState {A} (op : State A) : S -> A := fst ∘ op.
  Definition execState {A} (op : State A) : S -> S := snd ∘ op.

End State.
Hint Unfold put get runState evalState execState state_fmap state_liftA state_bind : monad_db.
Ltac fold_evalState :=
  match goal with
  | [ |- context[fst (?c ?v)] ] => replace (fst (c v)) with (evalState c v)
                                                       by reflexivity
  end.

Arguments get {S}.
Arguments put {S}.

Instance stateF {A} : Functor (State A) :=
    { fmap := @state_fmap A }.
Instance stateA {A} : Applicative (State A) :=
    { pure := fun  A a s=> (a,s);
      liftA := @state_liftA A }.
Instance stateM {A} : Monad (State A) :=
    { bind := @state_bind A }.

Instance stateF_correct {A} : Functor_Correct (State A).
  Proof.
    split; intros;
      apply functional_extensionality; intros op;
      apply functional_extensionality; intros x;
      simpl; unfold state_fmap.
    - destruct (op x); reflexivity.
    - destruct (op x); reflexivity.
  Qed.

Instance stateA_correct {A} : Applicative_Correct (State A).
  Proof.
    split; intros;
      apply functional_extensionality; intros op;
      simpl; unfold state_liftA.
    - apply functional_extensionality; intros x.
      destruct (op x); reflexivity.
    - destruct (u op).
      destruct (v a).
      destruct (w a0).
      reflexivity.
    - reflexivity.
    - destruct (u op).
      reflexivity.
  Qed.

Instance stateM_correct {A} : Monad_Correct (State A).
  Proof.
    split; intros; simpl; unfold state_bind.
    - apply functional_extensionality; intros x.
      destruct (a x); reflexivity.
    - reflexivity.
    - apply functional_extensionality; intros x.
      destruct (ma x).
      reflexivity.
  Qed.

Hint Unfold Basics.compose : monad_db.
Hint Unfold stateM : monad_db.


Require Import ClassicalChoice.

Section not_wf_with_choice.

 Variables (A:Set)(R: A -> A -> Prop).
 Hypothesis R_not_wf : not (well_founded R).

 Notation "x > y" := (R y x).

 Definition strictly_decreasing (seq: nat -> A) :=
  forall n :nat, seq n > seq (S n).

  Remark  ex_not_acc :  exists x:A, ~ (Acc R x).
  Proof.
   apply not_all_ex_not;auto.
  Qed.

 Lemma go_down : forall x, ~ Acc R x -> exists y, x > y /\ ~ Acc R y.
 Proof.
 intros x H; change (exists z, (fun y => x > y /\ ~ Acc R y) z).
 apply not_all_not_ex.
 intro H0;  assert (H1: forall n, x > n -> Acc R n).
 -  intros n Hn;  specialize (H0 n).
     case (not_and_or _ _ H0).
    +  now destruct 1.
    +  intros;apply NNPP;auto.
 -  apply H; split;apply H1.
 Qed.

 Lemma decrease : exists f,
       forall x, ~ Acc R x ->  ~ Acc R (f x) /\ x > f x.
 Proof.
 case (choice  (fun x y =>  Acc R x \/ x > y /\ ~ Acc R y)).
 -  intros x ; case (classic (Acc R x)).
   +  exists x;auto.
   + intros H; case (go_down _ H).
     intros x0 [Hx0 H'x0]; exists x0; auto.
 - intros s Hs; exists s.
   intros x;  case (Hs x); tauto.
Qed.

Theorem infinite_descent : exists s : nat -> A, strictly_decreasing  s.
Proof.
  destruct decrease as [s Hs].
  case ex_not_acc;intros z0 Hz.
  pose (F := fun n:nat => Nat.iter n s z0); exists F.
  assert (H : forall n, F n > F (S n) /\ ~ Acc R (F n) /\ ~ Acc R (F (S n))).
  - induction n as [| p IHp].
   + unfold F; case (Hs z0 Hz);  tauto.
   +  destruct IHp as [H [H0 H1]]; split; auto.
    simpl; now case (Hs _ H1).
    split;auto;    now case (Hs _ H1).
 -  simpl; red;  intros n; case (H n);simpl;auto.
Qed.

End not_wf_with_choice.


(** * ugregex_dec: simple decision procedure for untyped generalised regular expressions *)

(** We implement a rather basic algorithm consisting in trying to
   build a bisimulation on-the-fly, using partial derivatives.

   We prove the correctness of this algorithm, but not completeness
   ("it merely let you sleep better" according to Krauss and Nipkow).

   This very simple algorithm seems to be sufficient for reasonable
   expressions; we plan to improve it to be able to handle larger
   ones. *)

Require Import lset kat positives sums glang boolean comparisons powerfix.
Require Export ugregex.
Set Implicit Arguments.

Section l.
Variable Pred: nat.
Notation Sigma := positive.
Notation Atom := (ord (pow2 Pred)).
Notation tt := ugregex_tt.
Notation ugregex := (ugregex_monoid_ops Pred tt tt).
Notation uglang := (glang_kat_ops Pred Sigma traces_tt traces_tt).
Notation lang := (@lang Pred).

Ltac fold_ugregex_type := change (@ugregex.ugregex Pred) with (@car ugregex) in *.
Ltac fold_ugregex := ra_fold ugregex_monoid_ops tt; fold_ugregex_type.

(** * Partial derivatives *)

(** reversed product *)
Notation tod e := (fun f => u_dot f e) (only parsing).

(** [pderiv a i e] returns the set of partial derivatives of [e] along
   transition [(a,i)] (since we work with KAT regular expressions,
   labels are composed of an atom together with a letter) *)
Fixpoint pderiv a i (e: ugregex): list ugregex :=
  match e with
    | u_prd _ => []
    | u_var _ j => if eqb_pos i j then [u_one _] else []
    | u_pls e f => union (pderiv a i e) (pderiv a i f)
    | u_dot e f =>
        if epsilon a e then union (map (tod f) (pderiv a i e)) (pderiv a i f)
        else map (tod f) (pderiv a i e)
    | u_itr e => map (tod (u_str e)) (pderiv a i e)
  end.

(** [epsilon] was defined in [ugregex],
   we now to extend both notions to sets of expressions, homomorphically: *)

Definition epsilon' a (l: list ugregex): bool :=
  fold_right (fun e b => b ||| epsilon a e) false l.

Definition pderiv' a i (l: list ugregex): list ugregex :=
  fold_right (fun e => union (pderiv a i e)) [] l.

(** specification of [epsilon'] *)
Lemma epsilon'_eq a l: epsilon a (sup id l) ≡ epsilon' a l.
Proof.
  induction l. reflexivity. simpl.
  rewrite <- IHl. unfold id.
  rewrite <-2Bool.orb_lazy_alt. apply Bool.orb_comm.
Qed.

(** correctness of partial derivatives *)
Lemma deriv_eq a i e: deriv a i e ≡ sup id (pderiv (set.mem a) i e).
Proof.
  induction e; simpl; fold_ugregex.
   case eqb_pos. 2: reflexivity. now rewrite sup_singleton.
   reflexivity.
   rewrite union_app, sup_app. now apply cup_weq.
   assert (H: deriv a i e1 ⋅ e2 ≡ sup id (map (tod e2) (pderiv (set.mem a) i e1))).
    rewrite sup_map. setoid_rewrite <-(dotsumx (X:=ugregex_monoid_ops _)).
    now apply dot_weq.
   case epsilon.
    rewrite union_app, sup_app.
    setoid_rewrite dot1x. now apply cup_weq.
    setoid_rewrite dot0x. now rewrite cupxb.
   rewrite sup_map. setoid_rewrite <-(dotsumx (X:=ugregex_monoid_ops _)).
    now apply dot_weq.
Qed.

Lemma deriv'_eq a i l: deriv a i (sup id l) ≡ sup id (pderiv' (set.mem a) i l).
Proof.
  induction l. reflexivity. simpl (sup _ _).
  rewrite union_app, sup_app.
  apply cup_weq. apply deriv_eq. assumption.
Qed.

(** Kleene variables of an expression *)
Fixpoint vars (e: ugregex): list Sigma :=
  match e with
    | u_prd _ => []
    | u_var _ i => [i]
    | u_pls e f | u_dot e f => union (vars e) (vars f)
    | u_itr e => vars e
  end.

(** partial derivatives do not increase the set of Kleene variables *)
Lemma deriv_vars a i (e: ugregex): \sup_(x\in pderiv a i e) vars x ≦ vars e.
Proof.
  induction e; simpl pderiv; simpl vars.
   case eqb_pos; apply leq_bx.
   apply leq_bx.
   rewrite 2union_app, sup_app. now apply cup_leq.
   setoid_rewrite union_app at 2.
   assert (H: \sup_(x\in map (tod e2) (pderiv a i e1)) vars x ≦ vars e1 ++ vars e2).
    rewrite sup_map. simpl vars. setoid_rewrite union_app. rewrite supcup.
    apply cup_leq. assumption. now apply leq_supx.
   case epsilon. rewrite union_app, sup_app, H. hlattice. assumption.
   rewrite sup_map. simpl vars. setoid_rewrite union_app. rewrite supcup.
    apply leq_cupx. assumption. now apply leq_supx.
Qed.

Lemma deriv'_vars a i l: \sup_(x\in pderiv' a i l) vars x ≦ sup vars l.
Proof.
  induction l. reflexivity. setoid_rewrite union_app. rewrite sup_app.
  apply cup_leq. apply deriv_vars. assumption.
Qed.

(** deriving an expression w.r.t. a letter it does not contain necessarily gives [0] *)
Lemma deriv_out a i e I: vars e ≦ I -> ~In i I -> deriv a i e ≡ 0.
Proof.
  intros He Hi. induction e; simpl deriv; simpl vars in He; fold_ugregex.
   case eqb_spec. 2: reflexivity. intros <-. apply Hi in He as []. now left.
   reflexivity.
   rewrite union_app in He.
    rewrite IHe1, IHe2 by (rewrite <-He; lattice). apply cupI.
   rewrite union_app in He.
    rewrite IHe1, IHe2 by (rewrite <-He; lattice). rewrite dot0x, dotx0. apply cupI.
   rewrite IHe by assumption. apply dot0x.
Qed.

(** we need binary relations on sets of expressions, we represent them
   as lists of pairs (this could easily be optimised) *)
Definition rel_mem (p: list ugregex * list ugregex) := existsb (eqb p).
Notation rel_insert p rel := (p::rel).
Notation rel_empty := [].
(* OPT *)
(* Definition rel_mem := trees.mem (pair_compare (list_compare compare)).  *)
(* Definition rel_insert := trees.insert (pair_compare (list_compare compare)).  *)
(* Notation rel_empty := (@trees.L _) *)

Lemma rel_mem_spec p rel: reflect (In p rel) (rel_mem p rel).
Proof.
  induction rel. constructor. tauto.
  simpl rel_mem. case eqb_spec.
  intros <-. constructor. now left.
  case IHrel; constructor. now right. intros [?|?]; congruence.
Qed.

(** * Main loop for the on-the-fly bisimulation algorithm *)

(** [epsilon'] and [deriv'] provide us with a (generalised) DFA whose
   states are sets of generalised expressions ([list ugregex]). We
   simply try compute bisimulations in this DFA. *)

Section a.

(** we assume a set of Kleene variable, and a set of atoms; the
   following algorithm tries to compute bisimulations w.r.t. those
   sets. *)
Variable I: list positive.
Variable A: list (ord Pred -> bool).

Definition obind X Y (f: X -> option Y) (x: option X): option Y :=
  match x with Some x => f x | _ => None end.

Fixpoint ofold X Y (f: X -> Y -> option Y) (l: list X) (y: Y): option Y :=
  match l with
    | [] => Some y
    | x::q => obind (f x) (ofold f q y)
  end.

(** [loop_aux e f a todo] checks the accepting status of [e] and [f] along [a],
   - if a mismatch is found, we can stop (a counter example has bee found)
   - otherwise, it inserts all derivatives of the pair [(e,f)] along [{a}⋅I] into [todo] *)
Definition loop_aux e f :=
  fun a todo =>
    if eqb_bool (epsilon' a e) (epsilon' a f)
    then Some (fold_right (fun i => cons (pderiv' a i e, pderiv' a i f)) todo I)
    else None.

(** [ofold (loop_aux e f) A todo] does the same, for all [a\in A] *)

(** [loop n rel todo] is the main loop of the algorithm:
   it tries to prove that all pairs in [todo] are bisimilar, assuming
   that those in [rel] are bisimilar.
   - if a pair of [todo] was already in [rel], it can be skipped;
   - otherwise, its accepting status is checked, all derivatives are
     inserted in [todo], and the pair is added to [rel]
   The number of iterations is bounded by [2^n], using the [powerfix] operator. *)
Definition loop n := powerfix n (fun loop rel todo =>
  match todo with
    | [] => Some true
    | (e,f)::todo =>
      if rel_mem (e,f) rel then loop rel todo else
        match ofold (loop_aux e f) A todo with
          | Some todo => loop (rel_insert (e,f) rel) todo
          | None => Some false
        end
    end
) (fun _ _ => None).

(** * Correctness of the main loop *)

(** [prog] is a predicate on binary relations:

   [prog rel (rel++todo)] is the invariant of the main loop *)

Definition prog R S :=
  forall e f, In (e,f) R -> sup vars (e++f) ≦ I /\
    forall a, In a A -> epsilon' a e = epsilon' a f /\
      forall i, In i I -> In (pderiv' a i e, pderiv' a i f) S.

Lemma prog_cup_x R R' S: prog R S -> prog R' S -> prog (R++R') S.
Proof. intros H H' e f Hef. apply in_app_iff in Hef as [?|?]. now apply H. now apply H'. Qed.

Lemma prog_x_leq R S S': prog R S -> S ≦ S' -> prog R S'.
Proof.
  intros H H' e f Hef. apply H in Hef as [? Hef].
  split. assumption. split. now apply Hef. intros. now apply H', Hef.
Qed.

Definition below_I todo := forall e f, In (e,f) todo -> sup vars (e++f) ≦ I.

(** specification of the inner loop *)

Lemma loop_aux_spec e f a todo todo':
  below_I ((e,f)::todo) ->
  loop_aux e f a todo = Some todo' ->
  epsilon' a e = epsilon' a f /\
  todo ≦ todo' /\
  below_I todo' /\
  forall i, In i I -> In (pderiv' a i e, pderiv' a i f) todo'.
Proof.
  unfold loop_aux. case eqb_bool_spec. 2: discriminate. intros Heps Hvars E.
  split. assumption. injection E. clear E Heps. revert todo'.
  induction I as [|i J IH]; simpl fold_right; intro todo'.
   intros <-. split. reflexivity. split. intros ? ? ?. apply Hvars; now right. intros _ [].
   intro E. destruct todo' as [|p todo']. discriminate.
   injection E. intros H <-. clear E. apply IH in H as [H1 [H2 H3]]. clear IH.
   split. fold_cons. rewrite <- H1. lattice.
   split. intros ? ? [E|H].
    injection E; intros <- <-. rewrite sup_app, 2deriv'_vars, <-sup_app. apply Hvars. now left.
    now apply H2.
   intros b [<-|Hb]. now left. right. now apply H3.
Qed.

Lemma fold_loop_aux_spec e f todo: forall todo',
  below_I ((e,f)::todo) ->
  ofold (loop_aux e f) A todo = Some todo' ->
  todo ≦ todo' /\
  below_I todo' /\
  forall a, In a A -> epsilon' a e = epsilon' a f /\
  forall i, In i I -> In (pderiv' a i e, pderiv' a i f) todo'.
Proof.
  induction A as [|b B IH]; simpl ofold; intros todo'.
   intros Hvars H. injection H. intros <-. split. reflexivity.
   split. intros ? ? ?. apply Hvars. now right. intros _ [].
  unfold obind. fold_ugregex_type. case_eq (ofold (X:=ord Pred -> bool) (loop_aux e f) B todo).
   2: discriminate.
  intros todo'' Htodo'' Hvars Htodo'.
  apply IH in Htodo'' as [Htodo''_leq [Hvars' Htodo'']]. 2: assumption. clear IH.
  apply loop_aux_spec in Htodo' as (Heps&Htodo'_leq&Hvars''&Htodo').
  split. etransitivity; eassumption.
  split. assumption.
  intros a [<-|Ha]. now split.
  apply Htodo'' in Ha as [Haeps Ha]. split. assumption.
  intros. now apply Htodo'_leq, Ha.
  intros ? ? [E|?]. injection E; intros <- <-. apply Hvars; now left. now apply Hvars'.
Qed.

Lemma In_cons X (a: X) l: In a l -> [a]++l ≦ l.
Proof. now intros ? ? [<-|?]. Qed.

(** specification of the outer loop *)

Lemma prog_loop n: forall rel todo,
  loop n rel todo = Some true ->
  prog rel (rel++todo) ->
  below_I todo ->
  exists rel', rel++todo ≦ rel' /\ prog rel' rel'.
Proof.
  (* TODO: use powerfix_invariant *)
  unfold loop. rewrite powerfix_linearfix. generalize (pow2 n). clear n. intro n.
  induction n; intros rel todo Hloop Hrel Hvars. discriminate.
  simpl in Hloop. destruct todo as [|[e f] todo].
   exists rel. split. now rewrite <- app_nil_end. now rewrite <-app_nil_end in Hrel.
   revert Hloop. case rel_mem_spec.
   intros Hef Hloop. apply IHn in Hloop as (rel'&H1&H2).
    eexists. split. 2: eassumption.
     rewrite <- H1. rewrite <-(In_cons Hef) at 2. fold_cons. lattice.
    eapply prog_x_leq. apply Hrel.
     rewrite <-(In_cons Hef) at 2. fold_cons. lattice.
    intros ? ? ?. apply Hvars. now right.
   intros _. fold_ugregex_type. case_eq (ofold (X:=ord Pred -> bool) (loop_aux e f) A todo).
    2: discriminate.
   intros todo' Htodo' Hloop.
   apply fold_loop_aux_spec in Htodo' as [Htodo' [Hvars' Hef]]. 2: assumption.
   destruct (IHn _ _ Hloop) as (rel'&Hrel'&Hrel''). 2: assumption.
   clear - Hef Hvars Hvars' Hrel Htodo'.
   apply (@prog_cup_x [_]). eapply prog_x_leq.
    intros ? ? [E|[]]. injection E; intros <- <-; clear E.
    split. apply Hvars. now left. apply Hef. lattice.
   eapply prog_x_leq. apply Hrel. rewrite <- Htodo'. fold_cons. lattice.
   eexists. split. 2: eassumption. rewrite <-Hrel', <-Htodo'. fold_cons. lattice.
Qed.

End a.

Existing Instance lang'_weq.

(** correctness of the bisimulation proof method, at the abstract level *)

Lemma prog_correct I l rel:
  (forall a, In (set.mem a) l) ->
  prog I l rel rel -> below_I I rel ->
  forall e f, In (e,f) rel -> sup lang e ≡ sup lang f.
Proof.
  intros Hl Hrel Hvars e f Hef.
  rewrite <-2lang_sup, 2lang_lang'.
  intro w. revert e f Hef. induction w; simpl lang'; intros e f Hef.
  - apply Hrel in Hef as [_ Hef].
    rewrite 2epsilon'_eq. destruct (Hef _ (Hl a)) as [-> _]. reflexivity.
  - destruct (fun H => In_dec H i I) as [Hi|Hi]. decide equality.
    etransitivity. apply lang'_weq. apply deriv'_eq.
    etransitivity. 2: apply lang'_weq; symmetry; apply deriv'_eq.
    apply IHw. apply Hrel. assumption. apply Hl. assumption.
    clear IHw. revert w. apply lang'_weq. rewrite 2deriv_sup.
    rewrite 2sup_b. reflexivity.
     intros f' Hf. eapply deriv_out. 2: eassumption.
      etransitivity. 2: apply Hvars. 2: apply Hef. apply leq_xsup. apply in_app_iff. now right.
     intros e' He. eapply deriv_out. 2: eassumption.
      etransitivity. 2: apply Hvars. 2: apply Hef. apply leq_xsup. apply in_app_iff. now left.
Qed.

(** * Final algorithm, correctness *)

(** the final algorithm is obtained by callign the main loop with
   appropriate arguments *)

Definition eqb_kat (e f: ugregex) :=
  let atoms := map (@set.mem _) (seq _) in
  let vars := vars (e+f) in
    loop vars atoms 1000 rel_empty [([e],[f])%list].
(* stated as this, the algorithm is not complete: we would need to
   replace 1000 with the size of [e+f]... bzzz *)

(** correctness of the algorithm *)

Theorem eqb_kat_correct e f: eqb_kat e f = Some true -> e ≡ f.
Proof.
  unfold eqb_kat. intro H. apply prog_loop in H as [rel [Hef Hrel]].
  2: intros _ _ [].
  2: simpl vars; intros ? ? [E|[]]; injection E; intros <- <-;
      rewrite union_app, sup_app, 2sup_singleton; reflexivity.
  eapply prog_correct in Hrel.
   2: intro; apply in_map, in_seq.
   3: apply Hef; now left.
  rewrite 2sup_singleton in Hrel. assumption.
  intros ? ? ?. now apply Hrel.
Qed.

End l.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import msl.eq_dec.
Import Relations.

Definition table A B := list (A*B).

Fixpoint table_get {A B}{H: EqDec A} (rho: table A B) (x: A) : option B :=
  match rho with
  | (y,v)::ys => if eq_dec x y then Some v else table_get ys x
  | nil => None
 end.

Definition table_set {A B}{H: EqDec A} (x: A) (v: B) (rho: table A B) : table A B := (x,v)::rho.

Lemma table_gss {A B}{H: EqDec A}: forall rho x (v : B), table_get (table_set x v rho) x = Some v.
Proof.
intros.
simpl. destruct (eq_dec x x); auto. contradiction n; auto.
Qed.

Lemma table_gso {A B}{H: EqDec A}: forall rho x y (v : B), x<>y -> table_get (table_set x v rho) y = table_get rho y.
Proof.
intros.
simpl. destruct (eq_dec y x); auto.  contradiction H0; auto.
Qed.


Require Export Program Permutation.

Unset Implicit Arguments.

(* Enumerating the items of a Bag resulting from inserting
   an item [inserted] into a bag [container] is a permutation
   of adding [inserted] to the original set of elements.
   *)
Definition BagInsertEnumerate
           {TContainer TItem: Type}
           (RepInv : TContainer -> Prop)
           (benumerate : TContainer -> list TItem)
           (binsert    : TContainer -> TItem -> TContainer) :=
  forall inserted container
         (containerCorrect : RepInv container),
    Permutation
      (benumerate (binsert container inserted))
      (inserted :: benumerate container).

(* The enumeration of an empty bag [bempty] is an empty list. *)
Definition BagEnumerateEmpty
           {TContainer TItem: Type}
           (benumerate : TContainer -> list TItem)
           (bempty     : TContainer) :=
  forall item, ~ List.In item (benumerate bempty).

(* [bfind] returns a permutation of the elements in a bag
   [container] filtered by the match function [bfind_matcher]
   using the specified search term [search_term]. *)
Definition BagFindCorrect
           {TContainer TItem TSearchTerm: Type}
           (RepInv : TContainer -> Prop)
           (bfind         : TContainer -> TSearchTerm -> list TItem)
           (bfind_matcher : TSearchTerm -> TItem -> bool)
           (benumerate : TContainer -> list TItem) :=
  forall container search_term
         (containerCorrect : RepInv container),
    Permutation
      (List.filter (bfind_matcher search_term) (benumerate container))
      (bfind container search_term).

(* The [bstar] search term matches every item in a bag. *)
Definition BagFindStar
           {TContainer TItem TSearchTerm: Type}
           (RepInv : TContainer -> Prop)
           (bfind : TContainer -> TSearchTerm -> list TItem)
           (benumerate : TContainer -> list TItem)
           (bstar : TSearchTerm) :=
  forall container
    (containerCorrect : RepInv container),
      bfind container bstar = benumerate container.

(* [bcount] returns the number of elements in a bag which match
   a search term [search_term]. *)
Definition BagCountCorrect
           {TContainer TItem TSearchTerm: Type}
           (RepInv : TContainer -> Prop)
           (bcount        : TContainer -> TSearchTerm -> nat)
           (bfind         : TContainer -> TSearchTerm -> list TItem) :=
  forall container search_term
  (containerCorrect : RepInv container),
    List.length (bfind container search_term) = (bcount container search_term).

(* The elements of a bag [container] from which all elements matching
   [search_term] have been deleted is a permutation of filtering
   the enumeration of [container] by the negation of [search_term]. *)
Definition BagDeleteCorrect
           {TContainer TItem TSearchTerm: Type}
           (RepInv : TContainer -> Prop)
           (bfind         : TContainer -> TSearchTerm -> list TItem)
           (bfind_matcher : TSearchTerm -> TItem -> bool)
           (benumerate : TContainer -> list TItem)
           (bdelete    : TContainer -> TSearchTerm -> (list TItem) * TContainer) :=
  forall container search_term
         (containerCorrect : RepInv container),
    Permutation (benumerate (snd (bdelete container search_term)))
                (snd (List.partition (bfind_matcher search_term)
                                     (benumerate container)))
    /\ Permutation (fst (bdelete container search_term))
                   (fst (List.partition (bfind_matcher search_term)
                                     (benumerate container))).

(* The elements of a bag [container] in which the function [f_update]
   has been applied to all elements matching [search_term]
   is a permutation of partitioning the list into non-matching terms
   and matching terms and mapping [f_update] over the latter. *)
Definition BagUpdateCorrect
           {TContainer TItem TSearchTerm TUpdateTerm : Type}
           (RepInv : TContainer -> Prop)
           (ValidUpdate : TUpdateTerm -> Prop)
           (bfind         : TContainer -> TSearchTerm -> list TItem)
           (bfind_matcher : TSearchTerm -> TItem -> bool)
           (benumerate : TContainer -> list TItem)
           (bupdate_transform : TUpdateTerm -> TItem -> TItem)
           (bupdate    : TContainer -> TSearchTerm -> TUpdateTerm -> TContainer) :=
  forall container search_term update_term
         (containerCorrect : RepInv container)
         (valid_update : ValidUpdate update_term),
    Permutation (benumerate (bupdate container search_term update_term))
                   ((snd (List.partition (bfind_matcher search_term)
                                         (benumerate container)))
                      ++ List.map (bupdate_transform update_term)
                      (fst (List.partition (bfind_matcher search_term)
                                           (benumerate container)))).

Definition binsert_Preserves_RepInv
           {TContainer TItem: Type}
           (RepInv : TContainer -> Prop)
           (binsert    : TContainer -> TItem -> TContainer)
    := forall container item
              (containerCorrect : RepInv container),
         RepInv (binsert container item).

Definition bdelete_Preserves_RepInv
           {TContainer TItem TSearchTerm: Type}
           (RepInv : TContainer -> Prop)
           (bdelete    : TContainer -> TSearchTerm -> (list TItem) * TContainer)
  := forall container search_term
            (containerCorrect : RepInv container),
       RepInv (snd (bdelete container search_term)).

Definition bupdate_Preserves_RepInv
           {TContainer TSearchTerm TUpdateTerm : Type}
           (RepInv : TContainer -> Prop)
           (ValidUpdate       : TUpdateTerm -> Prop)
           (bupdate    : TContainer -> TSearchTerm -> TUpdateTerm -> TContainer)
  := forall container search_term update_term
            (containerCorrect : RepInv container)
            (valid_update : ValidUpdate update_term),
       RepInv (bupdate container search_term update_term).

Class Bag (BagType TItem SearchTermType UpdateTermType : Type) :=
  {

    bempty            : BagType;
    bstar             : SearchTermType;
    bfind_matcher     : SearchTermType -> TItem -> bool;
    bupdate_transform : UpdateTermType -> TItem -> TItem;

    benumerate : BagType -> list TItem;
    bfind      : BagType -> SearchTermType -> list TItem;
    binsert    : BagType -> TItem -> BagType;
    bcount     : BagType -> SearchTermType -> nat;
    bdelete    : BagType -> SearchTermType -> (list TItem) * BagType;
    bupdate    : BagType -> SearchTermType -> UpdateTermType -> BagType
  }.

Class CorrectBag
      {BagType TItem SearchTermType UpdateTermType : Type}
      (RepInv            : BagType -> Prop)
      (ValidUpdate       : UpdateTermType -> Prop)
      (BagImplementation : Bag BagType TItem SearchTermType UpdateTermType) :=
{

  bempty_RepInv     : RepInv bempty;
  binsert_RepInv    : binsert_Preserves_RepInv RepInv binsert;
  bdelete_RepInv    : bdelete_Preserves_RepInv RepInv bdelete ;
  bupdate_RepInv    : bupdate_Preserves_RepInv RepInv ValidUpdate bupdate;

  bfind_star        : BagFindStar RepInv bfind benumerate bstar;

  benumerate_empty  : BagEnumerateEmpty benumerate bempty;
  binsert_enumerate : BagInsertEnumerate RepInv benumerate binsert;
  bfind_correct     : BagFindCorrect RepInv bfind bfind_matcher benumerate;
  bcount_correct    : BagCountCorrect RepInv bcount bfind;
  bdelete_correct   : BagDeleteCorrect RepInv bfind bfind_matcher benumerate bdelete;
  bupdate_correct   : BagUpdateCorrect RepInv ValidUpdate bfind bfind_matcher benumerate bupdate_transform bupdate
}.

(* [BagPlusProof] packages a container with its operations and
   their correctness proofs. *)
Record BagPlusProof (TItem : Type) :=
  { BagTypePlus : Type;
    SearchTermTypePlus : Type;
    UpdateTermTypePlus : Type;

    RepInvPlus : BagTypePlus -> Prop;
    ValidUpdatePlus : UpdateTermTypePlus -> Prop;

    BagPlus : Bag BagTypePlus TItem SearchTermTypePlus UpdateTermTypePlus;
    CorrectBagPlus : CorrectBag RepInvPlus ValidUpdatePlus BagPlus
  }.

Arguments BagTypePlus [TItem] _.
Arguments SearchTermTypePlus [TItem] _.
Arguments UpdateTermTypePlus [TItem] _.
Arguments RepInvPlus [TItem] _ _.
Arguments ValidUpdatePlus [TItem] _ _.
Arguments BagPlus [TItem] _.
Arguments CorrectBagPlus [TItem] _.

Instance BagPlusProofAsBag {TItem}
         (bag : BagPlusProof TItem)
: Bag _ _ _ _ := BagPlus bag.

Instance BagPlusProofAsCorrectBag {TItem}
         (bag : BagPlusProof TItem)
: CorrectBag _ _ _ := CorrectBagPlus bag.

(* We can bundle a container and its invariant if we so desire. *)
Definition WFBagPlusType {TItem} (Index : BagPlusProof TItem)
  := sigT (RepInvPlus Index).

Instance WFBagPlusTypeAsBag {TItem}
         (Index : BagPlusProof TItem)
: Bag (WFBagPlusType Index) TItem (SearchTermTypePlus Index)
      (sigT (ValidUpdatePlus Index)).
Proof.
  destruct Index as [? ? ? ? ? BagPlus' CorrectBagPlus'];
  destruct BagPlus'; destruct CorrectBagPlus'; simpl in *.
  econstructor 1; simpl; try solve [eassumption].
  (* bempty *)
  econstructor; eauto.
  (* bupdate_transform *)
  intro; apply bupdate_transform0; apply X.
  (* benumerate *)
  intros; apply benumerate0; apply X.
  (* bfind *)
  intros; destruct X; apply (bfind0 x X0).
  (* binsert *)
  intros; destruct X; econstructor; eapply binsert_RepInv0; apply r.
  (* bcount *)
  intros; destruct X; eapply bcount0; [apply x | apply X0 ].
  (* bdelete *)
  intros x search_term; constructor.
  - eapply (fst (bdelete0 (projT1 x) search_term)).
  - econstructor; eapply bdelete_RepInv0; apply (projT2 x).
  (* bupdate *)
  - intros x search_term update_term; destruct x; destruct update_term;
    econstructor.
    eapply bupdate_RepInv0.
    apply r.
    apply v.
    Grab Existential Variables.
    simpl; apply search_term.
    simpl; apply search_term.
    apply X0.
Defined.

Instance WFBagPlusTypeAsCorrectBag {TItem}
         (Index : BagPlusProof TItem)
: CorrectBag (fun _ => True) (fun _ => True) (WFBagPlusTypeAsBag Index).
Proof.
  destruct Index as [? ? ? ? ? BagPlus' CorrectBagPlus'];
  destruct BagPlus'; destruct CorrectBagPlus'; simpl in *.
  constructor; simpl; eauto;
  cbv delta [binsert_Preserves_RepInv
               bupdate_Preserves_RepInv
               bdelete_Preserves_RepInv
               BagInsertEnumerate
               BagEnumerateEmpty
               BagFindStar
               BagFindCorrect
               BagCountCorrect
               BagDeleteCorrect
               BagUpdateCorrect]; simpl; eauto;
  try (solve [intros; destruct container; eauto]).
  (* bupdate_correct *)
  destruct container; simpl; intros.
  destruct update_term; eauto.
Qed.


Require Export A_14_1.

Module A14_2.

(* 定义：函数f在x0处的泰勒公式余项 *)
Definition TaylorRn f n x x0 :=
  f[x] - (Σ {` λ k v, v = (dN f k)[x0] /
      (INR (k!)) * (x - x0)^^k `} n).

Theorem Theorem14_11 : ∀ f r x x0,
  0 < r -> -r < x-x0 < r
  -> limit_seq {` λ n s, s = TaylorRn f n x x0 `} 0
  -> limit_seq {` λ n s, s = Σ {` λ k v, v = (dN f k)[x0] /
      (INR (k!)) * (x - x0)^^k `} n `} f[x].
Proof.
  intros f r x x0 H0 H1 H2.
  split; try apply FunIsSeq.
  intros ε H3. apply H2 in H3 as H4.
  destruct H4 as [N H4].
  exists N. intros n H5. apply H4 in H5.
  rewrite FunValueR in H5.
  rewrite FunValueR. unfold TaylorRn in H5.
  rewrite Rminus_0_r in H5.
  rewrite Abs_eq_neg. rewrite Ropp_minus_distr.
  assumption.
Qed.

End A14_2.

Export A14_2.


Require Import compcert.lib.Coqlib.
Require Import VST.msl.Coqlib2.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import VST.floyd.sublist.

(* from verif_revarray.v *)

Definition flip_between {A} lo hi (contents: list A) :=
  firstn (Z.to_nat lo) (rev contents)
  ++ firstn (Z.to_nat (hi-lo)) (skipn (Z.to_nat lo) contents)
  ++ skipn (Z.to_nat hi) (rev contents).

Lemma flip_fact_0: forall {A} size (contents: list A),
  Zlength contents = size ->
  contents = flip_between 0 (size - 0) contents.
Proof.
  intros.
  assert (length contents = Z.to_nat size).
    apply Nat2Z.inj. rewrite <- Zlength_correct, Z2Nat.id; auto.
    subst; rewrite Zlength_correct; omega.
  unfold flip_between.
  rewrite !Z.sub_0_r. change (Z.to_nat 0) with O; simpl. rewrite <- H0.
  rewrite skipn_short.
  rewrite <- app_nil_end.
  rewrite firstn_exact_length. auto.
  rewrite rev_length. omega.
Qed.

Lemma flip_fact_1: forall A size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_between j (size - j) contents = rev contents.
Proof.
  intros.
  assert (length contents = Z.to_nat size).
    apply Nat2Z.inj. rewrite <- Zlength_correct, Z2Nat.id; auto.
    subst; rewrite Zlength_correct; omega.
  unfold flip_between.
  symmetry.
  rewrite <- (firstn_skipn (Z.to_nat j)) at 1.
  f_equal.
  replace (Z.to_nat (size-j)) with (Z.to_nat j + Z.to_nat (size-j-j))%nat
    by (rewrite <- Z2Nat.inj_add by omega; f_equal; omega).
  rewrite <- skipn_skipn.
  rewrite <- (firstn_skipn (Z.to_nat (size-j-j)) (skipn (Z.to_nat j) (rev contents))) at 1.
  f_equal.
  rewrite firstn_skipn_rev.
Focus 2.
rewrite H2.
apply Nat2Z.inj_le.
rewrite Nat2Z.inj_add by omega.
rewrite !Z2Nat.id by omega.
omega.
  rewrite len_le_1_rev.
  f_equal. f_equal. f_equal.
  rewrite <- Z2Nat.inj_add by omega. rewrite H2.
  rewrite <- Z2Nat.inj_sub by omega. f_equal; omega.
  rewrite firstn_length, min_l.
  change 1%nat with (Z.to_nat 1). apply Z2Nat.inj_le; omega.
  rewrite skipn_length.  rewrite H2.
  rewrite <- Z2Nat.inj_sub by omega. apply Z2Nat.inj_le; omega.
Qed.

Lemma Zlength_flip_between:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_between i j al) = Zlength al.
Proof.
intros.
unfold flip_between.
rewrite !Zlength_app, !Zlength_firstn, !Zlength_skipn, !Zlength_rev.
forget (Zlength al) as n.
rewrite (Z.max_comm 0 i).
rewrite (Z.max_l i 0) by omega.
rewrite (Z.max_comm 0 j).
rewrite (Z.max_l j 0) by omega.
rewrite (Z.max_comm 0 (j-i)).
rewrite (Z.max_l (j-i) 0) by omega.
rewrite (Z.max_comm 0 (n-i)).
rewrite (Z.max_l (n-i) 0) by omega.
rewrite Z.max_r by omega.
rewrite (Z.min_l i n) by omega.
rewrite Z.min_l by omega.
omega.
Qed.

Lemma flip_fact_3:
 forall A (al: list A) (d: A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
firstn (Z.to_nat j)
  (firstn (Z.to_nat (size - j - 1)) (flip_between j (size - j) al) ++
   firstn (Z.to_nat 1) (skipn (Z.to_nat j) (flip_between j (size - j) al)) ++
   skipn (Z.to_nat (size - j - 1 + 1)) (flip_between j (size - j) al)) ++
firstn (Z.to_nat 1)
  (skipn (Z.to_nat (size - j - 1)) al) ++
skipn (Z.to_nat (j + 1))
  (firstn (Z.to_nat (size - j - 1)) (flip_between j (size - j) al) ++
   firstn (Z.to_nat 1) (skipn (Z.to_nat j) (flip_between j (size - j) al)) ++
   skipn (Z.to_nat (size - j - 1 + 1)) (flip_between j (size - j) al)) =
flip_between (Z.succ j) (size - Z.succ j) al.
Proof.
intros.
assert (Zlength (rev al) = size) by (rewrite Zlength_rev; omega).
unfold flip_between.
rewrite Zfirstn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite !Zlength_app.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite !Zlength_skipn.
rewrite (Z.max_r 0 j) by omega.
rewrite (Z.max_r 0 (size-j)) by omega.
rewrite Z.max_r by omega.
rewrite Z.max_r by omega.
rewrite (Z.min_l j) by omega.
rewrite (Z.min_l (size-j-j)) by omega.
rewrite Z.min_l by omega.
omega.
} Unfocus.
rewrite Zfirstn_app2
 by (rewrite Zlength_firstn, Z.max_r by omega;
      rewrite Z.min_l by omega; omega).
rewrite Zfirstn_app1
 by (rewrite Zlength_firstn, Z.max_r by omega;
      rewrite Z.min_l by omega; omega).
rewrite Zfirstn_firstn by omega.
rewrite Zskipn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_rev.
rewrite !Zlength_app.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Zlength_firstn.
rewrite (Z.min_l j (Zlength al)) by omega.
rewrite Z.max_r by omega.
rewrite Zlength_app.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 j)  by omega.
rewrite (Z.max_r 0 ) by omega.
rewrite (Z.min_l  (size-j-j)) by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 (size-j)) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
omega.
} Unfocus.
rewrite Zskipn_app2
 by (rewrite Zlength_firstn, Z.max_r by omega;
       rewrite Z.min_l by omega; omega).
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Zfirstn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega. omega.
} Unfocus.
rewrite Zfirstn_firstn by omega.
rewrite Zskipn_app2
 by (rewrite Zlength_firstn, Z.max_r by omega;
       rewrite Z.min_l by omega; omega).
rewrite Zskipn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega. omega.
} Unfocus.
rewrite Zfirstn_app1.
Focus 2. {
rewrite !Zlength_skipn, !Zlength_firstn.
rewrite (Z.max_r 0 j) by omega.
rewrite (Z.min_l j) by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 j) by omega.
rewrite (Z.max_r 0 (Zlength al - j)) by omega.
rewrite (Z.max_l 0 (j-j)) by omega.
rewrite (Z.max_r 0 (size-j-j)) by omega.
rewrite Z.min_l by omega.
rewrite Z.max_r by omega.
omega.
} Unfocus.
rewrite Zskipn_app2.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite (Z.min_l j) by omega.
omega.
} Unfocus.
rewrite Zskipn_app2.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite (Z.min_l j) by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
omega.
} Unfocus.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Z.min_l by omega.
rewrite Zskipn_skipn by omega.
rewrite !Zskipn_firstn by omega.
rewrite !Z.sub_diag.
rewrite Z.sub_0_r.
rewrite !Zskipn_skipn by omega.
rewrite Zfirstn_firstn by omega.
rewrite <- app_ass.
f_equal.
rewrite <- (firstn_skipn (Z.to_nat j) (rev al)) at 2.
rewrite Zfirstn_app2
  by (rewrite Zlength_firstn, Z.max_r by omega;
        rewrite Z.min_l by omega; omega).
rewrite Zlength_firstn, Z.max_r by omega;
rewrite Z.min_l by omega.
replace (Z.succ j - j) with 1 by omega.
f_equal.
rewrite app_nil_end.
rewrite app_nil_end at 1.
rewrite <- Znth_cons with (d0:=d) by omega.
rewrite <- Znth_cons with (d0:=d) by omega.
f_equal.
rewrite Znth_rev by omega.
f_equal. omega.
replace (size - j - 1 - j - (j + 1 - j))
  with (size- Z.succ j- Z.succ j) by omega.
replace (j+(j+1-j)) with (j+1) by omega.
f_equal.
rewrite Z.add_0_r.
rewrite <- (firstn_skipn (Z.to_nat 1) (skipn (Z.to_nat (size- Z.succ j)) (rev al))).
rewrite Zskipn_skipn by omega.
f_equal.
rewrite app_nil_end.
rewrite app_nil_end at 1.
rewrite <- Znth_cons with (d0:=d) by omega.
rewrite <- Znth_cons with (d0:=d) by omega.
f_equal.
rewrite Znth_rev by omega.
f_equal.
omega.
f_equal.
f_equal.
omega.
Qed.

Lemma flip_fact_2:
  forall {A} (al: list A) size j d,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al d =
  Znth (size - j - 1) (flip_between j (size - j) al) d.
Proof.
intros.
unfold flip_between.
rewrite app_Znth2
 by (rewrite Zlength_firstn, Z.max_r by omega;
      rewrite Zlength_rev, Z.min_l by omega; omega).
rewrite Zlength_firstn, Z.max_r by omega;
rewrite Zlength_rev, Z.min_l by omega.
rewrite app_Znth1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega;
rewrite Zlength_skipn by omega.
rewrite (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
omega. } Unfocus.
rewrite Znth_firstn by omega.
rewrite Znth_skipn by omega.
f_equal; omega.
Qed.

Require Import VST.msl.shares.
Require Import VST.veric.shares.
Require Import compcert.lib.Integers.
Require Import compcert.common.Values.
Require Import compcert.cfrontend.Ctypes.
Require Import VST.veric.expr.

Lemma verif_sumarray_example1:
forall (sh : share) (contents : list int) (size : Z) (a : val),
readable_share sh ->
0 <= size <= Int.max_signed ->
is_pointer_or_null a ->
@Zlength val (@map int val Vint contents) = size ->
0 <= 0 /\
(0 <= size /\ True) /\
a = a /\
Vint (Int.repr 0) = Vint (Int.repr 0) /\
Vint (Int.repr size) = Vint (Int.repr size) /\
Vint Int.zero = Vint (Int.repr 0) /\ True.
Abort.

Lemma verif_sumarray_example2:
forall (sh : share) (contents : list int) (size : Z) (a : val),
forall (sh : share) (contents : list int) (size a1 : Z) (a : val),
readable_share sh ->
0 <= size <= Int.max_signed ->
a1 < size ->
0 <= a1 <= size ->
is_pointer_or_null a ->
Zlength (map Vint contents) = size ->
is_int I32 Signed (Znth a1 (map Vint contents) Vundef).
Abort.

Require Import compcert.exportclight.Clightdefs.

Require Import VST.veric.Clight_lemmas.  (* just for nullval? *)

Lemma verif_reverse_example1:
forall (sum_int: list int -> int) (sh : share) (contents cts : list int) (t0 t_old t : val) (h : int),
readable_share sh ->
isptr t0 ->
t0 = t_old ->
is_pointer_or_null t ->
is_pointer_or_null t ->
(t = nullval <-> map Vint cts = []) ->
t = t /\
Vint (Int.sub (sum_int contents) (sum_int cts)) =
Vint (Int.add (Int.sub (sum_int contents) (Int.add h (sum_int cts))) h) /\
True.
Abort.

Lemma verif_reverse_example2:
forall (sh : share) (contents cts1 : list val) (w h : val) (r : list val)
  (w_ t_ : val),
writable_share sh ->
contents = rev cts1 ++ h :: r ->
is_pointer_or_null t_ ->
is_pointer_or_null w_ ->
isptr w_ ->
is_pointer_or_null t_ ->
is_pointer_or_null t_ ->
(t_ = nullval <-> r = []) ->
is_pointer_or_null w ->
(w = nullval <-> cts1 = []) ->
contents = (rev cts1 ++ [h]) ++ r /\ True /\ w_ = w_ /\ t_ = t_ /\ True.
Abort.


Require Import Nat Arith.

Fixpoint mult (mult_arg0 : nat) (mult_arg1 : nat) : nat
           := match mult_arg0, mult_arg1 with
              | n, m => if > m 0 then plus n (mult n (minus m 1)) else 0
              end.

Theorem theorem0 : forall (x : nat) (y : nat), eq (minus (mult x y) y) (mult (minus x 1) y).
Proof.
Admitted.

Theorem theorem1 : forall (n : nat) (m : nat), eq (mult n m) (mult m n).
Proof.
Admitted.


From Coq Require Import Arith Relations.

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

(* **************************************************************
 *                                                              *
 *  Basic setup, inductive trees, and almost-full relations     *
 *                                                              *
 ****************************************************************)

(* Decidable *)
Definition dec_rel (X:Type) (R:X->X->Prop) :=
  forall x y, {~ R y x} + {R y x}.

(* AF *)
Inductive almost_full X : (X -> X -> Prop) -> Prop :=
| AF_ZT : forall (R : X -> X -> Prop),
   (forall x y, R x y) -> almost_full R
| AF_SUP : forall R,
   (forall x, almost_full (fun y z => R y z \/ R x y)) -> almost_full R.

(* AFStrengthen *)
Lemma af_strengthen:
 forall (X:Type) (A : X -> X -> Prop), almost_full A ->
 forall (B : X -> X -> Prop), (forall x y, A x y -> B x y) -> almost_full B.
Proof.
intros X A p.
induction p.
intros. apply AF_ZT; auto.
intros. apply AF_SUP. intro x. apply H0 with (x := x).
intros. destruct H2.
left;  auto.
right; auto.
Defined.

(* SecureBy implies that every infinite chain has two related elements *)
(* InfiniteChain *)
Lemma sec_binary_infinite_chain :
  forall (X:Type) R (f : nat -> X), almost_full R ->
  forall (k:nat), exists n, exists m, (n > m) /\ (m >= k) /\ R (f m) (f n).
Proof.
intros X R f p. induction p.
intro k. exists (S k). exists k. auto with arith.
intro k.
remember (H0 (f k) (S k)). clear Heqe.
destruct e as (n,e).
destruct e as (m,e). destruct e. destruct H2. destruct H3.
exists n. exists m. auto with arith.
exists m. exists k. auto with arith.
Defined.

(* InfiniteChainCorollary *)
Corollary af_inf_chain (X : Type) (R : X -> X -> Prop):
 almost_full R -> forall (f : nat -> X), exists n, exists m, (n > m) /\ R (f m) (f n).
Proof.
intros.
destruct (@sec_binary_infinite_chain X R f H 0); firstorder.
Defined.

(* **************************************************************
 *                                                              *
 *  From a decidable Well-founded relation to an AlmostFull     *
 *                                                              *
 ****************************************************************)

(* Generalization to an arbitrary decidable well-founded relation *)
(* AfTreeIter *)
Lemma af_iter : forall (X:Type) (R : X -> X -> Prop)
 (decR : dec_rel R) (x:X) (accX : Acc R x),
 almost_full (fun y z => ~ R y x \/ ~ R z y).
Proof.
intros.
induction accX.
apply AF_SUP; intro y.
destruct (decR x y).
apply AF_ZT. intros. right. left. apply n.
assert (almost_full (fun y0 z => ~ R y0 y \/ ~ R z y0)).
apply H0. apply r.
eapply af_strengthen. apply H1. intros.
simpl in H2. destruct H2. right. right. auto.
left. right. auto.
Defined.

(* AfFromWfCor *)
Corollary af_from_wf (X:Type) (R : X -> X -> Prop) :
  well_founded R -> dec_rel R -> almost_full (fun x y => ~ R y x).
Proof.
intros.
apply AF_SUP. intro x.
assert (Acc R x). apply H.
remember (@af_iter X R X0 x H0). clear Heqa.
eapply af_strengthen. apply a. intros. simpl in H1.
destruct H1.
right; assumption.
left;  assumption.
Defined.

(* **************************************************************
 *                                                              *
 *  From an AlmostFull relation to a Well-Founded one           *
 *                                                              *
 ****************************************************************)

Lemma trans_clos_left : forall X (T : X -> X -> Prop) z y z0,
 T z y -> clos_refl_trans X T z0 z -> clos_refl_trans X T z0 y.
Proof.
intros. eapply rt_trans. apply H0. apply rt_step. apply H.
Qed.

Lemma trans_clos_left_aux : forall X (T : X -> X -> Prop) z y z0,
 T z y -> clos_refl_trans X T z0 z -> clos_trans_1n X T z0 y.
Proof.
intros X T z y z0 H Hrt.
remember (@Relation_Operators.t1n_step X T z y H) as G. clear HeqG; clear H.
remember (@clos_rt_rt1n _ T z0 z Hrt) as F. clear HeqF. clear Hrt.
induction F. apply G. econstructor 2. apply H. apply IHF. apply G.
Qed.

(* AccFromAf *)
Lemma acc_from_af: forall (X:Type) (R : X -> X -> Prop),
  almost_full R -> forall (T : X -> X -> Prop) y,
  (forall x z, clos_refl_trans X T z y ->
            clos_trans_1n X T x z /\ R z x -> False) -> Acc T y.
Proof.
intros X R afPred.
induction afPred.
intros. apply Acc_intro. intros.
edestruct H0. constructor 2. split.
constructor 1. apply H1. apply H.
intros. apply Acc_intro. intros z HT.
remember (H y).
eapply H0.
intros.
intros. destruct H3. destruct H4.
eapply H1. eapply trans_clos_left. apply HT.
apply H2. split. apply H3. apply H4.
eapply H1. apply rt_refl. split. 2: apply H4.
eapply trans_clos_left_aux. apply HT. apply H2.
Defined.

(* WfFromAf *)
Lemma wf_from_af :
 forall (X:Type) (R : X -> X -> Prop) (T : X -> X -> Prop),
  (forall x y, clos_trans_1n X T x y /\ R y x -> False) ->
  almost_full R -> well_founded T.
Proof.
intros. unfold well_founded. intro y.
eapply acc_from_af.
2: { intros. eapply H. apply H2. }
induction H0. apply AF_ZT. apply H0.
apply AF_SUP.
intros. apply H0.
Defined.

(* A reassuring lemma *)
(* WfFromWqo *)
Lemma wf_from_wqo :
  forall (X:Type) (R : X -> X -> Prop), transitive X R -> almost_full R ->
  well_founded (fun x y => R x y /\ ~ R y x).
Proof.
intros X R trH afR.
apply wf_from_af with (R := R).
intros. destruct H.
assert (~ R y x).
induction H. destruct H; auto.
destruct H. assert (R z y).
  eapply trH. apply H0. apply H.
assert (~ R z y).
apply IHclos_trans_1n.
assumption. firstorder. firstorder.
assumption.
Defined.