Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj4eqsynthconj4 : forall  (lv0 : natural), (@eq natural (Succ lv0) (plus (Succ Zero) lv0)).
Admitted.
QuickChick conj4eqsynthconj4.


Require Import Utf8.
Require Import Cpdt.CpdtTactics.

Set Implicit Arguments.

(* Implicit Types V: Set. *)

Inductive inc (V: Set) : Set :=
  | VZ : inc V
  | VS : V -> inc V.

Arguments VZ {V}.
Arguments VS {V}.

Inductive ty : Set :=
  | ty_bool : ty
  | ty_arrow : ty -> ty -> ty.

Inductive val (V: Set) : Set :=
  | v_var  : V -> val V
  | v_true : val V
  | v_false : val V
  | v_abs  : ty -> exp (inc V) -> val V
with exp (V : Set) : Set :=
  | e_val  : val V -> exp V
  | e_if   : exp V -> exp V -> exp V -> exp V
  | e_app  : exp V -> exp V -> exp V.

Arguments v_true {V}.
Arguments v_false {V}.
Arguments e_val {V}.
Arguments e_if {V}.
Arguments e_app {V}.

Notation "∅" := (Empty_set).

Definition empty_fun {T} : ∅ → T :=
  λ y, match y with end.

Notation exp0 := (exp Empty_set).
Notation val0 := (val Empty_set).


Unset Strict Universe Declaration.

Universe b.

Universe c.

Definition U : Type@{b} := Type@{c}.

Module Type MT.

Definition T := Prop.
End MT.

Module M : MT.
   Definition T := Type@{b}.

Print Universes.
Fail End M.

Set Universe Polymorphism.

(* This is a modified version of Hurkens with all universes floating *)
Section Hurkens.

Variable down : Type -> Type.
Variable up : Type -> Type.

Hypothesis back : forall A, up (down A) -> A.

Hypothesis forth : forall A, A -> up (down A).

Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A),
      P (back A (forth A a)) -> P a.

Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A),
      P a -> P (back A (forth A a)).

(** Proof *)
Definition V : Type := forall A:Type, ((up A -> Type) -> up A -> Type) -> up A -> Type.
Definition U : Type := V -> Type.

Definition sb (z:V) : V := fun A r a => r (z A r) a.
Definition le (i:U -> Type) (x:U) : Type := x (fun A r a => i (fun v => sb v A r a)).
Definition le' (i:up (down U) -> Type) (x:up (down U)) : Type := le (fun a:U => i (forth _ a)) (back _ x).
Definition induct (i:U -> Type) : Type := forall x:U, up (le i x) -> up (i x).
Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))).
Definition I (x:U) : Type :=
  (forall i:U -> Type, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False.

Lemma Omega : forall i:U -> Type, induct i -> up (i WF).
Proof.
intros i y.
apply y.
unfold le, WF, induct.
apply forth.
intros x H0.
apply y.
unfold sb, le', le.
compute.
apply backforth_r.
exact H0.
Qed.

Lemma lemma1 : induct (fun u => down (I u)).
Proof.
unfold induct.
intros x p.
apply forth.
intro q.
generalize (q (fun u => down (I u)) p).
intro r.
apply back in r.
apply r.
intros i j.
unfold le, sb, le', le in j |-.
apply backforth in j.
specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))).
apply q.
exact j.
Qed.

Lemma lemma2 : (forall i:U -> Type, induct i -> up (i WF)) -> False.
Proof.
intro x.
generalize (x (fun u => down (I u)) lemma1).
intro r; apply back in r.
apply r.
intros i H0.
apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))).
unfold le, WF in H0.
apply back in H0.
exact H0.
Qed.

Theorem paradox : False.
Proof.
exact (lemma2 Omega).
Qed.

End Hurkens.

Polymorphic Record box (T : Type) := wrap {unwrap : T}.

(* Here we instantiate to Set *)

Fail Definition down (x : Type) : Prop := box x.
Definition up (x : Prop) : Type := x.

Fail Definition back A : up (down A) -> A := unwrap A.

Fail Definition forth A : A -> up (down A) := wrap A.

Definition id {A : Type} (a : A) := a.
Definition setlt (A : Type@{i}) :=
  let foo := Type@{i} : Type@{j} in True.

Definition setle (B : Type@{i}) :=
  let foo (A : Type@{j}) := A in foo B.

Fail Check @setlt@{j Prop}.
Fail Definition foo := @setle@{j Prop}.
Check setlt@{Set i}.
Check setlt@{Set j}.


Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import TLC.LibListSort.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
(* Load the CF definitions. *)
Require Import Floyd_warshall_ml.

Ltac auto_tilde ::= try solve [ auto with maths | false; math ].

(* Parameter Array : forall A, list A -> loc -> hprop. *)

(* Parameter Matrix : forall A, list (list A) -> loc -> hprop := *)
(*   forall A xxs m, *)
(*     Hexists (xs : list loc), m ~> xs \*  *)

Lemma floyd_warshall_spec :
  specZ [cost \in_O (fun n => n ^ 3)]
    (forall a (xs : list (array int)),
      app floyd_warshall [a]
      PRE (\$ cost (length xs) \* a ~> Array xs)
      POST (fun (_:unit) => Hexists (xs' : list (array int)), a ~> Array xs')).
Proof.
  xspecO. xcf. xpay.
  xapps.
  weaken. xfor_inv (fun (_:int) => Hexists (xs1 : list (array int)), a ~> Array xs1). math.
  { intros i Hi. xpull. intros xs1. xpay.
    weaken. xfor_inv (fun (_:int) => Hexists (xs2 : list (array int)), a ~> Array xs2). math.
    { intros j Hj. xpull. intros xs2. xpay.
      weaken. xfor_inv (fun (_:int) => Hexists (xs3 : list (array int)), a ~> Array xs3). math.
      { intros k Hk. xpull. intros xs3. xpay.
        xapps~. admit. xapps.
Abort.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj7synthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus Zero (plus lv0 lv1)) (plus lv1 lv0)).
Admitted.
QuickChick conj7synthconj2.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus lv0 Zero))).
Admitted.
QuickChick conj8eqsynthconj3.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj11synthconj2 : forall  (lv0 : lst), (@eq natural (len (Cons (len Nil) lv0)) (Succ (len lv0))).
Admitted.
QuickChick conj11synthconj2.


Require Import RamifyCoq.graph.find_not_in.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_ind.
Require Import Coq.Logic.ProofIrrelevance.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.relation_list.
Require Import RamifyCoq.lib.Equivalence_ext.

Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.

Arguments clos_refl_trans {A} _ _ _.
Arguments clos_refl_trans_1n {A} _ _ _.
Arguments clos_refl_trans_n1 {A} _ _ _.
Arguments PreGraph _ _ {_} {_}.

Section BiGraph.
Definition V:=nat.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.

(*
Record PreGraph (Vertex Edge : Type) (EV : EqDec Vertex eq)
(EE : EqDec Edge eq) : Type := Build_PreGraph
  { vvalid : Ensemble Vertex;
    evalid : Ensemble Edge;
    src : Edge -> Vertex;
    dst : Edge -> Vertex }

Record LabeledGraph (Vertex Edge : Type) (EV : EqDec Vertex eq)
(EE : EqDec Edge eq) (DV DE DG : Type) : Type
  := Build_LabeledGraph
  { pg_lg : PreGraph Vertex Edge;
    vlabel : Vertex -> DV;
    elabel : Edge -> DE;
    glabel : DG }

    *)

Definition BiGraph_re (pg: PreGraph V E) (f : V -> bool ): Prop :=
  forall e x y, evalid pg e -> src pg e = x -> dst pg e = y -> f x = negb (f y).

Record BiGraph := {
 bgraph : PreGraph V E ;
 vlabel : V -> bool ; (* 表示两个点集 *)
 re : BiGraph_re bgraph vlabel
}.
Fixpoint Inb (x: V) (l : list V) : bool :=
match l with
|nil => false
|y::l' => if  Nat.eqb x y then true else (Inb x l')
end.

Definition Vstateb:= V -> bool.
Definition default_Vstateb : Vstateb := (fun _ => false).
Definition Vstateb_update (m : Vstateb) (v: V) : Vstateb :=
 fun x =>   if Nat.eqb x  v then true else m x.
Definition Vstateb_update_f (m : Vstateb) (v: V) : Vstateb :=
 fun x =>  if Nat.eqb x  v then false else m x.

Definition Vstateb_update_l (m : Vstateb) (v : list V) : Vstateb :=
 fun x => if Inb x v then true else m x.
Definition Vstateb_update_fl (m : Vstateb) (v : list V) : Vstateb :=
 fun x => if Inb x v then false else m x .

Definition Vstateb_update_op (m : Vstateb) (v : option V) : Vstateb :=
fun x => match v with
       |None => m x
       |Some y => Vstateb_update m y  x
       end.
Definition Vstate:= V -> Prop.
Definition default_Vstate : Vstate := (fun _ => False).
Definition Vstate_update (m : Vstate) (v: V) : Vstate :=
 fun x =>   x =  v \/ m x.
Definition Vstate_update_f (m : Vstate) (v: V) : Vstate :=
 fun x =>  ( x = v -> False ) \/ (~ x = v  -> m x).

Definition Vstate_update_l (m : Vstate) (v : list V) : Vstate :=
 fun x => In x v \/ m x.

Definition Vstate_update_fl (m : Vstate) (v : list V) : Vstate :=
 fun x => (In x v -> False ) \/ (~ In  x  v  -> m x).

Definition matching := list E.
Context {BG : BiGraph }.

Fixpoint list_sub (u v :list V) : list V :=
match v with
|nil => u
|e::v' => list_sub (remove EV e u ) v'
end.
Notation Gph := (PreGraph V E).

Fixpoint epath_to_vpath (g: Gph) (p : list E) {struct p} : list V :=
  match p with
  | nil => nil
  | e :: nil => dst g e :: src g e :: nil
  | e :: el => dst g e :: epath_to_vpath' g el
  end.

(*均为有向*)
Definition gra := bgraph BG.

Inductive connected (v: V) (cl : list V) : Prop :=
|connected_intro : forall (x : V ), ( step gra v x <-> In x cl) -> connected v cl .

(*  给出图的点集  *)

Variable LV: list V.
Hypothesis lise_re : forall v , In v LV <-> vvalid gra v.

Definition get_connectednode_func  := V -> list V.
Variable con : V -> list V. (* TODO : 怎么得到一个点的连接点集 *)
Hypothesis conlistre : forall v , connected v (con v).

