From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo81:
  prime  4732254109989697->
  prime  46357161274830326863.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      46357161274830326863
      9796
      ((4732254109989697,1)::nil)
      0
      711828
      117
      1521)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List Psatz NArith.
Require Import BasicFacts OrderedSet.
Require Import Signatures SeqScan.

Set Implicit Arguments.

Section Group.

  Variable elt : Type.
  Variable Elt : Oeset.Rcd elt.
  Variable C : Cursor.Rcd Elt.

  Variable key : Type.
  Variable Key : Oeset.Rcd key.

  Variable proj : elt -> key.
  Variable theta : list elt -> bool.
  Variable build : list elt -> elt.

(*  Fixpoint assoc e ls :=
    match ls with
    | nil => (proj e, (e::nil))::nil
    | (k,l)::ls =>
      match Oeset.compare Key k (proj e) with
      | Eq => (k,e::l)::ls
      | _ => (k,l)::(assoc e ls)
      end
    end.
*)

Notation assoc := (group Key proj).

  Definition group (c : Cursor.cursor C) :=
    let c' := Cursor.reset c in
    SeqScan.mk_seqcursor (
        List.map (fun l => build (snd l))
                 (List.filter
                    (fun l => theta (snd l))
                    (snd (iter Cursor.next (Cursor.ubound c') c' assoc nil))
                 )
      ).

  Hypothesis proj_eq : forall e1 e2,
      Oeset.compare Elt e1 e2 = Eq ->
      Oeset.compare Key (proj e1) (proj e2) = Eq.
  Hypothesis build_eq : forall l1 l2,
    comparelA (Oeset.compare Elt) l1 l2 = Eq ->
    Oeset.compare Elt (build l1) (build l2) = Eq.
  Hypothesis theta_eq : forall l1 l2,
    comparelA (Oeset.compare Elt) l1 l2 = Eq -> theta l1 = theta l2.

  Definition OL : Oeset.Rcd (list elt) := mk_oelists Elt.
  Definition OKL : Oeset.Rcd (key * list elt) := mk_oepairs Key OL.
  Definition OKLleft : Oeset.Rcd (key * list elt) := mk_oepairsleft (list elt) Key.

  Lemma assoc_eq (x1 x2 : elt) (Heqx : Oeset.compare Elt x1 x2 = Eq) :
    forall (y1 y2 : list (key * list elt)),
      comparelA (Oeset.compare OKL) y1 y2 = Eq ->
      comparelA (Oeset.compare OKL) (assoc x1 y1) (assoc x2 y2) = Eq.
  Proof.
    induction y1 as [ |[k1 l1] ys1 IHys1]; intros [ |[k2 l2] ys2]; simpl.
    - intros _. now rewrite (proj_eq _ _ Heqx), Heqx.
    - discriminate.
    - discriminate.
    - case_eq (Oeset.compare Key k1 k2); try discriminate. intro Heqk.
      case_eq (comparelA (Oeset.compare Elt) l1 l2); try discriminate. intros Heql Heqys.
      case_eq (Oeset.compare Key k1 (proj x1)); intro Heq4.
      + replace (Oeset.compare Key k2 (proj x2)) with Eq; simpl.
        * now rewrite Heqk, Heqx, Heql.
        * symmetry. apply (Oeset.compare_eq_trans _ _ k1).
          {
            now apply Oeset.compare_eq_sym.
          }
          {
            apply (Oeset.compare_eq_trans _ _ (proj x1)); trivial.
            now apply proj_eq.
          }
      + replace (Oeset.compare Key k2 (proj x2)) with Lt; simpl.
        * rewrite Heqk, Heql. now apply IHys1.
        * symmetry. apply (Oeset.compare_eq_lt_trans _ _ k1).
          {
            now apply Oeset.compare_eq_sym.
          }
          {
            apply (Oeset.compare_lt_eq_trans _ _ (proj x1)); trivial.
            now apply proj_eq.
          }
      + replace (Oeset.compare Key k2 (proj x2)) with Gt; simpl.
        * rewrite Heqk, Heql. now apply IHys1.
        * symmetry. apply (Oeset.compare_eq_gt_trans _ _ k1).
          {
            now apply Oeset.compare_eq_sym.
          }
          {
            apply (Oeset.compare_gt_eq_trans _ _ (proj x1)); trivial.
            now apply proj_eq.
          }
  Qed.

  Lemma assoc_nb_occ_key e : forall ls,
      (forall p, (Oeset.nb_occ OKLleft p ls <= 1)%N) ->
      forall p,
        (Oeset.compare Key (fst p) (proj e) <> Eq ->
         Oeset.nb_occ OKLleft p (assoc e ls) = Oeset.nb_occ OKLleft p ls)
        /\
        (Oeset.compare Key (fst p) (proj e) = Eq ->
         Oeset.nb_occ OKLleft p (assoc e ls) = 1%N).
  Proof.
    induction ls as [ |[k l] ls IHls]; intros Hls [k' l']; simpl; split; intro H.
    - case_eq (Oeset.compare Key k' (proj e)); auto; try lia.
      intro H'. now elim H.
    - now rewrite H.
    - simpl in Hls. assert (H':forall p : key * list elt, (Oeset.nb_occ OKLleft p ls <= 1)%N).
      {
        intros [k1 l1]. generalize (Hls (k1, l1)). case (compareAl (Oeset.compare Key) (k1, l1) (k, l)); lia.
      }
      assert (IH:=IHls H'). clear IHls. destruct (IH (k', l')) as [IH1 _]. assert (IH':=IH1 H); clear IH1.
      case_eq (Oeset.compare Key k (proj e)); intro Heqk; auto; simpl; now rewrite IH'.
    - simpl in Hls. assert (H':forall p : key * list elt, (Oeset.nb_occ OKLleft p ls <= 1)%N).
      {
        intros [k1 l1]. generalize (Hls (k1, l1)). case (compareAl (Oeset.compare Key) (k1, l1) (k, l)); lia.
      }
      assert (IH:=IHls H'). clear IHls. destruct (IH (k', l')) as [_ IH2]. assert (IH':=IH2 H); clear IH2.
      case_eq (Oeset.compare Key k (proj e)); intro Heqk; simpl.
      + assert (H0:Oeset.compare Key k' k = Eq) by (eauto using Oeset.compare_eq_trans, Oeset.compare_eq_sym).
        rewrite H0. generalize (Hls (k',l')). simpl. rewrite H0. intro H1.
        now replace (Oeset.nb_occ OKLleft (k', l') ls) with 0%N by lia.
      + replace (Oeset.compare Key k' k) with Gt; auto.
        symmetry. rewrite Oeset.compare_lt_gt. apply Oeset.compare_eq_sym in H.
        now rewrite (Oeset.compare_lt_eq_trans _ _ _ _ Heqk H).
      + replace (Oeset.compare Key k' k) with Lt; auto.
        symmetry. rewrite Oeset.compare_lt_gt. apply Oeset.compare_eq_sym in H.
        now rewrite (Oeset.compare_gt_eq_trans _ _ _ _ Heqk H).
  Qed.

  Lemma assoc_nb_occ e ls (Hls: forall p, (Oeset.nb_occ OKLleft p ls <= 1)%N) p :
    (Oeset.nb_occ OKLleft p (assoc e ls) <= 1)%N.
  Proof.
    destruct (assoc_nb_occ_key e ls Hls p) as [H1 H2].
    case_eq (Oeset.compare Key (fst p) (proj e)); intro Heq.
    - now rewrite H2.
    - rewrite H1; auto. now rewrite Heq.
    - rewrite H1; auto. now rewrite Heq.
  Qed.

  Lemma buckets_nb_occ_strong : forall n (c : Cursor.cursor C) acc,
    (forall p, (Oeset.nb_occ OKLleft p acc <= 1)%N) ->
    forall p, (Oeset.nb_occ OKLleft p (snd (iter Cursor.next n c assoc acc)) <= 1)%N.
  Proof.
    induction n as [ |n IHn]; intros c acc Hacc p; auto.
    unfold iter. rewrite nat_iter_succ_r. case_eq (Cursor.next c); intros t c'' Heq.
    change (Nat.iter n
           (fun c'l : Cursor.cursor C * list (key * list elt) =>
            let (c', l) := c'l in
            let (r, c''0) := Cursor.next c' in
            (c''0,
            match r with
            | Result r' => assoc r' l
            | No_Result => l
            | Empty_Cursor => l
            end))
           (c'',
           match t with
           | Result r' => assoc r' acc
           | No_Result => acc
           | Empty_Cursor => acc
           end)) with (iter Cursor.next n c'' assoc (match t with
           | Result r' => assoc r' acc
           | No_Result => acc
           | Empty_Cursor => acc
           end)).
    apply IHn. intro p'. destruct t as [r'| | ]; auto.
    now apply assoc_nb_occ.
  Qed.

  Lemma buckets_nb_occ (c : Cursor.cursor C) n p :
    (Oeset.nb_occ OKLleft p (snd (iter Cursor.next n c assoc nil)) <= 1)%N.
  Proof.
    apply buckets_nb_occ_strong. intros; simpl; lia.
  Qed.

  Lemma buckets_collection q :
    comparelA (Oeset.compare OKL)
              (snd (iter Cursor.next (Cursor.ubound (Cursor.reset q)) (Cursor.reset q) assoc nil))
              (fold_left (fun a e => assoc e a) (Cursor.collection (r:=C) q) nil)
    = Eq.
  Proof.
    assert (Hr := Cursor.reset_coherent q).
    assert (H := Cursor.ubound_complete assoc nil Hr _ (le_n _)).
    apply (Cursor.has_next_spec (Cursor.iter_coherent _ _ _ assoc nil Hr)) in H.
    rewrite Cursor.iter_collection in H; trivial.
    rewrite Cursor.reset_collection in H.
    generalize (Cursor.iter_visited_gen _ assoc (Cursor.ubound (Cursor.reset q)) nil _ (Cursor.reset_coherent q)). rewrite Cursor.reset_visited. simpl.
    case_eq (iter Cursor.next (Cursor.ubound (Cursor.reset q)) (Cursor.reset q) assoc nil); intros c' l' Heq. intro; subst l'.
    simpl. rewrite Heq in H. simpl in H.
    apply (Oeset.compare_eq_sym (mk_oelists OKL)).
    apply (fold_left_rev_right_eq _ Elt); trivial.
    now intros; apply assoc_eq.
  Qed.

  Lemma group_collection q :
    comparelA (Oeset.compare Elt)
              (Cursor.collection (r:=SeqScan.SeqScan.build Elt) (group q))
              (List.map build (List.filter theta (List.map snd (List.fold_left (fun acc e => assoc e acc) (Cursor.collection q) nil))))
    = Eq.
  Proof.
    rewrite ListFacts.filter_map, map_map. unfold group. simpl.
    apply (comparelA_map_eq_2 OKL).
    - intros [k1 l1] [k2 l2]. simpl.
      destruct (Oeset.compare Key k1 k2); try discriminate.
      apply build_eq.
    - apply comparelA_eq_filter.
      + intros [k1 l1] [k2 l2]. simpl. intros _.
        destruct (Oeset.compare Key k1 k2); try discriminate.
        apply theta_eq.
      + apply buckets_collection.
  Qed.

End Group.


Require Import ExtLib.Structures.Monad.

Set Implicit Arguments.

Class MonadFix (m : Type -> Type) : Type :=
{ mfix : forall {T U}, ((T -> m U) -> T -> m U) -> T -> m U }.

Section MonadFix.

  Fixpoint ftype (ls : list Type) (r : Type) : Type :=
    match ls with
      | nil => r
      | cons l ls => l -> ftype ls r
    end.

  Fixpoint tuple (ls : list Type) : Type :=
    match ls with
      | nil => unit
      | cons l ls => l * tuple ls
    end%type.

  Fixpoint wrap (ls : list Type) R {struct ls} : (tuple ls -> R) -> ftype ls R :=
    match ls as ls return (tuple ls -> R) -> ftype ls R with
      | nil => fun f => f tt
      | cons l ls => fun f => fun x => wrap ls (fun g => f (x,g))
    end.

  Fixpoint apply (ls : list Type) R {struct ls} : ftype ls R -> tuple ls -> R :=
    match ls as ls return ftype ls R -> tuple ls -> R with
      | nil => fun f _ => f
      | cons l ls  => fun f t => @apply ls R (f (fst t)) (snd t)
    end.

  Context {m : Type -> Type} {MF : MonadFix m}.

  Definition mfix_multi (ls : list Type) (R : Type)
    (f : ftype ls (m R) -> ftype ls (m R))
    : ftype ls (m R) :=
    @wrap ls (m R) (@mfix _ MF (tuple ls) R
      (fun packed => apply ls (m R) (f (wrap ls packed)))).

  Context {mMonad:Monad m}.

  Definition mfix2 A B C
    (ff:(A -> B -> m C) -> (A -> B -> m C)) (a:A) (b:B) : m C :=
    let ff' fabp (abp:A*B) :=
      let (a,b) := abp in
      let fab a b := fabp (a,b) in
      ff fab a b
    in
    mfix ff' (a,b).

  Definition mfix3 A B C D
    (ff:(A -> B -> C -> m D) -> (A -> B -> C -> m D))
    (a:A) (b:B) (c:C) : m D :=
    let ff' fabcp (abcp:A*B*C) :=
      let (abp,c) := abcp in
      let (a,b) := abp in
      let fabc a b c := fabcp (a,b,c) in
      ff fabc a b c
    in
    mfix ff' (a,b,c).

End MonadFix.
Arguments mfix {m MonadFix T U} _ _.


Require Export CatSem.CAT.cat_TYPE.
Require Export CatSem.CAT.orders.
Require Export CatSem.CAT.subcategories.
Require Export CatSem.CAT.product.
Require Export CatSem.CAT.initial_terminal.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

(** a category of preorders and maps (not necessarily monotone)
    between them
*)

Obligation Tactic := cat; unfold Proper; do 2 red; cat;
       repeat rew_all; cat.

Program Instance wPO_struct : Cat_struct (fun a b : PO_obj => a -> b) := {
   mor_oid a b := TYPE_hom_oid a b;
   id a := fun x: a => x;
   comp a b c := fun (f:a -> b) (g:b -> c) => fun x => g (f x)
}.

Definition wOrd := Build_Cat wPO_struct.

Class Monotone (a b : wOrd) (f : a ---> b) :=
  monotone : Proper (Rel ==> Rel) f.

Obligation Tactic := mauto ; unfold Monotone; cat;
                 unfold Proper, respectful in *; mauto.
(*
Obligation Tactic := idtac.
*)
Program Instance wPO_monotone_SubCat : SubCat_compat wOrd
      (fun x => True) (fun a b f => Monotone f).

Definition wPO_monotone := SubCat wPO_monotone_SubCat.

Program Instance wPO_prod : Cat_Prod wOrd := {
  product a b := PO_product a b;
  prl a b := fst;
  prr a b := snd;
  prod_mor a b c f g := fun z => (f z, g z)
}.

Program Instance wPO_Terminal : Terminal wOrd := {
  Term := PO_TERM;
  TermMor a := fun x => tt
}.

Obligation Tactic := simpl; intros;
  repeat match goal with [H:TEMPTY |- _ ] => elim H end;
      cat.

Program Instance TYPE_init : Initial wOrd := {
  Init := PO_INIT
}.


Add Rec LoadPath "." as DEP_AI.

Require Import List.
Require Import Peano_dec.
Require Import Arith.
Require Export ZArith.

Require Import ensembles.
Require Import Finite_sets.

(* identifiers *)
Parameter identifier : Set.
Parameter beq_identifier : identifier -> identifier -> bool.
Parameter beq_identifier_eq : forall n m : identifier, beq_identifier n m = true -> n = m.
Parameter eq_beq_identifier : forall n m : identifier, n = m -> beq_identifier n m = true.
Parameter neq_beq_identifier : forall n m : identifier, n <> m -> beq_identifier n m = false.
Parameter identifier_dec : forall n m : identifier, {n = m} + {n <> m}.

(* names of data constructors *)
Definition constr : Set := nat.

(* labels *)
Parameter label : Set.
Parameter eq_label_dec : forall n m : label, {n = m} + {n <> m}.
Definition eq_label (x y:label) : Prop := x = y.
Definition neq_label (x y:label) : Prop := x <> y.
Parameter eq_label_decide : forall n m : label, {eq_label n m} + {~ eq_label n m}.
Parameter eq_label_eq : forall n m : label, eq_label n m -> n = m.
Parameter eq_eq_label : forall n m : label, n = m -> eq_label n m.
Parameter label_finite_set : forall s : Ensemble label, exists lst : list label,
                               forall l:label, In _ s l <-> List.In l lst.

Inductive pattern : Set :=
 | P_Constr0 : constr -> pattern
 | P_Constr1 : constr -> identifier -> pattern
 | P_Couple  : identifier -> identifier -> pattern.

Inductive expr : Set :=
  | Num :  Z -> expr
  | Constr0 : constr ->  expr
  | Constr1 : constr ->  expr -> expr
  | Var : identifier -> expr
  | Lambda : identifier -> expr -> expr
  | Rec : identifier -> identifier -> expr -> expr
  | Apply : expr -> expr -> expr
  | If : expr -> expr -> expr -> expr
  | Expr_match : expr -> (pattern*expr) -> option (identifier*expr) -> expr
  | Couple : expr -> expr -> expr
  | Annot : label -> expr -> expr
  | Let_in : identifier -> expr -> expr -> expr.


Require Import util.

Definition constant_bits := 32.
Definition register_bits := 4.

(* Wrapper types for safety *)

Inductive immediate: Type :=
| imm: forall (i: N), immediate.
Inductive displacement: Type :=
| dsp: forall (d: N), displacement.
Inductive destination: Type :=
| dst: forall (d: N), destination.
Inductive register: Type :=
| reg: forall (r: N), register.

Inductive operator: Set :=
| addl
| subl
| andl
| xorl.

Inductive condition: Set :=
| none
| le
| l
| e
| ne
| ge
| g.

Inductive instruction: Type :=
| halt: instruction
| nop: instruction
| rrmovl: condition -> register -> register -> instruction
| irmovl: register -> immediate -> instruction
| rmmovl: register -> register -> displacement -> instruction
| mrmovl: register -> register -> displacement -> instruction
| OPl: operator -> register -> register -> instruction
| jump: condition -> destination -> instruction
| call: destination -> instruction
| ret: instruction
| pushl: register -> instruction
| popl: register -> instruction.

Definition instructions := list instruction.

(* Validity rules *)

Definition valid_register (n: N): Prop := (n <= 7)%N.

Definition valid_constant (n: N): Prop := N.size_nat n <= constant_bits.

Inductive valid_instruction: instruction -> Type :=
| valid_halt: valid_instruction halt
| valid_nop: valid_instruction nop
| valid_rrmovl: forall(c: condition)(r1 r2: N),
                  valid_register r1 ->
                  valid_register r2 ->
                    valid_instruction (rrmovl c (reg r1) (reg r2))
| valid_irmovl: forall(r1 c: N),
                  valid_register r1 ->
                  N.size_nat c <= constant_bits ->
                    valid_instruction (irmovl (reg r1) (imm c))
| valid_rmmovl: forall(r1 r2 c: N),
                  valid_register r1 ->
                  valid_register r2 ->
                  N.size_nat c <= constant_bits ->
                    valid_instruction (rmmovl (reg r1) (reg r2) (dsp c))
| valid_mrmovl: forall(r1 r2 c: N),
                  valid_register r1 ->
                  valid_register r2 ->
                  valid_constant c ->
                    valid_instruction (mrmovl (reg r1) (reg r2) (dsp c))
| valid_OPl: forall(o: operator)(r1 r2: N),
                  valid_register r1 ->
                  valid_register r2 ->
                    valid_instruction (OPl o (reg r1) (reg r2))
| valid_jump: forall(cond: condition)(c: N),
                  valid_constant c ->
                    valid_instruction (jump cond (dst c))
| valid_call: forall(c: N),
                  valid_constant c ->
                    valid_instruction (call (dst c))
| valid_ret: valid_instruction ret
| valid_pushl: forall(r: N),
                    valid_register r -> valid_instruction (pushl (reg r))
| valid_popl:  forall(r: N),
                    valid_register r -> valid_instruction (popl (reg r)).


Require Import Psatz.

Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Require Import Coq.Arith.PeanoNat.

Require Export SystemFR.Tactics.

Notation "A - n" := (List.remove PeanoNat.Nat.eq_dec n A).
Notation "A ++ B" := (List.app A B).
Notation "x ∈ A" := (In x A) (at level 70).

Definition empty {T}: list T := nil.

Definition add {T} (s: list T) (t: T) := t :: s.

Definition singleton {T} (t: T): list T := add nil t.

Fixpoint diff {A} (dec: forall a b: A, { a = b } + { a <> b }) (l1 l2: list A): list A :=
  match l2 with
  | nil => l1
  | x :: xs => diff dec (remove dec x l1) xs
  end.

Notation "A -- B" := (diff PeanoNat.Nat.eq_dec A B) (at level 50).

Lemma add_mem: forall {T} (s: list T) x, x ∈ (add s x).
  steps.
Qed.

#[export]
Hint Resolve add_mem: sets.

Lemma add_more: forall {T} (s: list T) x y,
    x ∈ s ->
    x ∈ add s y.
Proof.
  steps.
Qed.

#[export]
Hint Resolve add_more: sets.

Definition subset {T} (l1 l2: list T) :=
  forall x, x ∈ l1 -> x ∈ l2.

Definition equal_set {T} (l1 l2: list T) :=
  forall x, x ∈ l1 <-> x ∈ l2.

Lemma not_in_append: forall {T} l1 l2 (x: T),
    ~(x ∈ l1 ++ l2) ->
    (~(x ∈ l1) /\ ~(x ∈ l2)).
Proof.
  steps; eauto with *.
Qed.

Lemma in_remove:
  forall S x y,
   x ∈ S - y <-> x ∈ S /\ x <> y.
Proof.
  induction S; repeat step || rewrite IHS in *.
Qed.

#[export] Hint Rewrite in_remove: list_utils.

Lemma in_diff:
  forall S2 x S1,
   x ∈ S1 -- S2 <-> x ∈ S1 /\ ~(x ∈ S2).
Proof.
  induction S2; repeat step || rewrite IHS2 in * || autorewrite with list_utils in *.
Qed.

#[export] Hint Rewrite in_diff: list_utils.

Lemma app_eq_nil_iff:
  forall A (l l': list A),
    l ++ l' = nil <-> (l = nil /\ l' = nil).
Proof.
  destruct l; steps.
Qed.

#[export] Hint Rewrite List.app_nil_r: list_utils.

Ltac list_utils :=
  match goal with
  | H: _ = nil |- _ => rewrite H in *
  | H: nil = _ ++ _ :: _ |- _ => apply False_ind; apply (app_cons_not_nil _ _ _ H)
  | H: context[_ ∈ _ ++ _] |- _  => rewrite in_app_iff in H
  | |- context[_ ∈ _ ++ _] => rewrite in_app_iff
  | H: forall n, n ∈ (?s1 ++ ?s2) -> _,
    H': ?n ∈ ?s1 |- _ =>
      poseNew (Mark (H, n) "list_utils1");
      unshelve epose proof H n _;
      repeat light || rewrite in_app_iff
  | H: forall n, n ∈ (?s1 ++ ?s2) -> _,
    H': ?n ∈ ?s2 |- _ =>
      poseNew (Mark (H, n) "list_utils2");
      unshelve epose proof H n _;
      repeat light || rewrite in_app_iff
  | H: forall n, n ∈ (?s1 ++ ?s2 ++ ?s3) -> _,
    H': ?n ∈ ?s1 |- _ =>
      poseNew (Mark (H, n) "list_utils3");
      unshelve epose proof H n _;
      repeat light || rewrite in_app_iff
  | H: forall n, n ∈ (?s1 ++ ?s2 ++ ?s3) -> _,
    H': ?n ∈ ?s2 |- _ =>
      poseNew (Mark (H, n) "list_utils4");
      unshelve epose proof H n _;
      repeat light || rewrite in_app_iff
  | H: forall n, n ∈ (?s1 ++ ?s2 ++ ?s3) -> _,
    H': ?n ∈ ?s3 |- _ =>
      poseNew (Mark (H, n) "list_utils5");
      unshelve epose proof H n _;
      repeat light || rewrite in_app_iff
  | H: ?x ∈ ?l |- context[map ?f ?l] =>
    poseNew (Mark (f,l,x) "in_map");
    poseNew (in_map _ _ f l x)
  | H: ?y ∈ map ?f ?l |- _ =>
    poseNew (Mark (y,f,l) "in_map_iff");
    poseNew (proj1 (in_map_iff f l y) H)
  | H:  (?x ∈ ?l1 ++ ?l2) -> False |- _ =>
    poseNew (Mark (l1,l2,x) "not_in_append");
    poseNew (not_in_append l1 l2 x H)
  | |- context[?l1 ++ ?l2 = nil]  => rewrite (app_eq_nil_iff _ l1 l2)
  | H: context[?l1 ++ ?l2 = nil] |- _  => rewrite (app_eq_nil_iff _ l1 l2) in H
  | _ => progress (autorewrite with list_utils in *)
  end.

Lemma empty_list:
  forall A (l: list A),
    (forall x, x ∈ l -> False) ->
    l = nil.
Proof.
  destruct l; steps; eauto with exfalso.
Qed.

#[export]
Hint Resolve empty_list: list_utils.

#[export]
Hint Extern 50 => list_utils: list_utils.

Lemma empty_list_rewrite:
  forall A (l: list A),
    (forall x, x ∈ l -> False) <->
    l = nil.
Proof.
  destruct l; steps; eauto with exfalso.
Qed.

Lemma empty_list2:
  forall A (l: list A) x,
    l = nil ->
    x ∈ l ->
    False.
Proof.
  steps.
Qed.

Lemma NoDup_append:
  forall A (l1 l2: list A) x,
    NoDup (l1 ++ l2) ->
    x ∈ l1 ->
    x ∈ l2 ->
    False.
Proof.
  induction l1; repeat step || step_inversion NoDup || list_utils; eauto.
Qed.

Lemma cons_append:
  forall A (l1 l2: list A) x,
    l1 ++ x :: l2 = (l1 ++ (x :: nil)) ++ l2.
Proof.
  repeat step || rewrite <- List.app_assoc.
Qed.

Lemma cons_app:
  forall X (x: X) (xs: list X),
    x :: xs = (x :: nil) ++ xs.
Proof.
  steps.
Qed.

Lemma NoDup_false:
  forall T (x: T) l,
    NoDup (x :: x :: l) ->
    False.
Proof.
  repeat step || step_inversion NoDup.
Qed.

Lemma NoDup_false2:
  forall T (x y: T) l,
    NoDup (x :: y :: x :: l) ->
    False.
Proof.
  repeat step || step_inversion NoDup.
Qed.

Lemma NoDup_false3:
  forall T (x y: T) l,
    NoDup (y :: x :: x :: l) ->
    False.
Proof.
  repeat step || step_inversion NoDup.
Qed.

Ltac nodup :=
  apply_anywhere NoDup_false ||
  apply_anywhere NoDup_false2 ||
  apply_anywhere NoDup_false3.

Lemma Forall_inst:
  forall A (P: A -> Prop) l x,
    x ∈ l ->
    Forall P l ->
    P x.
Proof.
  repeat step || rewrite Forall_forall in *.
Qed.

Ltac Forall_inst :=
  match goal with
  | H1: ?x ∈ ?l, H2: Forall ?P ?l |- _ =>
    poseNew (Mark (x, H2) "Forall_inst");
    pose proof (Forall_inst _ _ _ _ H1 H2)
  end.

Lemma decide_empty:
  forall T (l: list T), l = nil \/ ~ l = nil.
Proof.
  destruct l; steps; right; steps.
Qed.


From Rela Require Import Com.
From Rela Require Import Inliner.
From Rela Require Import Aexp.
From Rela Require Import Bexp.
From Rela Require Import Sigma.
From Rela Require Import Loc.
From Rela Require Import Proc.
From Coq Require Import Lists.List.
Import ListNotations.

(** Definition of Precondtion **)

Definition precondition : Type := sigma -> Prop.

Definition empty_precondition : precondition := (fun _ => False).

(** Definition of Postcondtion **)

Definition postcondition : Type := sigma -> sigma -> Prop.

Definition empty_postcondition :  postcondition := (fun _ _ => True).

(** Defintion of a Hoare Triple **)

Definition hoare_triple (P : precondition) (Q: postcondition) (c : com) (ps : Psi.psi) : Prop :=
  forall s s',  P s -> ceval c s ps s' -> Q s' s.

(** Facts about Hoare Triples **)

Lemma seq_hoare_triple :
  forall p1 p2 ps (P:precondition) (Q: postcondition),
    hoare_triple P (fun s' s => forall s'', ceval p2 s' ps s'' -> Q s'' s) p1 ps ->
    hoare_triple P Q (CSeq p1 p2) ps.
Proof.
  unfold hoare_triple.
  intros. inversion H1;subst.
  specialize (H s s'0 H0 H4).
  apply H.
  apply H8.
Qed.

Lemma if_hoare_triple :
  forall p1 p2 b ps (P: precondition) (Q: postcondition),
    hoare_triple (fun s => P s /\ beval s b = true) Q p1 ps ->
    hoare_triple (fun s => P s /\ beval s b = false) Q p2 ps ->
    hoare_triple P Q (CIf b p1 p2) ps.
Proof.
  intros p1 p2 b ps P Q HTrue HFalse s s' HP HE.
  inversion HE;subst.
  - unfold hoare_triple in HTrue.
    eapply HTrue.
    + split.
      * apply HP.
      * assumption.
    + apply H6.
  - unfold hoare_triple in HFalse.
    eapply HFalse.
    + split.
      * apply HP.
      * assumption.
    + apply H6.
Qed.

Lemma while_triple :
  forall (inv: assertion) b c ps l,
    (forall s1 s2, inv (s1 :: l) /\ beval s1 b = true ->
                     ceval c s1 ps s2 -> inv (s2 :: l)) ->
    hoare_triple (fun s => inv (s :: l))
                ( fun s' _ => inv (s' :: l) /\ beval s'  b = false )
                (CWhile b c inv) ps.
Proof.
  intros P b c ps l st Hhoare st' HP Heval.
  remember (CWhile b c P) as original_command eqn:Horig.
  induction Heval; try inversion Horig.
  * inversion Horig;subst. eauto.
  * inversion Horig;subst.
    eauto.
Qed.

(** Definition of a procedure contract **)

Definition clause : Type := precondition * postcondition.

Definition empty_clause : clause := (empty_precondition, empty_postcondition).

Definition get_pre (an:clause) :=
          let (pre,post) := an in
          pre.

Definition get_post (an:clause) :=
          let (pre,post) := an in
          post.

(** Defintion of contract environments :
    a map from procedure name to clauses **)

Module Phi.

  Definition phi : Type := Proc.t -> clause.

  Definition empty_phi: phi := fun _ => empty_clause.

End Phi.

(** Defintion of a Hoare Triple with inliner **)

Definition i_hoare_triple (n: nat)
  (P: precondition) (Q: postcondition)
  (c : com) (ps : Psi.psi) : Prop :=
  forall s s',  P s -> ceval c s (k_inliner_ps n ps) s'  -> Q s' s.

Lemma i_hoare_triple_hoare_triple :
  forall P Q p ps,
  hoare_triple P Q p ps <-> forall n, i_hoare_triple n P Q p ps.
Proof.
unfold hoare_triple, i_hoare_triple;split;intros H.
* intros n s s' Pre Heval.
  eapply H.
  apply Pre.
  apply n_inline_ps_ceval in Heval.
  assumption.
* intros s s' HPre Heval.
  apply ceval_n_inline_ps in Heval.
  destruct Heval.
  eapply H.
  + apply HPre.
  + apply H0.
Qed.

(** Hoare triple for a com with procedure context **)

Definition hoare_triple_ctx (cl : Phi.phi) (ps: Psi.psi)
      (P: precondition) (Q: postcondition)  (c: com) :=
    (forall p, hoare_triple (get_pre (cl p)) (get_post (cl p)) (CCall p) ps) ->
      hoare_triple P Q c ps.

(** Hoare triple for a procedure with procedure context **)

Definition hoare_triple_proc_ctx (cl : Phi.phi) (ps_init :Psi.psi):=
  forall p ps, hoare_triple_ctx cl ps (get_pre (cl p)) (get_post (cl p)) (ps_init p).

Lemma recursive_proc ps cl:
    hoare_triple_proc_ctx cl ps ->
   (forall p, hoare_triple (get_pre (cl p)) (get_post (cl p)) (CCall p) ps).
Proof.
intros.
apply i_hoare_triple_hoare_triple.
intros n.
generalize dependent p.
induction n.
* intros p s s' HPre Heval.
  inversion Heval;subst.
  apply ceval_inf_loop in H1.
  contradiction H1.
* intros p s s' HPre Heval.
  eapply H.
  + apply IHn.
  + apply HPre.
  + apply n_inline_ps_inline in Heval.
    apply Heval.
Qed.

(** Modular Hoare Triple Verification **)

Theorem recursion_hoare_triple :
  forall P Q p ps cl,
    hoare_triple_proc_ctx cl ps  ->
    hoare_triple_ctx cl ps P Q p ->
    hoare_triple P Q p ps.
Proof.
intros.
apply H0.
apply recursive_proc.
assumption.
Qed.

(** Corollaire from recursion_hoare_triple **)

Theorem procedure_hoare_triple :
  forall p cl ps,
    hoare_triple_proc_ctx cl ps  ->
    hoare_triple (get_pre (cl p)) (get_post (cl p)) (ps p) ps.
Proof.
intros.
apply recursion_hoare_triple with cl.
assumption.
apply H.
Qed.