Fixpoint is_matching (vl: list V)(m : list E):Prop:=
match m with
|nil => True
|e::m' => (~ In (src gra e) vl /\ ~ In (dst gra e) vl)
          /\(is_matching (vl++(src gra e::(dst gra e::nil)))  m')
end.

Definition e_to_v (p : list E) : list V := epath_to_vpath gra p .

Fixpoint Ma (v : V) (M :matching): (option V) :=
match M with
|nil => None
|e::m' => if Nat.eqb (src gra e) v then
          Some (dst gra e) else
            (Ma v m')
end.

Context {M : matching}.

Definition Matching (v: V) : (option V) := Ma v M.
Definition path : Type := (V * list E)%type.

(* Definition crossGraph (matching) : Type :=  PreGraph

 *)

Print Nat.odd.

Variable Max : nat.

(*Inductive
step (Vertex Edge : Type) (EV : EqDec Vertex eq)
(EE : EqDec Edge eq) (pg : PreGraph Vertex Edge)
  : Vertex -> Vertex -> Prop :=
    step_intro : forall (e : Edge) (x y : Vertex),
                 evalid pg e ->
                 src pg e = x ->
                 dst pg e = y -> step pg x y

*)

(* 找到对于一个Vstateb中从大到小的*)
Print nth_In.
Fixpoint conn (v: V) (v1 : Vstateb) (n:nat): V :=
match n with
|O => O
|S n' =>  if Inb (S n') (con v) then
             (if v1 (S n') then n else conn v v1 n')
             else conn v v1 n'
end.

Definition max_conn (v : V) (v1 : Vstateb) := conn v v1 Max.

Inductive cross_step : (Vstateb * path) -> (Vstateb * path ) -> Prop :=
| one_v : forall (u w: V ) (e1 e2 : E) (v1 : Vstateb) ,
    Matching u  = None -> let v := max_conn u v1  in
    src gra e1 = u -> dst gra e1 = v  ->src gra e2 = v -> dst gra e2 = w ->~ In e1 M ->  In e2 M ->
    (*-> Matching v = Some w -> *)
         cross_step (Vstateb_update default_Vstateb u, (u, nil)) ( Vstateb_update (Vstateb_update (Vstateb_update default_Vstateb u)  v) w  , (w ,e2 :: (e1::nil)))
(**从一个非匹配点 经过非匹配边和匹配边  到一个匹配点 *)
| not_one : forall (u  w: V ) (e1 e2 e3 : E)(p :list E) (v1: Vstateb), (* ???  *)
    dst gra e3 = u -> In e3 M -> let v := max_conn u v1 in
    (* Nat.odd (length p) = true ->*)
    v1 u = true -> v1 w = false  ->
    src gra e1 = u -> dst gra e1 = v  -> src gra e2 = v -> dst gra e2 = w -> In e2 M -> ~ In e1 M
    ->(*->
      Matching v = Some w -> *)
         cross_step (v1, (u, e3 :: p)) ( Vstateb_update (Vstateb_update v1  v) w  , (w ,e2::(e1::(e3::p))))
(**从一个匹配点 经过非匹配边和匹配边  到一个匹配点 *)
|yes_to_no : forall (u v : V ) (e1 e2 : E) (p: list E)  (v1 : Vstateb) ,
   dst gra e2 = u ->  In e2 M -> v1 u = true -> let v := max_conn u v1 in
   Matching v = None ->
   src gra e1 = u -> dst gra e1 = v  -> ~ In e1 M ->
         cross_step (v1, (u, e2::p)) ( Vstateb_update v1  v , (v ,e1::(e2::p)))
(**从一个匹配点到非匹配点*)
|no_to_no :  forall (u : V ) (e1 :E)  ,
    Matching u  = None -> let v := max_conn u  (Vstateb_update default_Vstateb u) in
    Matching v = None ->
    src gra e1 = u -> dst gra e1 = v  -> ~ In e1 M ->
         cross_step (Vstateb_update default_Vstateb u, (u, nil))
         (Vstateb_update (Vstateb_update default_Vstateb u) v,(v, e1 :: nil) )
(* *)
|Back_to_yes : forall (u w1 w2: V ) (e1 e2 e3: E)(p :list E)
               (v1: Vstateb),
      dst gra e3 = w2 -> In e3 M ->
      v1 u = true -> max_conn u v1 = O ->
            In e1 M ->  ~In e2 M ->
              src gra e1 = w1 -> dst gra e1 = u  -> src gra e2 = w2 -> dst gra e2 = w1 ->
           cross_step (v1, (u, e1::(e2::(e3::p)))) ( Vstateb_update_fl v1 (list_sub (con u) (e_to_v p) ) , (w2 ,e3::p))
(**回溯到上一个匹配点*)
|Back_to_no : forall (u w1 w2 : V) (e1 e2 : E) (p : list E )
              (v1 : Vstateb) ,
     v1 u = true -> max_conn u v1 = O ->
           In e1 M ->  ~In e2 M ->
             src gra e1 = w1 -> dst gra e1 = u  -> src gra e2 = w2 -> dst gra e2 = w1 ->
           cross_step (v1, (u, e1::(e2::nil))) ( Vstateb_update_fl v1 (list_sub (con u )(e_to_v p) ) , (w2 ,nil))
(** 回溯到初始状态即一个点*)    .

Inductive cross_halt : (Vstateb * path) -> Prop :=
|success : forall (u : V) (v : Vstateb) (e : E )(p : list E),
              Matching u = None ->
            v u = true -> dst gra e = u -> ~ In e M -> cross_halt (v , (u, e::p)).
Definition state := (Vstateb * path)%type.
Definition multi_cstep : state -> state -> Prop := clos_refl_trans cross_step .

Lemma half_halt :
  forall st1 st2, cross_step st1 st2 -> ~ cross_halt st1.
Proof.
  intros.
  unfold not; intros; inversion H.
  - rewrite <- H8 in H0.
    inversion H0.
  - rewrite <- H11 in H0.
    inversion H0. subst. auto.
  - rewrite <- H8 in H0.
    inversion H0. subst. auto.
  - rewrite <- H6 in H0.
    inversion H0.
  - rewrite <- H11 in H0.
    inversion H0. subst. auto.
  - rewrite <- H9 in H0.
    inversion H0. subst. auto.
Qed.

Lemma stay_even :
  forall st1 st2, cross_step st1 st2 -> ~cross_halt st2 ->
    Nat.even (length (snd (snd st1))) = Nat.even (length (snd (snd st2))).
Proof.
  intros.
  induction H.
  - simpl. reflexivity.
  - unfold snd. reflexivity.
  - unfold not in H0. destruct H0. apply success.
    auto.  unfold Vstateb_update.
    assert (Nat.eqb v0 v0 = true).
    apply PeanoNat.Nat.eqb_refl.
    rewrite H0. reflexivity.
    auto. auto.
  - unfold not in H0. destruct H0. apply success.
    auto. unfold Vstateb_update at 1.
    assert (Nat.eqb v v = true).
    apply PeanoNat.Nat.eqb_refl.
    rewrite H0. reflexivity.
    auto. auto.
  - unfold snd. reflexivity.
  - unfold snd. reflexivity.
Qed.

Theorem try :
  forall  ( v: V) st , ~ cross_halt st ->
    multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
      Nat.even (length (snd (snd st))) = true.
Proof.
  intros.
  apply Operators_Properties.clos_rt_rtn1_iff in H0.
  induction H0.
  - reflexivity.
  - pose proof (half_halt y z H0) .
    pose proof (IHclos_refl_trans_n1 H2).
    rewrite <- H3.
    apply eq_sym.
    apply stay_even; auto.
Qed.

Lemma cons_length : forall (v: E) l , length (v::l) = S (length l).
Proof.
  intros.
  induction l.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.
Lemma S_even : forall n , Nat.even (S n) = negb (Nat.even n).
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - rewrite IHn. simpl. rewrite Bool.negb_involutive. reflexivity.
Qed.
Lemma list_ode: forall (v: E) l,  Nat.even (length l) =Nat.odd (length ( v:: l)).
Proof.
 intros. revert v.
 induction l.
 - simpl. reflexivity.
 - unfold Nat.odd. rewrite cons_length. intros. rewrite cons_length.
   rewrite S_even. rewrite S_even. rewrite Bool.negb_involutive.
   unfold Nat.odd in IHl. rewrite (IHl a). apply Bool.negb_involutive.
Qed.

Lemma notmatching : forall v e M, src gra e = v ->
     In e M -> ~ Ma v M = None .
Proof.
  intros.
  unfold not.
  intros. induction M0.
  - inversion H0.
  - inversion H0. rewrite H2 in H1. rewrite <- H in H1. simpl in H1.
    rewrite PeanoNat.Nat.eqb_refl in H1. inversion H1.
    simpl in H1. destruct (Nat.eqb (src gra a) v). inversion H1. apply IHM0. auto. auto.
Qed.

Lemma notmatching_rev : forall v e M, src gra e = v ->
      Ma v M = None -> ~ In e M .
Proof.
  intros.
  unfold not.
  intros. induction M0.
  - inversion H1.
  - inversion H1. rewrite H2 in H0. rewrite <- H in H0. simpl in H0.
    rewrite PeanoNat.Nat.eqb_refl in H0. inversion H0.
    simpl in H0. destruct (Nat.eqb (src gra a) v). inversion H0. apply IHM0. auto. auto.
Qed.

Lemma change_even :
  forall st1 st2, cross_step st1 st2 -> cross_halt st2 ->
    Nat.even (length (snd (snd st1))) = Nat.odd (length (snd (snd st2))).
Proof.
  intros.
  induction H.
  - inversion H0. unfold not in H14. apply H14 in H6.  inversion H6.
  - inversion H0. unfold not in H17. apply H17 in H8.  inversion H8.
  - unfold snd . pose proof (list_ode e1 (e2 :: p)). apply H7.
  - unfold snd. apply list_ode.
  - inversion H0. unfold not in H17. apply H17 in H1.  inversion H1.
  - inversion H0.
Qed.

Theorem path_odevity :
 forall v st, cross_halt st ->
      multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
      Nat.odd (length (snd (snd st))) = true.
Proof.
 intros.
 apply Operators_Properties.clos_rt_rtn1_iff in H0.
 induction H0.
 - inversion H.
 - pose proof (half_halt y z H0).
   assert ( multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) y).
   unfold multi_cstep. apply Operators_Properties.clos_rt_rtn1_iff. apply H1.
   pose proof (try v y H2 H3).
   pose proof (change_even y z H0 H). rewrite H5 in H4. auto.
Qed.

Definition E_eqb (e1 e2: E) : bool :=
  if Nat.eqb (src gra e1) (src gra e2) then
    if Nat.eqb (dst gra e1) (dst gra e2) then
      true
    else false else false.

Fixpoint Inb_edge (x: E) (l : list E) : bool :=
match l with
|nil => false
|y::l' => if  E_eqb x y then true else (Inb_edge x l')
end.

Fixpoint xor_edge (e1: list E) (p: list E) : list E :=
match p with
| nil => e1
| e::_ as p' => if (Inb_edge e e1) then xor_edge e1 p'
    else e::xor_edge e1 p'
end.

Variable de : E.

(**定义增广路*)
Fixpoint cross_path (l: list E) : Prop :=
match l with
|nil => True
|m::nil => True
|m::l' => (* actually hd de l' 不会需要default值*)
             ( In m M /\ ~ In (hd de l') M  \/
                   ~ In m M /\  In (hd de l') M)
             /\ cross_path l'
end.

Definition aug_path (l: list E) : Prop :=
match l with
|nil => False
|m::nil => ~ In m M
|m::n::l' => (~ In m M /\ In n M )/\
          (cross_path l' /\ cross_path (n::l'))
end.

Lemma cross_stay_unit : forall y z ,
   cross_step y z ->
       cross_path (snd (snd y)) -> cross_path (snd (snd z)).
Proof.
  intros.
  induction H.
  - simpl. split. 2: auto.  left. split. auto.
    pose proof ( notmatching_rev u e1 M). apply H7. auto. auto.
  - split. auto. unfold snd in H0. split. auto. auto.
  - unfold snd. unfold snd in H0. split. auto. auto.
  - unfold snd. unfold snd in H0. reflexivity.
  - unfold snd. unfold snd in H0. destruct H0. destruct H10. auto.
  - unfold snd. reflexivity.
Qed.

Theorem cross_stay :
  forall st1 st2, cross_path (snd (snd st1)) ->
      multi_cstep  st1  st2 ->
      cross_path (snd (snd st2)).
Proof.
 intros.
 apply Operators_Properties.clos_rt_rtn1_iff in H0.
 induction H0.
 - unfold snd. auto.
 - pose proof ( cross_stay_unit y z  H0 IHclos_refl_trans_n1 ). auto.
Qed.

Lemma st_ed_unmatched:
  forall (p: list E) (v: V) st, aug_path p -> cross_halt st -> multi_cstep (Vstateb_update default_Vstateb v, (v, nil)) st -> Matching (fst (snd st)) = None.
Proof.
  intros.
  apply Operators_Properties.clos_rt_rtn1_iff in H1.
  induction H1.
  inversion H0.
  inversion H0.
  unfold snd.
  unfold fst.
  exact H3.
Qed.

Lemma match_xor_aug_match:
  forall (e p: list E) (v: V) st, aug_path p -> Matching v = None ->
  cross_halt (st (v, p)) -> multi_cstep (Vstateb_update default_Vstateb v, (v, nil)) (st (v, p)) -> is_matching nil M -> e = xor_edge M p -> is_matching nil e.
Proof.
  intros.
  unfold aug_path in H.
  destruct p.
  unfold xor_edge in H4.
  rewrite H4.
  exact H3.
  destruct p.
  unfold xor_edge in H4;
  destruct (Inb_edge e0 M) in H4.
  rewrite H4.
  exact H3.
  - apply Operators_Properties.clos_rt_rtn1_iff in H2.
    rewrite H4.
    unfold is_matching; repeat split.
    + tauto. + tauto.
    Admitted.

Lemma path_to_aug : forall p ,
    cross_path p ->
      Nat.odd (length p) = true  ->
                    ~ In (last p de) M ->
          aug_path p.
Proof.
  intros.
  induction p.
  - inversion H0.
  - destruct p.
    auto.
    split; split.
    Admitted.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.Cito.SepHintsUtil Bedrock.Platform.Cito.SepHints2.

Set Implicit Arguments.

Section TopSection.

  Lemma split_buf : forall p len pos, buf_splittable len pos -> buf_to_split p len pos ===> p =?> pos * (p ^+ $ (4 * pos)) =?> (len - pos).
    unfold buf_splittable, buf_to_split; intros.
    eapply Himp_trans; [ apply allocated_split | ].
    eassumption.
    apply Himp_star_frame; try apply Himp_refl.
    apply allocated_shift_base; auto.
    rewrite <- wplus_assoc.
    do 2 f_equal.
    rewrite <-natToW_plus.
    unfold natToW; f_equal.
    omega.
  Qed.

  Definition hints_split_buf : TacPackage.
    prepare split_buf tt.
  Defined.

  Definition to_intro_array (_ : W) := True.

  Lemma intro_array' : forall p len base,
    (p ^+ natToW base) =?> len ===>
    Ex ls, [| length ls = len |] * ptsto32m' nil p base ls.
    induction len; simpl; intros.
    apply Himp_ex_c; exists nil.
    sepLemma.

    eapply Himp_trans; [ apply Himp_star_frame; [
      apply Himp_refl | apply allocated_shift_base ] | ].
    3: eapply Himp_trans; [ apply Himp_star_frame; [
      apply Himp_refl | apply IHlen ] | ].
    instantiate (1 := base + 4).
    do 2 rewrite <- wplus_assoc.
    do 2 rewrite <- natToWord_plus.
    do 2 f_equal; omega.
    auto.
    eapply Himp_trans; [ apply Himp_ex_star | ].
    eapply Himp'_ex; intro x.
    eapply Himp_trans; [ apply Himp_star_comm | ].
    eapply Himp_trans; [ apply Himp_ex_star | ].
    eapply Himp'_ex; intro xs.
    apply Himp_ex_c; exists (x :: xs).
    sepLemma.
    replace (base + 4) with (S (S (S (S base)))) by omega.
    reflexivity.
  Qed.

  Lemma intro_array : forall len p, to_intro_array p -> p =?> len ===> Ex ls, [| length ls = len |] * array ls p.
    intros.
    replace (p =?> len)%Sep with ((p ^+ natToW 0) =?> len)%Sep.
    eapply Himp_trans; [ apply intro_array' | ].
    apply Himp_ex; intros.
    apply Himp_star_frame.
    apply Himp_refl.
    apply ptsto32m'_out.
    repeat f_equal; words.
  Qed.

  Definition combined_locals vars1 vars2 vs1 vs2 p  := locals (vars1 ++ vars2) (merge vs1 vs2 vars1) 0 p.

  Lemma fold_combined_locals : forall vars1 vars2 vs1 vs2 p, locals (vars1 ++ vars2) (merge vs1 vs2 vars1) 0 p = combined_locals vars1 vars2 vs1 vs2 p.
    eauto.
  Qed.

  Definition locals_combinable A (vars vars2 : list A) := NoDup (vars ++ vars2).

  Opaque mult.

  Lemma combine_locals : forall vars1 vars2 vs1 vs2 p,
    locals_combinable vars1 vars2
    -> locals vars1 vs1 0 p * locals vars2 vs2 0 (p ^+ $ (4 * length vars1)) ===> combined_locals vars1 vars2 vs1 vs2 p.
    unfold locals, locals_combinable; sepLemma.
    unfold combined_locals, locals.
    sepLemma.
    eapply Himp_trans; [ | apply ptsto32m'_out ].
    eapply Himp_trans; [ | apply ptsto32m'_merge ].
    2: auto.
    eapply Himp_trans; [ apply Himp_star_frame; apply SepHintsUtil.ptsto32m'_in | ].
    apply Himp_star_frame.
    apply Himp_refl.
    eapply Himp_trans; [ | eapply ptsto32m'_shift_base ].
    instantiate (2 := 4 * length vars1).
    replace (0 + 4 * length vars1 - 4 * length vars1) with 0 by omega.
    apply Himp_refl.
    omega.
    apply agree_on_refl.
  Qed.

  Definition hints_intro_array : TacPackage.
    prepare intro_array tt.
  Defined.

  Definition hints_combine_locals : TacPackage.
    prepare tt combine_locals.
  Defined.

  Definition locals_to_split vars1 vars2 vs p := locals (vars1 ++ vars2) vs 0 p.

  Lemma fold_locals_to_split : forall vars1 vars2 vs p, locals (vars1 ++ vars2) vs 0 p = locals_to_split vars1 vars2 vs p.
    eauto.
  Qed.

  Lemma split_locals : forall vars1 vars2 vs p, locals_to_split vars1 vars2 vs p ===> locals vars1 vs 0 p * locals vars2 vs 0 (p ^+ $ (4 * length vars1)).
    unfold locals_to_split, locals; intros.
    sepLemma.
    eauto using NoDup_unapp1.
    eauto using NoDup_unapp2.
    eapply Himp_trans; [ apply SepHintsUtil.ptsto32m'_in | ].
    eapply Himp_trans; [ | apply Himp_star_frame; apply SepHintsUtil.ptsto32m'_out ].
    eapply Himp_trans; [ apply ptsto32m'_split | ].
    apply Himp_star_frame; try apply Himp_refl.
    eapply Himp_trans; [ apply ptsto32m'_shift_base' | ].
    Focus 2.
    apply Himp_refl'; f_equal.
    omega.
    omega.
  Qed.

  Definition hints_split_locals : TacPackage.
    prepare split_locals tt.
  Defined.

End TopSection.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(* Removal of epsilon transitions: from eNFAs to NFAs *)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import Monoid.
Require Import SemiLattice.
Require Import SemiRing.
Require Import KleeneAlgebra.
Require Import MxGraph.
Require Import MxSemiLattice.
Require Import MxSemiRing.
Require Import MxKleeneAlgebra.

Require Import DKA_Definitions.

Require Import Utils_WF.
Require Import Relations.
Require Import Eqdep_dec.

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

Section fold'.
  Variable A: Type.
  Definition stateset_fold p (f: forall i, A -> StateSet.mem i p = true -> A) a :=
    StateSet.fold
      (fun i a =>
        match StateSet.mem i p as x return StateSet.mem i p = x -> A with
          | true => fun H => f i a H
          | false => fun _ => a
        end refl_equal) p a.
  Arguments stateset_fold : clear implicits.

  Lemma bool_dec' : forall a b: bool, a=b \/ a<>b.
  Proof. intros. destruct (bool_dec a b); auto. Qed.

  Lemma stateset_fold_rec_bis:
    forall (P : stateset -> A -> Type) p (f : forall i, A -> StateSet.mem i p = true -> A) i,
      (forall u v a, StateSet.Equal u v -> P u a -> P v a) ->
      P StateSet.empty i ->
      (forall x a q (H: StateSet.mem x p = true),
        ~StateSet.In x q -> P q a -> P (StateSet.add x q) (f x a H)) ->
      P p (stateset_fold p f i).
  Proof.
    intros P p f i Hc Hi Ha. refine (StateSetProps.Props.fold_rec_bis _ _ _); auto.
    clear i Hc Hi.
    intros x a q Hxp Hxq IHa.
    apply StateSet.mem_1 in Hxp.

    replace ((if StateSet.mem x p as x0 return (StateSet.mem x p = x0 -> A)
       then fun H : StateSet.mem x p = true => f x a H
       else fun _ : StateSet.mem x p = false => a)
        refl_equal) with (f x a Hxp). auto.
    remember (f x a) as f'. clear.  revert Hxp f'.
     destruct (StateSet.mem x p); intros.
      rewrite (eq_proofs_unicity bool_dec' Hxp refl_equal). reflexivity.
      discriminate.
  Qed.
End fold'.
Arguments stateset_fold [A].

Section map_transitive_closure.

  Variable f: state -> stateset.
  Let R: relation state := fun i j => StateSet.mem i (f j) = true.

  Definition terminates := Init.Wf.well_founded R.
  Hypothesis Hwf: terminates.

  Definition rt_closure_aux: state -> statemap stateset -> statemap stateset * stateset :=
    Fix Hwf (fun _ => statemap stateset -> statemap stateset * stateset)
      (fun i rt_closure_aux acc =>
        match StateMap.find i acc with
          | Some pi => (acc,pi)
          | None =>
            let (acc,pi) :=
              stateset_fold (f i) (fun j accp Hj =>
                let '(acc,p) := accp in
                  let (acc,pj) := rt_closure_aux j Hj acc in
                    (acc,StateSet.union pj p)
              ) (acc,StateSet.singleton i) in
              (StateMap.add i pi acc, pi)
        end).

  Definition rt_closure_aux' i acc := fst (rt_closure_aux i acc).

  Definition rt_closure size: state -> stateset :=
    statemap_set_to_fun (fold_states rt_closure_aux' size (StateMap.empty _)).

End map_transitive_closure.

Definition set_closure (c: state -> stateset) (p: stateset): stateset :=
  StateSet.fold (fun i => StateSet.union (c i)) p StateSet.empty.

Definition statelabelmap_set_to_fun d := fun a i => optionset_to_set (StateLabelMap.find (i,a) d).

Definition eNFA_to_NFA A (Hwf: eNFA.well_founded A) :=
  let (size,_,delta,initial,final,max_label) := A in
  let eps := rt_closure (guard 100 Hwf) size in
    NFA.mk size
    (statelabelmap_set_to_fun (StateLabelMap.map (set_closure eps) delta))
    (eps initial)
    (StateSet.singleton final)
    max_label.
Arguments eNFA_to_NFA : clear implicits.

(** specifiaction the generic transitive closure algorithm *)

Definition step f: relation state := fun i j => StateSet.mem j (f i) = true.
Definition steps f: relation state := clos_refl_trans_1n _ (step f).

Definition valid f i p := forall j, StateSet.In j p <-> steps f i j.
Definition approx f acc := forall i p, StateMap.MapsTo i p acc -> valid f i p.

Lemma add_valid: forall acc f i p B, valid f i p /\ approx f acc /\ B ->
  StateMap.MapsTo i p (StateMap.add i p acc) /\ approx f (StateMap.add i p acc) /\ B.
Proof.
  intros. unfold approx.
   StateMapProps.map_iff. intuition.
   revert H1. StateMapProps.map_iff. intuition; subst; trivial.
Qed.

Ltac destruct_fold_pair H :=
  match type of H with
    context [stateset_fold ?x ?f ?acc] =>
    case_eq (stateset_fold x f acc);
    let acc' := fresh "acc" in
    let p' := fresh "p" in
    let H' := fresh "H" in
      intros acc' p' H';
      rewrite H' in H; simpl in H;
      injection H; intros; subst; clear H
  end.

Import Common.                  (* to get Common.apply *)

Lemma rt_closure_aux_spec: forall f (Hwf: terminates f) i acc acc' p,
  approx f acc -> rt_closure_aux Hwf i acc = (acc',p) ->
  StateMap.MapsTo i p acc' /\ approx f acc' /\ (forall j, StateMap.In j acc -> StateMap.In j acc').
Proof.
  intros f Hwf.
  refine (Fix_induction Hwf (P:=fun i (g: statemap stateset -> _) =>
    forall acc acc' p, approx f acc -> g acc = (acc',p) ->
      StateMap.MapsTo i p acc' /\ approx f acc' /\ (forall j, StateMap.In j acc -> StateMap.In j acc')) _).

  (** interesting part *)
  intros i G IH acc acc' p Hacc Hcall.

  StateMapProps.find_analyse.
   (* 1 memoised case *)
   dependent destruction Hcall.
   auto.

   (* 2 non memoised case *)
   clear H. simpl in Hcall. destruct_fold_pair Hcall. apply add_valid.

   match type of H with stateset_fold _ ?f _ = _ => set (g:=f) in * end.
   pose (stateset_fold_rec_bis
     (f:=g)
     (P:=fun x' accy =>
       let '(acc',y) := accy in
         approx f acc' /\
         (forall j, StateSet.In j y -> steps f i j) /\
         (forall j, steps f i j -> StateSet.In j y
           \/ exists2 k, StateSet.In k (StateSet.diff (f i) x') & steps f k j) /\
         (forall j, StateMap.In j acc -> StateMap.In j acc')
     )
     (i:=(acc,StateSet.singleton i))
     (p:=f i)
   ) as H'.
   rewrite H in H'. clear H.
   apply apply in H'. apply apply in H'. apply apply in H'.

    intuition. intro j. intuition. destruct (H0 _ H2) as [? | [k ? ?]];  trivial.
    clear - H4. revert H4. StateSetProps.set_iff. tauto.
    StateMapProps.map_iff. auto.

    (* 2.1 internal inductive case *)
    clear - IH.
    intros j [acc' p] y Hij Hnjy IHx. simpl. intuition.
    unfold g in *; clear g.
    case_eq (G j Hij acc'). intros acc'' pj Heq. apply IH in Heq; trivial; clear IH.
    intuition.
     revert H4. StateSetProps.set_iff. intros [H4|H4].
      apply H5 in H2. apply H2 in H4. clear - Hij H4. econstructor 2; eassumption.
      apply H1 in H4. trivial.
     destruct (H0 _ H4) as [H8 | [k H9 H10]].
      left. clear - H8. StateSetProps.set_iff. auto.
      destruct (eq_num_dec k j).
       subst. left. apply H5 in H2. apply H2 in H10. revert H10. clear. StateSetProps.set_iff. auto.
       right. exists k; trivial. revert H9. clear -n. StateSetProps.set_iff. intuition.

    (* 2.2 external base case *)
    clear - Hacc.
    intuition.
     revert H. StateSetProps.set_iff. intro H. subst. constructor 1.
     inversion_clear H.
      left. auto with set.
      right. exists y; trivial. StateSetProps.set_iff; auto with set.

    (* remaining compatibility lemma *)
    clear. intros u v [acc' y] Hu H. intuition.
    destruct (H1 j H2) as [?|[k ? ?]]; auto.
    right. exists k; auto. rewrite <- Hu. trivial.
Qed.

Lemma rt_closure_aux'_spec: forall f Hwf n acc,
  approx f acc ->
  approx f (@rt_closure_aux' f Hwf n acc)
  /\ forall i, StateMap.In i acc \/ i=n -> StateMap.In i (@rt_closure_aux' f Hwf n acc).
Proof.
  intros. unfold rt_closure_aux'.
  case_eq (rt_closure_aux Hwf n acc); intros acc' p H'.
  apply rt_closure_aux_spec in H'; auto.
  split.
   apply H'.
   intros i [Hi| ->]; simpl.
    apply H', Hi.
    exists p. apply H'.
Qed.

Lemma rt_closure_prespec: forall f Hwf size acc,
  approx f acc ->
  approx f (fold_states (@rt_closure_aux' f Hwf) size acc)
  /\ forall i, below i size \/ StateMap.In i acc ->
    StateMap.In i (fold_states (rt_closure_aux' Hwf) size acc).
Proof.
  induction size using Pind; intros acc H.
   split. apply H. intros i [Hi|H']. destruct i; discriminate Hi. apply H'.
   specialize (IHsize (rt_closure_aux' Hwf size acc)).
   pose proof (rt_closure_aux'_spec Hwf size H) as [Happrox Hin].
   apply apply in IHsize as [IHapprox IHin]; auto.
   unfold fold_states. rewrite Prect_succ. split; trivial.
   intros i Hi. destruct (eq_num_dec i size).
    subst. auto.
    apply IHin. destruct Hi as [Hi|Hi]; auto.
    left. clear -Hi n. num_lia.
Qed.

Theorem rt_closure_spec: forall f Hwf size i, below i size ->
  forall j, steps f i j <-> StateSet.In j (@rt_closure f Hwf size i).
Proof.
  intros f Hwf size i Hi j.
  pose proof (rt_closure_prespec Hwf size (acc:=StateMap.empty _)) as H.
  apply apply in H. destruct H as [Happrox Hin].
  eapply apply in Hin; eauto. destruct Hin as [p Hip].
  specialize (Happrox _ _ Hip). unfold valid in Happrox. rewrite <- Happrox.
  apply -> StateMapProps.find_mapsto_iff in Hip.
  unfold rt_closure, statemap_set_to_fun. rewrite Hip.
  reflexivity.
  clear. intros j acc. StateMapProps.map_iff. tauto.
Qed.

Section algebraic_lemmas.

  Context `{KA: KleeneAlgebra}.

  Lemma algebraic_correctness: forall A B C (j' j n m': X B B) (u u': X A B) (v v': X B C),
    j'==j# -> m'==n*j' -> u'==u*j' -> v'==v -> u*(j+n)#*v == u'*m'#*v'.
  Proof.
    intros.
    rewrite H0, H1, H2, H.
    rewrite star_distr. semiring_reflexivity.
  Qed.

  Lemma algebraic_rt_closure: forall A (j' j : X A A), 1 <== j' -> j' * j' <== j' -> j<==j' -> j# <== j'.
  Proof.
    intros A j' j Hr Ht H.
    transitivity (j'#); auto with algebra.
     apply star_destruct_left_one. semiring_normalize. rewrite Ht, Hr. auto with algebra.
  Qed.

  Lemma xif_bool_incr: forall A B b c (x : X A B), (b=true -> c=true) -> xif b x 0 <== xif c x 0.
  Proof.
    intros. destruct b.
     rewrite H; auto.
     simpl. trivial with algebra.
  Qed.

End algebraic_lemmas.

Notation ns := nat_of_state.
Notation sn := state_of_nat.

Lemma rt_closure_star: forall f Hwf size, (forall i, below i size -> setbelow (f i) size) ->
  (mx_bool tt (ns size) (ns size) (fun i j => StateSet.mem (sn j) (f (sn i)))) #
  ==
  (mx_bool tt (ns size) (ns size) (fun i j => StateSet.mem (sn j) (@rt_closure f Hwf size (sn i)))).
Proof.
  intros f Hwf size Hbounded.
  apply leq_antisym.
   apply algebraic_rt_closure; mx_intros i j Hi Hj; simpl; fold_regex; fold_leq.
    nat_analyse; fold_regex; auto with algebra.
    subst. type_view StateSet.mem; auto with algebra.
    elim n. rewrite <- rt_closure_spec by num_lia. constructor 1.

    apply sum_leq. intros k _ Hk.
    type_view StateSet.mem. 2: simpl; fold_regex; semiring_reflexivity.
    type_view StateSet.mem. 2: simpl; fold_regex; semiring_reflexivity.
    type_view StateSet.mem. simpl; fold_regex; semiring_reflexivity.
    elim n.
     rewrite <- rt_closure_spec by num_lia.
     apply trans_rt1n. constructor 3 with (sn k);
      apply rt1n_trans; apply <- rt_closure_spec; eauto; unfold below; num_lia.

    type_view StateSet.mem. 2: simpl; fold_regex; semiring_reflexivity.
    type_view StateSet.mem. simpl; fold_regex; semiring_reflexivity.
    elim n.
     rewrite <- rt_closure_spec by num_lia.
     constructor 2 with (sn j). apply StateSet.mem_1 in i0. assumption. constructor 1.

   mx_intros i j Hi Hj. simpl. fold_regex; fold_leq.
   set (m := mx_bool Datatypes.tt (ns size) (ns size) (fun i j => StateSet.mem (sn j) (f (sn i)))).
   type_view StateSet.mem; auto with algebra. rename i0 into Hij.
   rewrite <- rt_closure_spec in Hij by num_lia.
   revert Hi Hj. rewrite <- (id_nat i), <- (id_nat j). revert Hij.
   generalize (sn j) as j'. generalize (sn i) as i'. clear - Hbounded.
   intros i j ij. induction ij; intros Hi Hj.
    transitivity (!(1+m*m#) (ns x) (ns x)).
    simpl; fold_regex; fold_leq. nat_analyse. auto with algebra.
    apply equal_leq. refine (star_make_right m _ _ Hi Hj).

    transitivity (!(1+m*m#) (ns x) (ns z)).
    simpl; fold_regex; fold_leq. rewrite <- plus_make_right.
    assert (ns y < ns size).
     rewrite <- lt_nat_spec in Hi. apply Hbounded in Hi.
     rewrite <- lt_nat_spec. apply Hi. apply StateSet.mem_2, H.
    apply leq_sum. exists (ns y); repeat split; auto with arith.
    rewrite 2id_num. rewrite H. rewrite <- IHij by assumption. unfold xif. semiring_reflexivity.
    apply equal_leq. refine (star_make_right m _ _ Hi Hj).
Qed.

Local Opaque star dot plus zero one equal leq guard .

Lemma mem_set_closure: forall f i p,
  StateSet.mem i (set_closure f p) = StateSet.exists_ (fun j => StateSet.mem i (f j)) p.
Proof.
  intros f i p. unfold set_closure.
  rewrite StateSetProps.exists_fold by (repeat intro; psubst; reflexivity).

  (* Generalisation preinduction *)
  assert (StateSet.mem i StateSet.empty = false) by auto with set.
  revert H;  generalize StateSet.empty;  generalize false.

  change stateset with NumSet.t in *. (* BUG d'induction *)
  induction p using StateSetProps.set_induction_below; intros b acc Hbacc.

     rewrite 2 StateSetProps.fold_empty; (repeat intro; num_prop; psubst; try reflexivity || ti_auto).
     rewrite H1; reflexivity.

     (* asserts used to avoid non instantiated variables *)
     assert (SetoidList.compat_op eq StateSet.Equal (fun i => StateSet.union (f i))).
        repeat intro. rewrite H3. psubst. reflexivity.
     assert (SetoidList.compat_op eq (@eq bool) (fun x acc => StateSet.mem i (f x) || acc)).
        repeat intro. psubst. reflexivity.

     rewrite (StateSetProps.fold_equal _ H2 _ H1).
     rewrite (StateSetProps.fold_equal _ H3 _ H1).

     setoid_rewrite StateSetProps.fold_add_below;
       try solve [(repeat intro; num_prop;  subst; try reflexivity || ti_auto)].
     rewrite (IHp1 (StateSet.mem i (f x) || b)); [reflexivity|].
     rewrite <- Hbacc.
     rewrite bool_prop_iff. bool_connectors. rewrite <- 3NumSetProps.mem_iff. StateSetProps.setdec.
     repeat intro; num_prop; psubst; rewrite H5; reflexivity.
Qed.

Lemma delta_bounded: forall A, eNFA.bounded A ->
  forall i a n x, StateLabelMap.MapsTo (i, a) x (eNFA.deltamap A) -> StateSet.In n x -> below n (eNFA.size A).
Proof.
  intros [size eps delta initial final max_label] Hb i a n x Hx Hnx.
  simpl. apply (@eNFA.bounded_delta _ Hb a i).
  unfold eNFA.delta in *. simpl in *. apply StateLabelMapProps.find_mapsto_iff in Hx. rewrite Hx. apply Hnx.
Qed.

Theorem correct: forall A HA, eNFA.bounded A -> NFA.eval (eNFA_to_NFA A HA) == eNFA.eval A.
Proof.
  intros [size eps delta initial final max_label] Hwf Hb.
  apply mx_to_scal_compat. simpl. symmetry.
  apply algebraic_correctness with
    (mx_bool tt (ns size) (ns size) (fun i j => StateSet.mem (sn j)
      (rt_closure (guard 100 Hwf) size (sn i)))).

  (* j' = j# *)
  symmetry. apply rt_closure_star.
  intros. apply Hb.

  Local Transparent dot plus zero one equal.

  (* m' = n*j' *)
  mx_intros i j Hi Hj. simpl. unfold labelling. fold_regex.
  setoid_rewrite sum_distr_left.
  rewrite sum_inversion.
  apply sum_compat. intros a Ha. simpl; fold_regex.
  unfold eNFA.delta, eNFA.deltamap, statelabelmap_set_to_fun.
  setoid_rewrite dot_xif_zero.
  setoid_rewrite dot_neutral_right.
  rewrite StateLabelMapProps.map_o.
  unfold numota_of_nat.
  StateLabelMapProps.find_analyse; simpl; fold_regex.
  rewrite mem_set_closure.
  match goal with |- context [StateSet.exists_ ?f ?p] => set (e:=StateSet.exists_ f p) end.
  apply leq_antisym.
   case_eq e; intros Hj'; trivial with algebra.
   apply leq_sum.
    subst e; apply <- StateSetProps.exists_iff in Hj'. destruct Hj' as [n [Hnx Hjn]].
    exists (ns n); repeat split; auto with arith.
    simpl. rewrite <- lt_nat_spec. apply (delta_bounded Hb H Hnx).
    apply StateSet.mem_1 in Hnx. rewrite 2id_num. rewrite Hnx.
    unfold statesetelt_of_nat in Hjn. rewrite Hjn. reflexivity.
    repeat intro. psubst. reflexivity.
   apply sum_leq. intros n _ Hn.
    apply xif_bool_incr. bool_connectors. intros [Hnx Hjn].
    apply -> StateSetProps.exists_iff. 2: repeat intro;  psubst; reflexivity.
    exists (sn n); split; assumption.
  symmetry. rapply sum_fun_zero.

  (* u' = u*j' *)
  mx_intros i j Hi Hj. simpl; fold_regex.
  rewrite (sum_collapse (n:=ns initial)). simpl. bool_simpl. simpl. fold_regex. unfold statesetelt_of_nat.
  auto with algebra.
  apply -> lt_nat_spec. apply Hb.
  simpl. intros k Hk. nat_analyse. simpl. fold_regex. auto with algebra.

  (* v' = v *)
  mx_intros i j Hi Hj. simpl. fold_regex. apply xif_compat; trivial.
  bool_simpl. rewrite bool_prop_iff. num_prop. nat_prop. num_lia.
Qed.

Lemma rt_closure_bounded: forall f Hwf size,
  (forall i, below i size -> setbelow (f i) size) ->
   forall i, below i size -> setbelow (@rt_closure f Hwf size i) size.
Proof.
  intros f Hwf size H i Hi j Hj.
  rewrite <- rt_closure_spec in Hj by trivial.
  revert Hi. induction Hj; intro Hi; trivial.
  apply IHHj.
  apply (H x Hi). apply StateSet.mem_2, H0.
Qed.

Lemma bounded: forall A HA, eNFA.bounded A -> NFA.bounded (eNFA_to_NFA A HA).
Proof.
  intros [size eps delta initial final max_label] Hwf Hb. unfold eNFA_to_NFA. constructor; simpl.
   (* delta *)
   intros a i j Hj. unfold statelabelmap_set_to_fun in Hj.
   rewrite StateLabelMapProps.map_o in Hj.
   StateLabelMapProps.find_analyse; simpl in Hj. 2: StateSetProps.setdec.
    apply StateSet.mem_1 in Hj. rewrite mem_set_closure in Hj.
    rewrite <- StateSetProps.exists_iff in Hj by (repeat intro; psubst; reflexivity).
    destruct Hj as [n [Hnx Hjn]].
    eapply rt_closure_bounded. 3: apply StateSet.mem_2, Hjn. intros. apply Hb.
    apply (delta_bounded Hb H Hnx).
   (* initiaux *)
   intros i Hi. eapply rt_closure_bounded. 3: apply Hi. 2: apply Hb.
   clear i Hi. intros i Hi. apply Hb.
   (* finaux *)
   intros i. StateSetProps.set_iff. intro Hi. psubst. apply Hb.
Qed.

Lemma preserve_max_label: forall A HA, NFA.max_label (@eNFA_to_NFA A HA) = eNFA.max_label A.
Proof.
  intros A HA. destruct A. reflexivity.
Qed.


(* * Summary File *)

From FOL Require Import FullSyntax.
From Undecidability.Synthetic Require Import Definitions Undecidability.
From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ReducibilityFacts.
From Undecidability.Synthetic Require Import ListEnumerabilityFacts MoreEnumerabilityFacts.
From Undecidability.Shared Require Import Dec.
From Undecidability Require Import Synthetic.Undecidability.
From Equations Require Import Equations.
From FOL.Utils Require Import MPFacts.
Require Import ConstructiveEpsilon.
Require Import List.
Import ListNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Definition computational_explosion := enumerable (complement SBTM.SBTM_HALT).

(* Check that we anchor to the right undecidable problem *)
Definition computational_explosion_is_sane X (p : X -> Prop) : (undecidable p) = (decidable p -> computational_explosion) := eq_refl.

(* ** Section 3 *)

(* *** Decision problems on first-order axiomatisations *)
#[local]
Existing Instance falsity_on.

Local Hint Constructors prv : core.

Notation "S <<= S'" := (forall phi, S phi -> S' phi) (at level 10).
Notation "I ⊨= phi" := (forall rho, sat I rho phi) (at level 20).
Notation "I ⊨=T T" := (forall psi, T psi -> I ⊨= psi) (at level 20).
Notation "T ⊨T phi" := (forall D (I : interp D) rho, (forall psi, T psi -> rho ⊨ psi) -> rho ⊨ phi) (at level 55).

Section FixSignature.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Implicit Type T : form -> Prop.

  Definition tprv_class T phi := T ⊢TC phi.
  Definition tprv_intu T phi := T ⊢TI phi.
  Definition tvalid T phi := T ⊨T phi.

  (* *** Definition 6 : reductions to axiomatisations combine Tarski semantics and intuitionistic ND *)

  Definition treduction X (f : X -> form) (P : X -> Prop) T :=
    reduction f P (tvalid T) /\ reduction f P (tprv_intu T).

  (* *** Fact 7 : if a non-trivial problem reduces to T, then T is consistent *)

  Fact reduction_consistency {p : peirce} X (f : X -> form) (P : X -> Prop) T :
    reduction f P (tprv T) -> (exists x, ~ P x) -> ~ T ⊢T ⊥.
  Proof.
    intros Hf [x Hx] [A[H1 H2]]. apply Hx, Hf.
    exists A. split; trivial. now apply Exp.
  Qed.

  Section Axiomatisations.

    Context {enum_funcs : enumerable__T Σ_funcs} {eqdec_funcs : eq_dec syms}.
    Context {enum_preds : enumerable__T Σ_preds} {eqdec_preds : eq_dec preds}.

    (* Assuming a discrete and enumerable signature, the type of formulas is discrete and enumerable *)

    Instance EqDec_funcs : EqDec Σ_funcs.
    Proof.
      intros x y. apply eqdec_funcs.
    Qed.

    Instance EqDec_preds : EqDec Σ_preds.
    Proof.
      intros x y. apply eqdec_preds.
    Qed.

    Lemma form_discrete :
      discrete form.
    Proof.
      apply discrete_iff. constructor. apply dec_form; trivial.
      all: intros ? ?; unfold dec; decide equality.
    Qed.

    Lemma form_enumerable :
      enumerable__T form.
    Proof.
      eapply enumT_form'; trivial. apply enumT_binop. apply enumT_quantop.
    Qed.

    (* For any (enumerable) axiomatisation, the deductive consequences are enumerable *)

    Variable T : form -> Prop.
    Hypothesis enum_T : enumerable T.

    Lemma tprv_enumerable {p : peirce} :
      enumerable (fun phi => tprv T phi).
    Proof.
      apply enumerable_enum.
      apply enumerable_enum in enum_T as [L HL].
      apply enum_enumT in enum_funcs as [L1 HL1].
      apply enum_enumT in enum_preds as [L2 HL2].
      exists (@L_tded _ _ L1 HL1 L2 HL2 _ _ p falsity_on (cumul L)).
      now apply enum_tprv.
    Qed.

    (* *** Fact 9 : consistent complete theories are decidable for closed formulas *)

    Definition stripneg `{falsity_flag} (phi : form) : option form :=
      match phi with
      | bin Impl phi ⊥ => Some phi
      | _ => None
      end.

    Instance eq_dec_ff :
      eq_dec falsity_flag.
    Proof.
      intros ff ff'. unfold dec. decide equality.
    Qed.

    Derive Signature for form.

    Lemma stripneg_spec {ff : falsity_flag} {phi psi} :
      stripneg phi = Some psi -> phi = ¬ psi.
    Proof.
      depelim phi; cbn; try destruct b0; try discriminate.
      - inversion H. apply @inj_right_pair in H1 as ->; eauto. 2: intros ??; unfold dec; decide equality. cbn. discriminate.
      - depelim phi2; cbn; try destruct b0; try discriminate.
        inversion H. apply @inj_right_pair in H1 as ->; eauto. 2: intros ??; unfold dec; decide equality.  congruence.
    Qed.

    Lemma enumerable_equiv X (P Q : X -> Prop) :
      (forall x, P x <-> Q x) -> enumerable P -> enumerable Q.
    Proof.
      intros H [f Hf]. exists f. intros x. rewrite <- H. apply Hf.
    Qed.

    Definition complete :=
      forall phi, bounded 0 phi -> T ⊢TC phi \/ T ⊢TC ¬ phi.

    Fact complete_decidable :
      (~ T ⊢TC ⊥) -> complete -> decidable (fun phi => bounded 0 phi /\ T ⊢TC phi).
    Proof.
      intros H1 H2.
      assert (H : forall phi, bounded 0 phi -> ~ T ⊢TC phi <-> T ⊢TC ¬ phi).
      - intros phi HP. split; intros H.
        + destruct (H2 phi) as [H3|H3]; tauto.
        + intros [B[HB1 HB2]]. destruct H as [C[HC1 HC2]].
          apply H1. exists (B ++ C). split.
          * intros psi. rewrite in_app_iff. intuition.
          * eapply IE; eapply Weak; eauto. 1:apply incl_appr. 2:apply incl_appl. all:apply incl_refl.
      - apply weakPost; try apply form_discrete.
        + intros phi. destruct (bounded_dec phi 0) as [Hb|Hb].
          destruct (H2 phi Hb) as [Hp|Hp % H]. all: tauto.
        + apply enumerable_conj; try apply form_discrete.
          * apply dec_count_enum; try apply form_enumerable.
            apply decidable_iff. constructor. intros phi. apply bounded_dec.
          * apply tprv_enumerable.
        + apply enumerable_equiv with (fun phi => ~ bounded 0 phi \/ T ⊢TC ¬ phi).
          { intros phi. destruct (bounded_dec phi 0); intuition. }
          apply enumerable_disj; try apply dec_count_enum'; try apply form_enumerable.
          { apply decidable_iff. constructor. intros phi. apply bounded_dec. }
          destruct (tprv_enumerable (p:=class)) as [f Hf].
          exists (fun n => match f n with Some phi => stripneg phi | _ => None end).
          intros phi. rewrite (Hf (¬ phi)). split; intros [n Hn]; exists n; try now rewrite Hn.
          destruct (f n) as [psi|]; try discriminate. now rewrite (stripneg_spec Hn).
    Qed.

    (* *** Consequence : problems reducing to complete theories are decidable *)

    Fact complete_reduction X (P : X -> Prop) (f : X -> form) :
      (~ T ⊢TC ⊥) -> complete -> reduction f P (tprv_class T) -> (forall x, bounded 0 (f x)) -> decidable P.
    Proof.
      intros H1 H2 H3 H4. apply complete_decidable in H1; trivial.
      apply decidable_iff in H1 as [H1]. apply decidable_iff. constructor.
      intros x. destruct (H1 (f x)) as [H|H].
      - left. apply H3, H.
      - right. contradict H. split; try now apply H4. apply H3, H.
    Qed.

  End Axiomatisations.

  (* *** Theorem 10 : undecidability transports to extended axiomatisations satisfied by standard models *)

  Section Reduction.

    Variable T : form -> Prop.

    Variable X : Type.
    Variable P : X -> Prop.
    Variable f : X -> form.

    Variable standard : forall D, interp D -> Prop.

    Hypothesis hyp1 : forall x, P x -> T ⊨T (f x).
    Hypothesis hyp2 : forall D (I : interp D) x, standard I -> I ⊨=T T -> I ⊨= (f x) -> P x.
    Hypothesis hyp3 : forall {p : peirce} x, P x -> T ⊢T (f x).

    Lemma WeakT {p : peirce} (S S' : form -> Prop) phi :
      S ⊢T phi -> S <<= S' -> S' ⊢T phi.
    Proof.
      intros [A[H1 H2]] H. exists A. split; auto.
    Qed.

    Theorem reduction_theorem (S : form -> Prop) :
      T <<= S -> (exists D (I : interp D), standard I /\ I ⊨=T S) -> treduction f P S.
    Proof.
      intros HS (D & I & [std MT]). repeat split; intros H.
      - intros D' I' rho H'. apply hyp1; auto.
      - apply (hyp2 std); auto.
      - apply WeakT with T; trivial. now apply hyp3.
      - apply (hyp2 std); auto. intros rho. apply (tsoundness H); auto.
    Qed.

    (* *** Theorem 10 : variant for classical deduction, using LEM *)

    Definition LEM := forall P, P \/ ~ P.

    Theorem reduction_theorem_class (S : form -> Prop) :
      LEM -> T <<= S -> (exists D I, @standard D I /\ I ⊨=T S) -> reduction f P (tprv_class S).
    Proof.
      intros lem HS (D & I & [std MT]). split; intros H.
      - apply WeakT with T; trivial. now apply hyp3.
      - apply (hyp2 std); auto. intros rho. apply (tsoundness_class lem H); auto.
    Qed.

  End Reduction.

  (* *** Fact 11 : reductions from finite axiomatisations to the Entscheidungsproblem *)

  Definition list_theory (A : list form) :=
    fun phi => In phi A.

  Lemma red_finite_valid A :
    tvalid (list_theory A) ⪯ valid.
  Proof.
    exists (impl A). intros phi. unfold valid. setoid_rewrite impl_sat. firstorder.
  Qed.

  Lemma red_finite_prv {p : peirce} A :
    tprv (list_theory A) ⪯ (prv nil).
  Proof.
    exists (impl A). intros phi. setoid_rewrite <- impl_prv. rewrite app_nil_r. split; intros H.
    - destruct H as [B[H1 H2]]. apply (Weak (B:=A)) in H2; auto.
      apply (Weak H2). unfold incl. apply in_rev.
    - exists A. split; trivial. apply (Weak H). unfold incl. apply in_rev.
  Qed.

  (* *** Fact 12 : indirect reductions between axiomatisations *)

  Lemma red_prv_prv {p : peirce} A T :
    T <<= (prv A) -> prv A ⪯ tprv T.
  Proof.
    intros Ded.
    exists (fun phi => A ==> phi). intros phi; split; intros H.
    - exists nil. split; [auto|]. 1: intros a []. setoid_rewrite <- impl_prv.
      rewrite app_nil_r.
      apply (Weak H). unfold incl. apply in_rev.
    - destruct H as [B [H1 H2 % impl_prv]].
      apply (prv_cut H2). intros psi [H|H] % in_app_iff.
      + apply Ctx. now apply in_rev.
      + now apply Ded, H1.
  Qed.

  Lemma red_prv_valid A T :
    T <<= (prv (p:=intu) A) -> tvalid (list_theory A) ⪯ tvalid T.
  Proof.
    intros Ded.
    exists (fun phi => A ==> phi). intros phi; split; intros H D I rho HI.
    - apply impl_sat. apply H.
    - specialize (H D I rho). setoid_rewrite impl_sat in H. apply H.
      + intros psi HP. apply Ded in HP. apply soundness in HP. apply HP. apply HI.
      + apply HI.
  Qed.

  Lemma red_sub_prv {p : peirce} A T :
    T <<= (list_theory A) -> prv A ⪯ tprv T.
  Proof.
    intros Sub. apply red_prv_prv.
    intros phi H. now apply Ctx, Sub.
  Qed.

  Lemma red_sub_valid {p : peirce} A T :
    T <<= (list_theory A) -> tvalid (list_theory A) ⪯ tvalid T.
  Proof.
    intros Sub. apply red_prv_valid.
    intros phi H. now apply Ctx, Sub.
  Qed.

  Lemma red_union_prv' {p : peirce} A T :
    reduction (fun phi => A ==> phi) (tprv (fun phi => T phi \/ In phi A)) (tprv T).
  Proof.
    intros phi; split; intros [C [H1 H2]].
    - assert (exists C1 C2, incl C1 A /\ list_theory C2 <<= T /\ incl C (C1 ++ C2)).
      + clear H2. induction C.
        * exists nil, nil. cbn. repeat split; auto. all: intros x [].
        * destruct IHC as (C1 & C2 & H2 & H3 & H4).
          -- intros psi HP. apply H1. now right.
          -- destruct (H1 a) as [H|H]; try now left.
             ++ exists C1, (a::C2). repeat split; trivial. firstorder congruence.
                intros psi [->|HP]; auto. 1: { apply in_or_app, or_intror; now left. } apply H4 in HP as [HP|HP] % in_app_iff; auto. 1: now apply in_or_app, or_introl. 1:now apply in_or_app, or_intror, or_intror.
             ++ exists (a::C1), C2. repeat split; firstorder congruence.
      + destruct H as (C1 & C2 & H3 & H4 & H5).
        exists C2. split; try apply H4. apply impl_prv. apply (Weak H2).
        intros psi [H|H] % H5 % in_app_iff; auto. apply in_app_iff. left. apply -> in_rev. now apply H3.
        now apply in_or_app, or_intror.
    - exists (rev A ++ C). split; try now apply impl_prv.
      intros psi [H|H] % in_app_iff; auto. right. now apply in_rev.
  Qed.

  Lemma red_union_prv {p : peirce} A T :
    tprv (fun phi => T phi \/ In phi A) ⪯ tprv T.
  Proof.
    exists (fun phi => A ==> phi). apply red_union_prv'.
  Qed.

  Lemma red_union_valid A T :
    tvalid (fun phi => T phi \/ In phi A) ⪯ tvalid T.
  Proof.
    exists (fun phi => A ==> phi). intros phi; split; intros H D I rho HI.
    - apply impl_sat. intros HA. apply H. firstorder.
    - specialize (H D I rho). setoid_rewrite impl_sat in H. apply H; firstorder.
  Qed.

End FixSignature.

(* ** Main results *)

(* *** Theorem 26 : H10 reduces to Q', Q, and PA *)

From FOL Require Import Arithmetics.
From Undecidability.FOL.Reductions Require Import H10p_to_FA.
From Undecidability.H10 Require Import H10p H10p_undec.

#[local]
Existing Instance PA_funcs_signature.
#[local]
Existing Instance PA_preds_signature.

(* We first show the three hypotheses regarding Q' *)

Definition Q' := list_theory FAeq.

Lemma PA_undec1 E :
  H10p E -> Q' ⊨T embed E.
Proof.
  intros HE D M HM rho. apply H10p_to_FA_sat; auto.
Qed.

(* A model is standard if it is isomorphic to nat *)

Lemma PA_undec2 D (M : interp D) E :
  standard D M -> M ⊨=T Q' -> M ⊨= embed E -> H10p E.
Proof.
  intros H1 H2 H3. apply standard_embed with (fun n => iO); auto.
Qed.

Lemma PA_undec3 (p : peirce) E :
  H10p E -> Q' ⊢T embed E.
Proof.
  intros H. exists FAeq. split; auto. now apply H10p_to_FA_prv'.
Qed.

(* Then the reductions to Q', Q, and PA all follow by reduction_theorem *)

Notation "P ⪯T T" := (exists f, treduction f P T) (at level 55).

Theorem undec_Q' :
  H10p ⪯T Q'.
Proof.
  exists embed. apply (reduction_theorem PA_undec1 PA_undec2 PA_undec3).
  - auto.
  - exists nat, interp_nat. split; try apply nat_standard.
    eauto using nat_is_FA_model.
Qed.

Theorem undec_Q :
  H10p ⪯T list_theory Qeq.
Proof.
  exists embed. apply (reduction_theorem PA_undec1 PA_undec2 PA_undec3).
  - firstorder.
  - exists nat, interp_nat. split; try apply nat_standard.
    eauto using nat_is_Q_model.
Qed.

Theorem undec_PA :
  H10p ⪯T PAeq.
Proof.
  exists embed. apply (reduction_theorem PA_undec1 PA_undec2 PA_undec3).
  - eauto using PAeq.
  - exists nat, interp_nat. split; try apply nat_standard.
    eauto using nat_is_PAeq_model.
Qed.

(* *** Theorem 27 : all extensions of Q' satisfied by the standard model are incompletene, using LEM *)

(* We first need to show the PA signature discrete and enumerable *)

#[global]
Instance eqdec_PA_syms :
  eq_dec syms.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

#[global]
Instance eqdec_PA_preds :
  eq_dec preds.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

#[global]
Definition enum_PA_syms :
  enumerable__T syms.
Proof.
  apply enum_enumT. exists (fun _ => [Zero; Succ; Plus; Mult]).
  intros []; exists 0; auto. all: cbv; eauto.
Qed.

Definition enum_PA_preds :
  enumerable__T preds.
Proof.
  apply enum_enumT. exists (fun _ => [Eq]).
  intros []; exists 0; auto. all: cbv; eauto.
Qed.

Lemma PAeq_enum :
  enumerable PAeq.
Proof.
  destruct enumT_form' as [f Hf].
  - apply enum_PA_syms.
  - apply enum_PA_preds.
  - apply enumT_binop.
  - apply enumT_quantop.
  - exists (fun n => match n with 0 => Some ax_refl | 1 => Some ax_sym | 2 => Some ax_trans
                     | 3 => Some ax_succ_congr | 4 => Some ax_add_congr
                     | 5 => Some ax_mult_congr | 6 => Some ax_add_zero
                     | 7 => Some ax_add_rec | 8 => Some ax_mult_zero | 9 => Some ax_mult_rec
                     | 10 => Some ax_zero_succ | 11 => Some ax_succ_inj
                     | S (S (S (S (S (S (S (S (S (S (S (S n))))))))))) =>
                         match f n with Some phi => Some (ax_induction phi) | _ => None end end).
    intros phi. split.
    + intros [| | |psi].
      * destruct H as [<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]]]].
        now exists 0. now exists 1. now exists 2. now exists 3. now exists 4. now exists 5. now exists 6. now exists 7. now exists 8. now exists 9.
      * now exists 10.
      * now exists 11.
      * destruct (Hf psi) as [n Hn]. exists (12 + n). cbn. now rewrite Hn.
    + intros [[|[|[|[|[|[|[|[|[|[|[|[|]]]]]]]]]]]] [=]]; subst; eauto using PAeq.
      all: try (apply PAeq_FA; cbn; tauto).
      destruct (f n); try congruence. injection H0. intros <-. apply PAeq_induction.
Qed.

Theorem incompleteness_PA (T : form -> Prop) :
  LEM -> Q' <<= T -> enumerable T -> complete T -> interp_nat ⊨=T T -> computational_explosion.
Proof.
  intros lem HFA HE HC HT. apply H10p_undec.
  apply (@complete_reduction _ _ enum_PA_syms _ enum_PA_preds _ T HE) with embed.
  - intros H. apply (@tsoundness_class _ _ lem _ T ⊥ H nat interp_nat (fun n => 0)). firstorder.
  - apply HC.
  - eapply (reduction_theorem_class PA_undec2 PA_undec3); trivial.
    exists nat, interp_nat. split; auto. apply nat_standard.
  - apply embed_is_closed.
Qed.

(* *** Fact 28 : all axiomatisations satisfied by the standard model are undecidable *)

Fact undec_standard_prv (T : form -> Prop) :
  interp_nat ⊨=T T -> H10p ⪯ @tprv _ _ _ intu T.
Proof.
  intros HT. eapply reduces_transitive; try apply (red_union_prv FAeq).
  exists embed. apply (reduction_theorem PA_undec1 PA_undec2 PA_undec3).
  - auto.
  - exists nat, interp_nat. split; try apply nat_standard.
    intros Phi [H|H]; try now apply HT.
    eauto using nat_is_FA_model.
Qed.

Fact undec_standard_valid (T : form -> Prop) :
  interp_nat ⊨=T T -> H10p ⪯ tvalid T.
Proof.
  intros HT. eapply reduces_transitive; try apply (red_union_valid FAeq).
  exists embed. apply (reduction_theorem PA_undec1 PA_undec2 PA_undec3).
  - auto.
  - exists nat, interp_nat. split; try apply nat_standard.
    intros Phi [H|H]; try now apply HT.
    eauto using nat_is_FA_model.
Qed.

(* *** Theorem 43 : PCP reduces to Z', Z, and ZF, assuming standard models *)

From Undecidability.FOL.Reductions Require Import PCPb_to_ZFeq PCPb_to_ZF PCPb_to_ZFD.
From Undecidability.FOL.Sets Require Import Models.Aczel_CE Models.ZF_model ZF.
From Undecidability.PCP Require Import PCP PCP_undec.

(* We first show the three hypotheses regarding Z' *)

#[local]
Existing Instance ZF_func_sig.
#[local]
Existing Instance ZF_pred_sig.

Definition Z' := list_theory ZFeq'.

Lemma ZF_undec1 B :
  PCPb B -> Z' ⊨T solvable B.
Proof.
  intros HE D M HM rho. apply (PCP_ZFD (p:=intu)) in HE.
  apply (soundness HE). auto.
Qed.

(* A model is standard if all k ∈ om correspond to some n : nat *)

Open Scope sem.
Lemma ZF_undec2 D (M : interp D) B :
  standard M -> M ⊨=T Z' -> M ⊨= solvable B -> PCPb B.
Proof.
  intros H1 H2 H3. apply PCP_ZFeq with (fun _ => ∅); auto.
Qed.

Lemma ZF_undec3 (p : peirce) B :
  PCPb B -> Z' ⊢T solvable B.
Proof.
  intros H. exists ZFeq'. split; auto. now apply PCP_ZFD.
Qed.

(* Then the reductions so Z', Z, and ZF all follow by reduction_theorem *)

Lemma undec_Z' :
  (exists D I, @standard D I /\ I ⊨=T Z') -> treduction solvable PCPb Z'.
Proof.
  apply (reduction_theorem ZF_undec1 ZF_undec2 ZF_undec3); trivial.
Qed.

Lemma undec_Z :
  (exists D I, @standard D I /\ I ⊨=T Zeq) -> treduction solvable PCPb Zeq.
Proof.
  apply (reduction_theorem ZF_undec1 ZF_undec2 ZF_undec3); trivial.
  eauto using Zeq.
Qed.

Lemma undec_ZF :
  (exists D I, @standard D I /\ I ⊨=T ZFeq) -> treduction solvable PCPb ZFeq.
Proof.
  apply (reduction_theorem ZF_undec1 ZF_undec2 ZF_undec3); trivial.
  eauto using ZFeq.
Qed.

(* *** Corollary 44 : the standard models required by the previous theorem can be constructed with CE and TD *)

Lemma CE_undec_Z' :
  Aczel_CE.CE -> treduction solvable PCPb Z'.
Proof.
  intros H. apply undec_Z'.
  destruct (extensionality_model_eq H) as (D & M & H1 & H2 & H3).
  exists D, M. split; trivial. eauto using Zeq.
Qed.

Lemma CE_undec_Z :
  Aczel_CE.CE -> treduction solvable PCPb Zeq.
Proof.
  intros H. apply undec_Z.
  destruct (extensionality_model_eq H) as (D & M & H1 & H2 & H3).
  exists D, M. split; trivial. auto.
Qed.

Lemma TD_undec_ZF :
  Aczel_CE.CE -> TD -> treduction solvable PCPb ZFeq.
Proof.
  intros HC HD. apply undec_ZF.
  destruct (normaliser_model_eq HC HD) as (D & M & H1 & H2 & H3).
  exists D, M. split; trivial. auto.
Qed.

(* Refinement : allowing intensional models disposes of CE *)

Lemma refined_undec_Z' :
  treduction solvable PCPb Z'.
Proof.
  apply undec_Z'.
  destruct intensional_model as (D & M & H1 & H2).
  exists D, M. split; trivial. auto.
Qed.

(* *** Theorem 45 : all extensions of Z' satisfied by a standard model are incompletene, using LEM *)

(* We first need to show the ZF signature discrete and enumerable *)

#[local]
Instance eqdec_ZF_syms :
  eq_dec syms.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

#[local]
Instance eqdec_ZF_preds :
  eq_dec preds.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

Definition enum_ZF_syms :
  enumerable__T syms.
Proof.
  apply enum_enumT. exists (fun _ => [eset; pair; power; union; om]).
  intros []; exists 0; auto. all: cbv; eauto. do 4 right. now left.
Qed.

Definition enum_ZF_preds :
  enumerable__T preds.
Proof.
  apply enum_enumT. exists (fun _ => [elem; equal]).
  intros []; exists 0; auto. all: cbv; eauto.
Qed.

(* The claim follows with complete_reduction and reduction_theorem_class *)

Theorem incompleteness_ZF (T : form -> Prop) :
  LEM -> Z' <<= T -> enumerable T -> complete T -> (exists D I, @standard D I /\ I ⊨=T T) -> computational_explosion.
Proof.
  intros lem HFA HE HC (Ds & Is & HI1 & HI2). apply PCPb_undec.
  apply (@complete_reduction _ _ enum_ZF_syms _ enum_ZF_preds _ T HE) with solvable.
  - intros H. apply (@tsoundness_class _ _ lem _ T ⊥ H Ds Is (fun n => ∅)). firstorder.
  - apply HC.
  - eapply (reduction_theorem_class ZF_undec2 ZF_undec3); trivial. now exists Ds, Is.
  - apply solvabe_bound.
Qed.

(* *** Theorem 53 : we obtain the same reductions for set theory only formulated with equality and membership *)

From Undecidability.FOL Require Import minZF PCPb_to_minZF PCPb_to_minZFeq.

#[local]
Existing Instance sig_empty.
#[local]
Existing Instance ZF_pred_sig.

(* See the file minZF_undec.v for a list of all reductions, we just record the axiom-free version here *)

Definition minZ' := list_theory minZFeq'.

Lemma undec_minZ' :
  PCPb ⪯T minZ'.
Proof.
  exists minsolvable. split; intros B; split; intros H.
  - apply (@PCP_ZFD intu), (@rm_const_prv intu nil), soundness in H. auto.
  - apply PCP_ZFeq'; try apply intensional_model.
    intros V M rho HM. apply min_correct; trivial.
    apply H. now apply min_axioms'.
  - exists minZFeq'. split; auto. now apply (@PCP_ZFD intu), (@rm_const_prv intu nil) in H.
  - destruct H as (A & H1 & H2). eapply (Weak (B:=minZFeq')) in H2; auto.
    apply PCP_ZFeq'; try apply intensional_model. apply soundness in H2.
    intros V M rho HM. apply min_correct; trivial.
    apply H2. now apply min_axioms'.
Qed.

(* *** Theorem 58 : FOL with a single binary relation symbol is undecidable *)

From Undecidability.FOL Require Import BinSig binZF PCPb_to_binZF binZF_undec.

#[local]
Existing Instance sig_empty.
#[local]
Existing Instance sig_binary.

(* We first show that set theory formulated only using membership is undecidable *)

Definition binZ' := list_theory binZF.

Lemma undec_binZ' :
  treduction binsolvable PCPb binZ'.
Proof.
  split; intros B.
  - rewrite (PCPb_entailment_binZF B). split; intros H D M rho; eauto.
  - rewrite (PCPb_deduction_binZF B). split; intros H.
    + exists binZF. split; auto.
    + destruct H as [A[H1 H2]]. apply (Weak H2). auto.
Qed.

(* We then derive the undecidability of binary FOL with Fact 11 *)

Lemma undec_valid :
  undecidable valid.
Proof.
  apply (undecidability_from_reducibility PCPb_undec). eapply reduces_transitive.
  + exists binsolvable. apply (proj1 undec_binZ').
  + apply red_finite_valid.
Qed.

Lemma undec_prv_intu :
  undecidable (prv (p:=intu) nil).
Proof.
  apply (undecidability_from_reducibility PCPb_undec). eapply reduces_transitive.
  + exists binsolvable. apply (proj2 undec_binZ').
  + apply red_finite_prv.
Qed.

(* For undecidability of classical deduction we need LEM again *)

Lemma undec_class_binZ' :
  LEM -> reduction binsolvable PCPb (tprv_class binZ').
Proof.
  intros lem. split; intros H.
  - apply (@PCP_ZFD class), (@rm_const_prv class nil) in H. exists binZF. split; trivial.
  - destruct H as [A[H1 H2]]. apply PCP_ZFeq'; try apply intensional_model.
    apply (Weak (B:=binZF)) in H2; auto. apply soundness_class in H2; trivial.
    intros V M rho HM. apply min_correct; trivial. apply H2. now apply min_axioms'.
Qed.

Lemma undec_prv_class :
  LEM -> undecidable (prv (p:=class) nil).
Proof.
  intros lem. apply (undecidability_from_reducibility PCPb_undec). eapply reduces_transitive.
  + exists binsolvable. now apply undec_class_binZ'.
  + apply red_finite_prv.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl_verif.init_tweetnacl.

Open Scope Z.

Definition set25519_spec :=
 DECLARE _set25519
  WITH r: val, a: val, shr : share, sha : share, contents_r : list val, contents_a : list Z
  PRE [ _r OF (tptr tlg), _a OF (tptr tlg)]
        PROP  (writable_share shr;
               readable_share sha;
                Zlength contents_a = 16;
                Zlength contents_r = 16)
        LOCAL (temp _r r; temp _a a)
        SEP   (sha [{ a }] <<(lg16)-- mVI64 contents_a;
               shr [{ r }] <<(lg16)-- contents_r)
  POST [ tvoid ]
        PROP ()
        LOCAL()
        SEP ( sha [{ a }] <<(lg16)-- mVI64 contents_a;
              shr [{ r }] <<(lg16)-- mVI64 contents_a).

Definition set25519_Inv shr sha r a contents_r contents_a :=
  EX i : Z,
   PROP  (writable_share shr; readable_share sha;
          Zlength contents_a = 16;
          Zlength contents_r = 16;
          i >= 0)
   LOCAL (temp _a a; temp _r r)
   SEP   (shr [{ r }] <<(lg16)-- ((list.take (nat_of_Z i) (mVI64 contents_a)) ++ list.drop (nat_of_Z i) contents_r);
          sha [{ a }] <<(lg16)-- mVI64 contents_a).

Close Scope Z.


(* make terms, experiment with lifting properness from domains to corresponding labels *)
Require Import Setoid.
Require Import Morphisms.
Require Import List.
Require Import Program.

Set Implicit Arguments.

Generalizable All Variables.

Definition funty `(el : U -> Type) args res :=
  fold_right  (fun a r => el a -> r) (el res) args.

Definition funrel `(rels : forall (u : U), relation (el u))
           args res : relation (funty el args res) :=
 list_rect (fun args => relation (funty el args res))
           (rels res) (fun a _ rs => respectful (rels a) rs) args.

Definition funty' `(el : U -> Type) args res :=
  fold_right  (fun a r => el a -> r) (option (el res)) args.

Definition option_impl `(R : relation A) : relation (option A) :=
  fun x y => match x, y with
                | Some v, Some w => R v w
                | None, _ => True
                | _, _ => False
              end.

Definition funrel' `(rels : forall (u : U), relation (el u))
           args res : relation (funty' el args res) :=
 list_rect (fun args => relation (funty' el args res))
           (option_impl (rels res)) (fun a _ rs => respectful (rels a) rs) args.

Module Type Labels.
  Parameter sort : Set.
  Parameter domain : sort -> Set.
  Parameter domain_eq : forall s, relation (domain s).
  Parameter domain_eq_equiv : forall s, Equivalence (@domain_eq s).
  Parameter label : Set.
  Parameter label_args : label -> list sort.
  Parameter label_res : label -> sort.
  Parameter label_sem : forall l, funty' domain (label_args l) (label_res l).
  Parameter label_proper : forall l, Proper (funrel' domain_eq (label_args l) (label_res l)) (label_sem l).
  Parameter var : sort -> Set.
End Labels.

Module Terms (Import labels : Labels).

Definition label_ty args res := funty' domain args res.

Unset Implicit Arguments.
Inductive Term : forall s : sort, Type :=
 | TVar : forall {s}, var s -> Term s
 | TCon : forall l, TArgs (label_args l) -> Term (label_res l)
with TArgs : forall (args : list sort), Type :=
 | TNil : TArgs nil
 | TCons : forall {a args}, Term a -> TArgs args -> TArgs (a :: args)
 .
Set Implicit Arguments.

Fixpoint gather {args : list sort} {res : sort} {struct args} :=
  match args as args return (TArgs args -> Term res) -> funty Term args res with
    | nil => fun k => k TNil
    | (cons x xs) => fun k => fun x' => @gather xs _ (fun xs' => k (TCons x' xs'))
  end.

Definition lapply (l : label) := gather (TCon l).

Notation Env := (forall s, var s -> option (domain s)).

Fixpoint eval (env : Env) {s} (t : Term s) : option (domain s) :=
  match t with
    | TVar _ v => env _ v
    | TCon f args => apply env (Some (label_sem f)) args
  end
with apply (env : Env) {args : list sort} {res : sort} (mf : option (label_ty args res))
           (ts : TArgs args){struct ts}  : option (domain res) :=
  match mf with
    | None => None
    | Some f =>
      match ts in TArgs args return label_ty args res -> option (domain res) with
        | TNil => fun f => f
        | TCons _ args' t ts => fun f' =>
          match  eval env t with
            | None => None
            | Some v => apply env (Some (f' v)) ts
          end
      end f
  end.

Definition valid_impl (s : sort) : relation (Term s) :=
  fun t1 t2 => forall env,
                 option_impl (@domain_eq s) (eval env t1) (eval env t2).

Lemma valid_impl_refl (s : sort) : Reflexive (@valid_impl s).
intro x; unfold valid_impl. intros. destruct (eval env x); simpl; reflexivity.
Qed.
Lemma valid_impl_trans (s : sort) : Transitive (@valid_impl s).
intro x; unfold valid_impl. intros. specialize (H env).  specialize (H0 env).
destruct (eval env x);destruct (eval env y);simpl in H;try tauto;destruct (eval env z);simpl in H0; try tauto.
simpl. etransitivity;eassumption.
Qed.

Add Parametric Relation (s : sort) : (Term s) (@valid_impl s)
  reflexivity proved by (@valid_impl_refl s)
  transitivity proved by (@valid_impl_trans s)
  as valid_rel.

Fixpoint valid_args (args : list sort) (ts1 : TArgs args) : TArgs args -> Prop :=
  match ts1 in TArgs args' return TArgs args' -> Prop with
    | TNil => fun ts2 => match ts2 with
                             | TNil => True
                             | _ => False
                         end
    | TCons s ss t1 ts1' => fun ts2 =>
      match ts2 in TArgs args'' return match args'' with
                                         | nil => True
                                         | (s :: ss) => Term s -> TArgs ss -> Prop
                                       end with
          | TNil => I
          | TCons _ _ t2 ts2' => fun t1' ts1'' =>
                                   valid_impl t1' t2 /\ valid_args ts1'' ts2'
      end t1 ts1'
  end.

Ltac dep_dest_1 := let x := fresh "x" in intro x; dependent destruction x.
Ltac straightforward_reflexivity := dep_dest_1; simpl; intuition reflexivity.
Ltac straightforward_transitivity := do 3 dep_dest_1; simpl; intuition (etransitivity; eassumption).

Lemma valid_args_refl (ss : list sort) : Reflexive (@valid_args ss).
induction ss; straightforward_reflexivity.
Qed.
Lemma valid_args_trans (ss : list sort) : Transitive (@valid_args ss).
induction ss; straightforward_transitivity.
Qed.

Add Parametric Relation (ss : list sort) : (TArgs ss) (@valid_args ss)
  reflexivity proved by (@valid_args_refl ss)
  transitivity proved by (@valid_args_trans ss)
  as valid_args_rel.

Add Parametric Morphism (s : sort) (ss : list sort) : (@TCons s ss)
with signature (@valid_impl s) ++> (@valid_args ss) ++> (@valid_args (s :: ss))
as tcons_valid.
simpl; auto.
Qed.

Lemma apply_rel
  (args : list sort)
  (res : sort)
  (x : funty' domain args res)
  (y : funty' domain args res)
  (H : funrel' domain_eq args res x y)
  (x0 : TArgs args)
  (y0 : TArgs args)
  (H0 : valid_args x0 y0) :
  forall env : Env,
   option_impl (domain_eq (s:=res)) (apply env (Some x) x0)
     (apply env (Some y) y0).
Proof.
intro env.
induction args; dependent destruction x0; dependent destruction y0.
exact H.
destruct H0.
specialize (H0 env).
simpl.
destruct (eval env t);
destruct (eval env t0);
simpl in H0 |- *; try tauto.
apply IHargs; auto.
Qed.

Add Parametric Morphism l : (TCon l)
  with signature (@valid_args (label_args l)) ++> (@valid_impl (label_res l))
  as tcon_valid.
Proof.
intros; unfold valid_impl; apply apply_rel; [apply label_proper |  assumption].
Qed.
End Terms.

Module ExpLabel <: Labels.
  Inductive sortI : Set := nsort.
  Definition sort := sortI.
  Definition domain s :=
    match s with
        nsort => nat
    end.
  Definition domain_eq s := @eq (domain s).
  Definition domain_eq_equiv s := @eq_equivalence (domain s).
  Definition var s := option (domain s).

  Inductive labelI : Set :=
    | lplus
    | lcon (n : nat).
  Definition label := labelI.
  Definition label_args (l : labelI) :=
    match l with
      | lplus => [nsort ; nsort]
      | lcon _ => nil
    end.
  Definition label_res (l : labelI) := nsort.
  Definition label_sem (l : labelI) :=
    match l as l return funty' domain (label_args l) (label_res l) with
      | lplus => fun x y => Some (x + y)
      | lcon v => Some v
    end.
  Definition label_proper (l : labelI) : Proper (funrel' domain_eq (label_args l) (label_res l)) (label_sem l).
    destruct l; unfold Proper; simpl; unfold domain_eq, respectful; congruence.
  Qed.
End ExpLabel.

Import ExpLabel.
Module Import lterms := Terms ExpLabel.

Notation tcon n := (TCon (lcon n) TNil : Term nsort).
Notation tplus l r := (TCon lplus (TCons l (TCons r TNil)) : Term nsort).

Lemma computing (x y : nat) : valid_impl (tplus (tcon x) (tcon y)) (tcon (x + y)).
Proof.
unfold valid_impl; reflexivity.
Qed.
Check computing.

Lemma computing_r (x y : nat) : (Basics.flip (@valid_impl _)) (tplus (tcon x) (tcon y)) (tcon (x + y)).
Proof.
unfold flip, valid_impl; reflexivity.
Qed.

Lemma con_equiv (x y : nat) : x = y -> valid_impl (tcon x) (tcon y).
congruence.
Qed.

Instance valid_default (s : sort) : DefaultRelation (@valid_impl s).
Instance valids_default (ss : list sort) : DefaultRelation (@valid_args s).

Fixpoint bu (simpl : forall s, Term s -> Term s) s (t : Term s) : Term s :=
  match t in Term s' return Term s' with
    | (TVar _ _ as t') => simpl _ t'
    | TCon l args => simpl _ (TCon l (bus simpl args))
  end
with bus (simpl : forall s, Term s -> Term s) ss (ts : TArgs ss) : TArgs ss :=
  match ts in TArgs ss' return TArgs ss' with
    | TNil => TNil
    | TCons _ _ t ts' => TCons (bu simpl t) (bus simpl ts')
  end.

Lemma bu_simpls : forall (simpl : forall s, Term s -> Term s)
      (simpl_simpls : forall s (t : Term s), valid_impl t (simpl s t)),
      forall s (t : Term s), valid_impl t (bu simpl t)
with bus_simpls : forall (simpl : forall s, Term s -> Term s)
      (simpl_simpls : forall s (t : Term s), valid_impl t (simpl s t)),
      forall ss (ts : TArgs ss), valid_args ts (bus simpl ts).
Proof.
clear bu_simpls. destruct t;simpl;auto.
rewrite <- simpl_simpls.
auto using tcon_valid.

clear bus_simpls. induction ts;simpl;auto.
Qed.

Definition simpl_plus s : Term s -> Term s :=
 match s as s return Term s -> Term s with
   | nsort => fun t => match t with
                         | TCon lplus (TCons _ _ (TCon (lcon x) TNil)
                                             (TCons _ _ (TCon (lcon y) TNil)
                                                    TNil)) => TCon (lcon (x + y)) TNil
                         | _ => t
                       end
 end.

Lemma simpl_plus_simpls : forall s (t : Term s), valid_impl t (simpl_plus t).
intros.
destruct t.
destruct s. reflexivity.
destruct l; try reflexivity.
dependent destruction t.
dependent destruction t1.
fold sort in t1.
dependent destruction t1.
dependent destruction t.
reflexivity.
destruct l.
reflexivity.
simpl in t.
dependent destruction t.
dependent destruction t2.
reflexivity.
destruct l.
reflexivity.
simpl in t.
dependent destruction t.
simpl.
unfold valid_impl.
simpl.
reflexivity.
Qed.

Require Import Omega.

Lemma test_computing (x y z : nat) :
  valid_impl (tplus (tplus (tcon x) (tcon y)) (tcon z))
             (tcon ((x + y) + z)).
autounfold.
rewrite computing.
autounfold.
rewrite computing.

pose proof (computing (x + y) z).
Set Printing All.
autounfold.
autounfold in H.
rewrite H.
Check trans_co_eq_inv_impl_morphism.
Check
(tcons_valid_Proper (computing x y) (TCons (tcon z) TNil)
          (TCons (tcon z) TNil)
          (reflexive_proper_proxy
             (valid_args_rel_Reflexive (ss:=[label_res (lcon z)]))
             (TCons (tcon z) TNil)))
.
test_computing =
(fun
   H : valid_impl (tplus (tcon (x + y)) (tcon z))
         (tplus (tcon (x + y)) (tcon z)) =>
 (fun lemma : valid_impl (tplus (tcon x) (tcon y)) (tcon (x + y)) =>
  trans_co_eq_inv_impl_morphism (valid_rel_Transitive (s:=label_res lplus))
    (tplus (tplus (tcon x) (tcon y)) (tcon z))
    (tplus (tcon (x + y)) (tcon z))
    (tcon_valid_Proper
       (TCons (tplus (tcon x) (tcon y)) (TCons (tcon z) TNil))
       (TCons (tcon (x + y)) (TCons (tcon z) TNil))
       (tcons_valid_Proper lemma (TCons (tcon z) TNil)
          (TCons (tcon z) TNil)
          (reflexive_proper_proxy
             (valid_args_rel_Reflexive (ss:=[label_res (lcon z)]))
             (TCons (tcon z) TNil)))) (tplus (tcon (x + y)) (tcon z))
    (tplus (tcon (x + y)) (tcon z))
    (eq_proper_proxy (Term (label_res lplus)) (tplus (tcon (x + y)) (tcon z))))
   (computing x y) H) (reflexivity (tplus (tcon (x + y)) (tcon z)))
     : forall x y z : nat,
       valid_impl (tplus (tplus (tcon x) (tcon y)) (tcon z))
         (tplus (tcon (x + y)) (tcon z))

rewrite computing.
reflexivity.
Qed.
Print test_computing.

Lemma use_computing (x y z w : nat) :
  valid_impl (tplus (tplus (tcon x) (tcon y)) (tplus (tcon z) (tcon w)))
             (tplus (tcon x) (tplus (tplus (tcon y) (tcon z)) (tcon w))).
Proof.
assert
cut (valid_impl (tcon ((x + y) + (z + w)))
                (tplus (tcon x) (tplus (tplus (tcon y) (tcon z)) (tcon w)))).
rewrite computing.
assert (Proper (valid_impl (s:=label_res lplus) ==> flip (@valid_impl (label_res lplus)) ==> flip impl)
               (valid_impl (s:=label_res lplus))).
unfold Proper.
unfold flip.
intro. intros.
intro. intros.
intro.
transitivity y0. assumption.
transitivity y1. assumption.
assumption.

Lemma
rewrite computing.
rewrite computing.
setoid_rewrite computing.

rewrite (bu_simpls _ simpl_plus_simpls).
simpl.
congruence omega.
setoid_rewrite computing.
repeat match goal with [|- valid ?pre _] =>
       match pre with context [tplus (tcon ?l) (tcon ?r)] => rewrite (computing l r) end end.
repeat match goal with [|- valid _ ?post] =>
       match post with context [tplus (tcon ?l) (tcon ?r)] => rewrite (computing_r l r) end end.
apply con_equiv.
omega.
Qed.

Definition oplus : label_ty (nsort :: nsort :: []) nsort  := fun x y => Some (x + y).

Instance plus_proper : Proper (label_rel (nsort :: nsort :: []) nsort) oplus.
repeat (intro; intros).
simpl in * |- *.
unfold domain_eq in * |- *.
congruence.
Qed.

Definition ocon (n : nat) : label_ty [] nsort := Some n.

Instance con_proper (n : nat) : Proper (label_rel [] nsort) (ocon n).
reflexivity.
Qed.

Notation tcon n := (TCon (ocon n) TNil).
Notation tplus l r := (TCon oplus (TCons l (TCons r TNil))).

Lemma computing (x y : nat) : valid (tplus (tcon x) (tcon y)) (tcon (x + y)).
Proof.
unfold valid; reflexivity.
Qed.
Lemma computing_r (x y : nat) : (Basics.flip (@valid _)) (tplus (tcon x) (tcon y)) (tcon (x + y)).
Proof.
unfold flip, valid; reflexivity.
Qed.

Lemma con_equiv (x y : nat) : x = y -> valid (tcon x) (tcon y).
congruence.
Qed.

Instance valid_default (s : sort) : DefaultRelation (@valid s).

Require Import Omega.

Lemma use_computing (x y z w : nat) :
  valid (tplus (tplus (tcon x) (tcon y)) (tplus (tcon z) (tcon w)))
        (tplus (tcon x) (tplus (tplus (tcon y) (tcon z)) (tcon w))).
Proof.
do 3 rewrite computing.
do 3 rewrite computing_r.
apply con_equiv.
omega.
Qed.


From Coq Require Import Morphisms.

From ITree Require Import
     ITree
     ITreeFacts
     Eq.EqAxiom
.

From Paco Require Import paco.

(* Tau t ≈ t*)
(* eqit_secure (Vis e k)  (k a) *)

(* r => fun (f g : A -> B) => f = g*)
Global Instance strong_bisim_proper_paco {E R1 R2 F r} :
       Proper (@eq_itree E R1 R1 eq ==> @eq_itree E R2 R2 eq ==> flip impl) (paco2 F r).
Proof.
  repeat intro. apply bisimulation_is_eq in H. apply bisimulation_is_eq in H0.
  subst. auto.
Qed.


Require Import CSet Le.

Require Import Plus Util AllInRel Map LengthEq.
Require Import CSet Val Var Envs SimF IL Annotation RenamedApart.

Require Import SetOperations Liveness.Liveness Eqn OptionR.

Set Implicit Arguments.
Unset Printing Records.

Inductive eqn_sound : list params -> list eqns  (*params*set var*eqns*)
                      -> stmt -> stmt
                      -> eqns
                      -> ann (set var * set var)
                      -> Prop :=
| EqnLet x ZL Δ s s' e Gamma e' G G' ang
  : eqn_sound ZL Δ s s' {EqnEq (Var x) e ; Gamma } ang
    -> entails Gamma {EqnApx e e'}
    -> eqn_sound ZL Δ (stmtLet x (Operation e) s) (stmtLet x (Operation e') s') Gamma
                (ann1 (G,G') ang)
| EqnIf ZL Δ e e' s s' t t' Gamma G G' ang1 ang2
  : eqn_sound ZL Δ s s' {EqnEq (UnOp UnOpToBool e) (Con val_true); Gamma} ang1
  -> eqn_sound ZL Δ t t' {EqnEq (UnOp UnOpToBool e) (Con val_false); Gamma} ang2
  -> entails Gamma {(EqnApx e e')}
  -> eqn_sound ZL Δ (stmtIf e s t) (stmtIf e' s' t') Gamma
              (ann2 (G,G') ang1 ang2)
| EqnApp (l:lab) Y Y' ZL Δ Gamma Z Γf G G'
  : get ZL  l Z -> get Δ l Γf
    -> length Y = length Y'
    -> entails (of_list ((fun y => EqnEq y y) ⊝ Y) ∪ Gamma) (subst_eqns (sid [Z <-- Y']) Γf)
    -> entails Gamma (list_EqnApx Y Y')
    -> eqn_sound ZL Δ (stmtApp l Y) (stmtApp l Y') Gamma (ann0 (G,G'))
| EqnReturn ZL Δ e e' Gamma G G'
  : entails Gamma {(EqnApx e e')}
    -> eqn_sound ZL Δ (stmtReturn e) (stmtReturn e') Gamma (ann0 (G,G'))
| EqnExtern x f ZL Δ s s' Y Y' Gamma G G' ang
  : eqn_sound ZL Δ s s' {EqnEq (Var x) (Var x) ; Gamma} ang
    -> entails Gamma (list_EqnApx Y Y')
    -> list_union (List.map Ops.freeVars Y') ⊆ G
    -> length Y = length Y'
    -> eqn_sound ZL Δ (stmtLet x (Call f Y) s) (stmtLet x (Call f Y') s') Gamma
                (ann1 (G,G') ang)
| EqnFun ZL Δ ΓF F F' t t' Gamma G G' angs angb
         (Len1:length(ΓF) = length F)
         (Len2: length F = length F')
         (ParamEq:forall n Z s Z' s' , get F n (Z, s) -> get F' n (Z', s') -> Z = Z')
         (IndF:forall n Z s Z' s' EqS angn , get F n (Z, s) -> get F' n (Z', s')
                                        -> get ΓF n EqS -> get angs n angn
                                        -> eqn_sound (List.map fst F ++ ZL)
                                                    (ΓF ++ Δ) s s' (EqS ∪ Gamma) angn)
         (Indt:eqn_sound (List.map fst F ++ ZL) (ΓF ++ Δ)  t t' Gamma angb)
         (EqnFVF: forall n EqS Zs, get F n Zs -> get ΓF n EqS -> eqns_freeVars EqS ⊆ G ∪ of_list (fst Zs))
  : eqn_sound ZL Δ (stmtFun F t) (stmtFun F' t') Gamma
              (annF (G,G') angs angb)
| EqnUnsat ZL Δ s s' Gamma ang
  : unsatisfiables Gamma
    -> eqn_sound ZL Δ s s' Gamma ang.

Lemma unsat_Equal Γ Γ'
  : unsatisfiables Γ
    -> Γ [=] Γ'
    -> unsatisfiables Γ'.
Proof.
  intros; hnf; intros.
  rewrite <- H0. eauto.
Qed.

Instance eqn_sound_Proper
  : Proper (eq ==> eq ==> eq ==> eq ==> Equal ==> ann_R (@pe var _) ==> impl)
           eqn_sound.
Proof.
  unfold Proper, respectful, impl; intros; subst. symmetry in H4.
  general induction H5; only 1-6:(invt @ann_R; invt @pe).
  - econstructor 1; eauto with cset; try rewrite <- H3; eauto.
  - econstructor 2; eauto with cset; try rewrite <- H3; eauto.
  - econstructor 3; eauto with cset; try rewrite <- H4; eauto.
  - econstructor 4; eauto with cset; try rewrite <- H3; eauto.
  - econstructor 5; eauto with cset; try rewrite <- H3; eauto.
    rewrite H10. eauto.
  - econstructor 6; eauto with cset.
    + intros; inv_get.
      exploit H; eauto; try reflexivity.
      rewrite H3; eauto.
    + intros; inv_get.
      rewrite EqnFVF; eauto. rewrite H7. reflexivity.
  - econstructor.
    rewrite <- H3; eauto.
Qed.

Ltac dowith c t :=
  match goal with
    | [ H : c _ _ _ _ |- _ ] => t H
  end.

Lemma eqn_sound_entails_monotone ZL Δ Γ1 Γ1' s s' ang
  : renamedApart s ang
    -> eqn_sound ZL Δ s s' Γ1 ang
    -> entails Γ1' Γ1
    -> eqn_sound ZL Δ s s' Γ1' ang.
Proof.
  intros. general induction H0;
            (try now (eapply EqnUnsat; eauto using unsatisfiable_entails_monotone));
            invt renamedApart; eauto.
  - econstructor; eauto.
    eapply IHeqn_sound; eauto.
    rewrite <- H2. reflexivity.
    + etransitivity; eauto.
  - econstructor; intros; eauto using entails_transitive.
    + eapply IHeqn_sound1; eauto.
      rewrite H1. reflexivity.
    + eapply IHeqn_sound2; eauto.
      rewrite H1. reflexivity.
  - econstructor; eauto using entails_transitive.
    etransitivity; eauto.
    eapply entails_union; split.
    + eapply entails_subset. cset_tac.
    + etransitivity; eauto.
      eapply entails_subset. cset_tac.
  - econstructor; eauto using entails_transitive.
  - econstructor; eauto using entails_transitive, entails_monotone.
    eapply IHeqn_sound; eauto.
    rewrite H4. reflexivity.
  - econstructor; eauto.
    + intros.
      exploit H10; eauto.
      eapply H; eauto.
      eapply entails_union; eauto; split.
      eapply entails_incl. eauto with cset.
      etransitivity; eauto.
      eapply entails_incl. eauto with cset.
Qed.

Lemma eqn_sound_monotone ZL Δ Γ Γ' s s' ang
  : renamedApart s ang
    -> eqn_sound ZL Δ s s' Γ ang
    -> Γ ⊆ Γ'
    -> eqn_sound ZL Δ s s' Γ' ang.
Proof.
  intros. eapply eqn_sound_entails_monotone; eauto.
  eapply entails_incl; eauto.
Qed.

Hint Resolve satisfies_fstNoneOrR_apx onvLe_fstNoneOrR_apx.

Instance PR : PointwiseProofRelationF (params*eqns):=
  {
    ArgRelFP := fun E E' '(Z,Γf) VL VL'
               => length Z = length VL /\ VL = VL' /\
                 satisfiesAll (E [Z <-- Some ⊝ VL]) Γf;
    ParamRelFP := fun '(Z,_) Z' Zb => Z = Z' /\ Zb = Z'
  }.

(*
Instance prod_eq_fst_morphism X `{OrderedType X}
: Proper (@pe X _ ==> Equal) fst.
Proof.
  unfold Proper, respectful; intros.
  inversion H0; simpl; eauto.
Qed.

Instance prod_eq_snd_morphism X `{OrderedType X}
: Proper (@pe X _ ==> Equal) snd.
Proof.
  unfold Proper, respectful; intros.
  inversion H0; simpl; eauto.
Qed.

Instance add_s_m_flip A `{OrderedType A}
  : Proper (Equal ==> Equal ==> iff) Subset.
Proof.
  unfold Proper, respectful, flip; intros.
  rewrite H0, H1. reflexivity.
Qed.

Instance add_s_m_flip' A `{OrderedType A}
  : Proper (Equal ==> Equal ==> impl) Subset.
Proof.
  unfold Proper, respectful, flip; intros.
  rewrite H0, H1. reflexivity.
Qed.

Instance add_s_m_flip'' A `{OrderedType A}
  : Proper (Equal ==> Equal ==> flip impl) Subset.
Proof.
  unfold Proper, respectful, flip; intros.
  rewrite H0, H1. reflexivity.
Qed.
 *)

Lemma satisfiesAll_EqnEq_omap E Y
  : satisfiesAll E (of_list ((fun y : op => EqnEq y y) ⊝ Y))
    <-> exists vl, omap (op_eval E) Y = Some vl.
Proof.
  general induction Y; simpl.
  - split; hnf; intros; eauto. hnf; intros. cset_tac.
  - rewrite satisfiesAll_add.
    simpl. case_eq (op_eval E a); intros; simpl.
    rewrite IHY.
    + split; intros; dcr. rewrite H3. simpl. eauto.
      split; eauto. econstructor; eauto. monad_inv H1. eauto.
    + split; intros; dcr; clear_trivial_eqs.
Qed.

Lemma satisfiesAll_EqnApx_omap E Y Y' (LEN:❬Y❭=❬Y'❭) vl
  : satisfiesAll E (list_EqnApx Y Y')
    -> omap (op_eval E) Y = Some vl
    -> omap (op_eval E) Y' = Some vl.
Proof.
  unfold list_EqnApx.
  general induction LEN; simpl in *; eauto.
  - monad_inv H0.
    rewrite satisfiesAll_add in H; dcr.
    hnf in H0. rewrite EQ in *. inv H0.
    simpl. eapply IHLEN in H1; eauto.
    rewrite H1. reflexivity.
Qed.

Lemma sim_vopt r L L' V s s' ZL Δ Gamma ang
  : satisfiesAll V Gamma
    -> eqn_sound ZL Δ s s' Gamma ang
    -> labenv_sim SimExt (sim r) PR (zip pair ZL Δ) L L'
    -> renamedApart s ang
    -> eqns_freeVars Gamma ⊆ fst (getAnn ang)
    -> (forall n b Γf, get L n b ->
                get Δ n Γf ->
                eqns_freeVars Γf ⊆ fst (getAnn ang) ∪ of_list (block_Z b) /\
                agree_on eq (eqns_freeVars Γf \ of_list (block_Z b)) (F.block_E b) V)
    -> sim r SimExt  (L,V, s) (L',V, s').
Proof.
  intros SAT EQN SIML REAPT FV EEQ.
  general induction EQN; (try (now exfalso; eapply H; eauto));
    simpl; invtc renamedApart; simpl in * |- *.
  - exploit H; eauto.
    exploit H0; eauto; [cset_tac|].
    eapply (sim_let_op_apx il_statetype_F).
    + eauto.
    + intros. left. eapply IHEQN; eauto.
      * assert (satisfies (V [x <- ⎣ v ⎦]) (EqnEq (Var x) e)). {
          eauto using satisfies_EqnEq_on_update.
        }
        rewrite !satisfiesAll_add; split; eauto.
         -- eapply satisfiesAll_agree; eauto.
            symmetry.
            eapply agree_on_update_dead; eauto.
      * pe_rewrite. rewrite! eqns_freeVars_add. simpl.
        rewrite H7, FV. clear. cset_tac.
      * intros. exploit EEQ; dcr; eauto.
        pe_rewrite. rewrite H11 at 1. split.
        -- clear_all. cset_tac.
        -- symmetry. eapply agree_on_update_dead; eauto.
           rewrite H11. revert H6; clear_all; cset_tac.
           symmetry. eauto.
    + eauto.
  -  exploit H; eauto.  exploit H0; eauto; [cset_tac|].
     eapply (sim_cond_op_apx il_statetype_F).
     + eauto.
     + eauto.
     + intros. left. eapply IHEQN1; clear IHEQN1 IHEQN2; eauto.
       * apply satisfiesAll_add. eauto using  op_eval_true_satisfies.
       * rewrite eqns_freeVars_add. simpl. pe_rewrite. intros a0 A. cset_tac.
       * pe_rewrite; eauto with cset.
     + intros. left. eapply IHEQN2; clear IHEQN1 IHEQN2; eauto.
       * apply satisfiesAll_add. eauto using op_eval_false_satisfies.
       * rewrite eqns_freeVars_add . pe_rewrite.  intros gamma A. cset_tac.
       * pe_rewrite. eauto with cset.
  - eapply labenv_sim_app; eauto using zip_get; simpl.
    intros; split; intros; eauto.
    assert (EV:omap (op_eval V) Y' = ⎣ Yv ⎦). {
      eapply omap_satisfies_list_EqnApx; eauto.
    }
    simpl in *; dcr; subst.
    exists Yv; repeat split; eauto using omap_exp_eval_onvLe.
    exploit EEQ; eauto; dcr. clear H11. simpl in *. symmetry in H12.
    rewrite <- satisfiesAll_subst; eauto with len.
    eapply H2.
    eapply satisfiesAll_union; split; eauto.
    hnf; intros ? Get.
    eapply of_list_get_first in Get; dcr.
    inv_get. invc H11. simpl.
    eapply omap_inversion in H8; eauto; dcr.
    rewrite H15. econstructor; eauto.
  - eapply (sim_return_apx il_statetype_F).
    exploit H; eauto. eauto.
  - exploit H; eauto. eapply (sim_let_call_apx il_statetype_F); eauto; simpl.
    + case_eq (omap (op_eval V) Y); eauto using fstNoneOrR.
      intros.
      rewrite <- H3. eapply satisfies_omap_op_eval_fstNoneOrR; eauto.
    + intros. simpl. left. eapply IHEQN; eauto.
      * eauto using satisfiesAll_EqnEq_on_update.
      * pe_rewrite. rewrite eqns_freeVars_add. simpl.
        rewrite FV.  clear_all. cset_tac.
      * intros. exploit EEQ; dcr; eauto.
        pe_rewrite. split.
        rewrite H6. clear_all; cset_tac.
        symmetry. eapply agree_on_update_dead; try symmetry; eauto.
        rewrite H6. revert H8. clear_all. cset_tac.
  - pone_step. left. eapply IHEQN; eauto.
    + rewrite zip_app; eauto with len.
      eapply labenv_sim_extension_ptw; eauto with len.
      * intros. hnf. intros. simpl in * |- *. destruct a. dcr. subst. inv_get.
        exploit ParamEq; eauto. subst.
        exploit H7; eauto. dcr.
        eapply H; eauto.
        -- rewrite satisfiesAll_union; split.
           ++ exploit EqnFVF; eauto.
           ++ eapply satisfiesAll_agree; eauto.
             eapply agree_on_update_list_dead; eauto.
             ** edestruct H8; eauto; dcr.
                rewrite FV. eauto.
        -- rewrite eqns_freeVars_union.
           rewrite FV. edestruct H8; eauto; dcr. simpl in *.
           rewrite H14.
           exploit EqnFVF as EQ; eauto.
           rewrite EQ. simpl.
           clear; cset_tac.
        -- intros ? ? ? Get1 Get2. eapply get_app_cases in Get1. destruct Get1.
           ++ inv_get.
             edestruct H8; try eapply H5; eauto; dcr. simpl in *.
             rewrite H15. split.
             ** rewrite EqnFVF; eauto. clear_all; cset_tac.
             ** eapply agree_on_update_list_dead; eauto with len.
                rewrite EqnFVF; eauto.
                eapply disj_2_incl; eauto. clear_all; cset_tac.
           ++ dcr; simpl in *. len_simpl.
             rewrite get_app_ge in Get2; eauto with len.
             rewrite Len1 in *. inv_get.
             exploit EEQ; eauto; dcr.
              edestruct H8; try eapply H5; eauto; dcr.
             rewrite H14. simpl. split. rewrite H18.
             clear_all; cset_tac.
             simpl in *.
             eapply agree_on_update_list_dead; eauto.
             eapply disj_2_incl; eauto. rewrite H18.
             clear_all; cset_tac. omega.
      * hnf. intros. simpl in *. subst. inv_get. exploit ParamEq; dcr; eauto.
    + pe_rewrite. eauto.
    + intros ? ? ? Get1 Get2. eapply get_app_cases in Get1. destruct Get1.
      ++ inv_get. pe_rewrite. split; eauto.
      ++ dcr; simpl in *. len_simpl.
        rewrite get_app_ge in Get2; eauto with len.
        rewrite Len1 in *.
        exploit EEQ; eauto; dcr.
        split; eauto. pe_rewrite. eauto. omega.
Qed.