(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
Require Import imonae_lib.
From HB Require Import structures.
Require Import ihierarchy imonad_lib ifail_lib istate_lib.

(******************************************************************************)
(*                    Formalization of monad transformers                     *)
(*                                                                            *)
(* This file corresponds to the formalization of [Mauro Jaskelioff, Modular   *)
(* Monad Transformers, ESOP 2009] (roughly, up to Sect. 5, Example 22).       *)
(*                                                                            *)
(*  Module MonadMLaws == laws of monad morphisms                              *)
(*             monadM == type of monad morphisms                              *)
(*             monadT == type of monad transformers, i.e., functions t of     *)
(*                       type monad -> monad equipped with an operator Lift   *)
(*                       such that for any monad M Lift t M is a monad        *)
(*                       morphism from M to t M                               *)
(*                       instances:                                           *)
(*                       - stateT: the state monad transformer                *)
(*                       - exceptT: the exception monad transformer           *)
(*                       - envT: environment                                  *)
(*                       - outputT                                            *)
(*                       - contT: continuation                                *)
(*         mapStateT2 == standard utility function                            *)
(*            lifting == lifting of a sigma-operation along a monad morphism  *)
(*           alifting == algebraic operation defined using an algebraic       *)
(*                       operation op and a monad morphism e                  *)
(* uniform_algebraic_lifting == Theorem: alifting is a lifting                *)
(*                                                                            *)
(*         functorial == type of functors where the action on objects as type *)
(*                       monad -> monad                                       *)
(*                fmt == type of functorial monad transformers                *)
(*                       instances:                                           *)
(*                       - exceptFMT                                          *)
(*                       - stateFMT                                           *)
(*                       - envFMT                                             *)
(*                       - outputFMT                                          *)
(*                                                                            *)
(******************************************************************************)

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

Local Open Scope monae_scope.

Module MonadMLaws.
Section monadmlaws.
Variables (M N : monad).
Definition ret (e : M ~~> N) := forall A : UU0, e A \o Ret = Ret.
Definition bind (e : M ~~> N) := forall (A B : UU0) (m : M A) (f : A -> M B),
  e B (m >>= f) = e A m >>= (e B \o f).
End monadmlaws.
End MonadMLaws.

HB.mixin Record isMonadM (M N : monad) (e : M ~~> N) := {
  monadMret : MonadMLaws.ret e ;
  monadMbind : MonadMLaws.bind e }.

#[short(type=monadM)]
HB.structure Definition MonadM (M N : monad) :=
  {e of isMonadM M N e & isNatural M N e}.

HB.factory Record isMonadM_ret_bind (M N : monad) (e : M ~~> N) := {
  monadMret : MonadMLaws.ret e ;
  monadMbind : MonadMLaws.bind e }.

HB.builders Context (M N : monad) (e : M ~~> N) of isMonadM_ret_bind M N e.

Lemma naturality_monadM : naturality M N e.
Proof.
move=> A B h; apply funext => m /=.
by rewrite !fmapE monadMbind (compA (e B)) monadMret.
Qed.

HB.instance Definition _ := isNatural.Build M N e naturality_monadM.
HB.instance Definition _ := isMonadM.Build M N e monadMret monadMbind.
HB.end.

HB.mixin Record isMonadT (T : monad -> monad) := {
  Lift : forall M, monadM M (T M) }.

#[short(type=monadT)]
HB.structure Definition MonadT := {T of isMonadT T}.
Arguments Lift : clear implicits.

Section state_monad_transformer.
Variables (S : UU0) (M : monad).

Definition MS := fun A : UU0 => S -> M (A * S)%type.

Definition retS : FId ~~> MS := fun (A : UU0) => curry Ret.

Definition bindS (A B : UU0) (m : MS A) f : MS B := fun s => m s >>= uncurry f.

Let bindSretf : BindLaws.left_neutral bindS retS.
Proof.
by move=> A B a f; rewrite /bindS; apply funext => s; rewrite bindretf.
Qed.

Let bindSmret : BindLaws.right_neutral bindS retS.
Proof.
move=> A m; rewrite /bindS; apply funext => s.
by rewrite -[in RHS](bindmret (m s)); bind_ext; case.
Qed.

Let bindSA : BindLaws.associative bindS.
Proof.
move=> A B C m f g; rewrite /bindS; apply funext => s.
by rewrite bindA; bind_ext; case.
Qed.

HB.instance Definition _ :=
  isMonad_ret_bind.Build MS bindSretf bindSmret bindSA.

Lemma MS_mapE (A B : UU0) (f : A -> B) (m : MS A) :
  ([the functor of MS] # f) m = (M # (fun x => (f x.1, x.2))) \o m.
Proof.
apply funext=> s.
rewrite {1}/actm /= /bindS /= fmapE.
congr bind.
by apply: funext; case.
Qed.

Definition liftS (A : UU0) (m : M A) : MS A :=
  fun s => m >>= (fun x => Ret (x, s)).

Let retliftS : MonadMLaws.ret liftS.
Proof.
move=> A; rewrite /liftS; apply funext => a /=; apply funext => s /=.
by rewrite bindretf.
Qed.

Let bindliftS : MonadMLaws.bind liftS.
Proof.
move=> A B m f; rewrite {1}/liftS; apply funext => s.
rewrite [in LHS]bindA.
transitivity ((liftS m s) >>= (uncurry (@liftS B \o f))) => //.
rewrite [in RHS]bindA.
bind_ext => a.
by rewrite [in RHS]bindretf.
Qed.

HB.instance Definition _ := isMonadM_ret_bind.Build
  M [the monad of MS] liftS retliftS bindliftS.

End state_monad_transformer.

Definition stateT (S : UU0) := fun M => [the monad of MS S M].

HB.instance Definition _ (S : UU0) := isMonadT.Build
  (stateT S) (fun M => [the monadM _ _ of @liftS S M]).

Definition mapStateT2 (A S : UU0) (N1 N2 N3 : monad)
    (f : N1 (A * S)%type -> N2 (A * S)%type -> N3 (A * S)%type)
    (m1 : stateT S N1 A) (m2 : stateT S N2 A) : stateT S N3 A :=
  fun s => f (m1 s) (m2 s).

Section stateMonad_of_stateT.
Variables (S : UU0) (M : monad).

Local Notation M' := (MS S M).
Let Put : S -> M' unit := fun s _ => Ret (tt, s).
Let Get : M' S := fun s => Ret (s, s).

Let bindputput (s s' : S) : Put s >> Put s' = Put s'.
Proof.
rewrite bindE /= /bindS.
apply funext => s0.
by rewrite MS_mapE bind_fmap bindretf.
Qed.

Let bindputget (s : S) : Put s >> Get = Put s >> Ret s.
Proof.
rewrite !bindE !MS_mapE /= /bindS.
apply funext => s'.
by rewrite !bind_fmap !bindretf.
Qed.

Let bindgetput : Get >>= Put = skip.
Proof.
rewrite bindE MS_mapE /= /bindS.
by apply funext => s; rewrite bind_fmap bindretf.
Qed.

Let bindgetget (A : UU0) (k : S -> S -> stateT S M A) :
  Get >>= (fun s => Get >>= k s) = Get >>= (fun s => k s s).
Proof.
apply funext => s.
rewrite /Get/=.
rewrite !bindE !MS_mapE /= /bindS /= /retS/=.
rewrite !bind_fmap !bindretf/=.
rewrite !bindE !MS_mapE /= /bindS /= /retS/=.
by rewrite bind_fmap bindretf.
Qed.

HB.instance Definition _ := @isMonadState.Build
  S (MS S M) Get Put bindputput bindputget bindgetput bindgetget.

End stateMonad_of_stateT.

Section exception_monad_transformer.
Local Obligation Tactic := idtac.
Variables (Z : UU0) (* the type of exceptions *) (M : monad).

(* action on objects of the transformed monad *)
Definition MX := fun X : UU0 => M (Z + X)%type.

(* unit and bind operator of the transformed monad *)
Definition retX : FId ~~> MX := fun X x => Ret (inr x).

Definition bindX X Y (t : MX X) (f : X -> MX Y) : MX Y :=
  t >>= fun c => match c with inl z => Ret (inl z) | inr x => f x end.

Let bindXretf : BindLaws.left_neutral bindX retX.
Proof. by move=> A B a f; rewrite /bindX bindretf. Qed.

Let bindXmret : BindLaws.right_neutral bindX retX.
Proof.
by move=> A m; rewrite /bindX -[in RHS](bindmret m); bind_ext; case.
Qed.

Let bindXA : BindLaws.associative bindX.
Proof.
move=> A B C m f g; rewrite /bindX bindA; bind_ext; case => //.
by move=> z; rewrite bindretf.
Qed.

HB.instance Definition _ :=
 isMonad_ret_bind.Build MX bindXretf bindXmret bindXA.

Lemma MX_mapE (A B : UU0) (f : A -> B) :
  [the functor of MX] # f = M # (fun x => match x with inl y => inl y | inr y => inr (f y) end).
Proof.
apply funext => m.
rewrite {1}/actm /= /bindX /= [in RHS]fmapE.
congr (_ _).
by apply: funext; case.
Qed.

Definition liftX X (m : M X) : MX X := m >>= (@ret [the monad of MX] _).

Let retliftX : MonadMLaws.ret liftX.
Proof.
by move=> A; apply funext => a; rewrite /liftX /= bindretf.
Qed.

Let bindliftX : MonadMLaws.bind liftX.
Proof.
move=> A B m f; rewrite {1}/liftX.
rewrite !bindE !fmapE.
rewrite /= /join_of_bind /bindX /= !bindA.
rewrite 2!joinE !bindA.
bind_ext => a.
rewrite 3!bindretf.
rewrite /liftX /=.
bind_ext => b.
by rewrite bindretf.
Qed.

HB.instance Definition _ := isMonadM_ret_bind.Build
  M [the monad of MX] liftX retliftX bindliftX.

End exception_monad_transformer.

Definition exceptT (Z : UU0) := fun M => [the monad of MX Z M].

HB.instance Definition _ (Z : UU0) := isMonadT.Build
  (exceptT Z) (fun M => [the monadM M [the monad of MX Z M] of @liftX Z M]).

Section failMonad_of_exceptT.
Variable M : monad.
Let N (B : UU0) := M (unit + B)%type.

Let Fail : forall B, N B := fun B => Ret (inl tt).

Let bindfail : BindLaws.left_zero (@bind (exceptT unit M)) Fail.
Proof.
move=> A B g; rewrite /Fail.
by rewrite bindE /= /join_of_bind /bindX /= fmapE /= bindA 2!bindretf.
Qed.

HB.instance Definition _ := @isMonadFail.Build (MX unit M) Fail bindfail.

End failMonad_of_exceptT.

Section exceptMonad_of_exceptT.
Variable (M : monad).
Let N (B : UU0) := M (unit + B)%type.

Let Catch (B : UU0) (x : N B) (y : N B) : N B :=
  x >>= (fun u => (fun k k' => match u with | inl a => k a | inr b => k' b end)
    (fun=> y) (fun b => Ret (inr b))).

Let Catchmfail (A : UU0) :
  right_id (@fail [the failMonad of MX unit M] A) (@Catch A).
Proof.
move=> x; rewrite /Catch /= /fail /= -[in RHS](bindmret x); bind_ext.
by case=> /= [[]|].
Qed.

Let Catchfailm (A : UU0) :
  left_id (@fail [the failMonad of MX unit M] A) (@Catch A).
Proof.
move=> x; rewrite /N in x *.
by rewrite /Catch /= /fail /= bindretf.
Qed.

Let CatchA (A : UU0) : associative (@Catch A).
Proof.
move=> x y z; rewrite /Catch bindA; bind_ext.
by case=> [[]//|b]; rewrite bindretf.
Qed.

Let Catchret (A : UU0) (ua : A%type) :
  @left_zero (N A) (N A) (Ret (inr ua)) (@Catch A).
Proof. by move=> n ; rewrite /Catch /= bindretf. Qed.

HB.instance Definition _ := @isMonadExcept.Build
  (MX unit M) Catch Catchmfail Catchfailm CatchA Catchret.

End exceptMonad_of_exceptT.

Section environment_monad_transformer.
Local Obligation Tactic := idtac.
Variables (R : UU0) (M : monad).

Definition MEnv := fun A : UU0 => R -> M A.

Definition retEnv : FId ~~> MEnv := fun (A : UU0) a r => Ret a.

Definition bindEnv A B (m : MEnv A) f : MEnv B :=
  fun r => m r >>= (fun a => f a r).

Let bindEnvretf : BindLaws.left_neutral bindEnv retEnv.
Proof.
by move=> A B a f; rewrite /bindEnv; apply funext => r; rewrite bindretf.
Qed.

Let bindEnvmret : BindLaws.right_neutral bindEnv retEnv.
Proof.
move=> A m; rewrite /bindEnv; apply funext => r.
rewrite -[in RHS](bindmret (m r)); by bind_ext; case.
Qed.

Let bindEnvA : BindLaws.associative bindEnv.
Proof.
move=> A B C m f g; rewrite /bindEnv; apply funext => r.
by rewrite bindA; bind_ext; case.
Qed.

HB.instance Definition _ :=
 isMonad_ret_bind.Build MEnv bindEnvretf bindEnvmret bindEnvA.

Lemma MEnv_mapE (A B : UU0) (f : A -> B) (m : MEnv A) :
  ([the functor of MEnv] # f) m = (M # f) \o m.
Proof. by apply funext=> r; rewrite /= fmapE. Qed.

Definition liftEnv A (m : M A) : MEnv A := fun r => m.

Let retliftEnv : MonadMLaws.ret liftEnv. Proof. by []. Qed.

Let bindliftEnv : MonadMLaws.bind liftEnv. Proof. by []. Qed.

HB.instance Definition envTmonadM := isMonadM_ret_bind.Build
  M [the monad of MEnv] liftEnv retliftEnv bindliftEnv.

End environment_monad_transformer.

Definition envT (E : UU0) := fun M => [the monad of MEnv E M].

HB.instance Definition _ (E : UU0) := isMonadT.Build (envT E)
  (fun M => [the monadM M [the monad of MEnv E M] of @liftEnv E M]).

(* traces monad transformer? *)
Section output_monad_transformer.
Local Obligation Tactic := idtac.
Variables (R : UU0) (M : monad).

Definition MO (X : UU0) := M (X * seq R)%type.

Definition retO : FId ~~> MO := fun (A : UU0) a => Ret (a, [::]).

Definition bindO A B (m : MO A) (f : A -> MO B) : MO B :=
  m >>= (fun o => let: (x, w) := o in f x >>=
  (fun o' => let (x', w') := o' in Ret (x', w ++ w'))).

Let bindOretf : BindLaws.left_neutral bindO retO.
Proof.
move=> A B a f; rewrite /bindO /= bindretf /=.
rewrite (_ : (fun o' : B * seq R => _) = (fun o => Ret o)) ?bindmret //.
by apply funext => -[].
Qed.

Let bindOmret : BindLaws.right_neutral bindO retO.
Proof.
move=> A m; rewrite /bindO /= /retO /= -[RHS]bindmret.
by bind_ext => -[a w]; rewrite bindretf cats0.
Qed.

Let bindOA : BindLaws.associative bindO.
Proof.
move=> A B C m f g; rewrite /bindO /=.
rewrite bindA; bind_ext; case=> x w.
rewrite !bindA; bind_ext; case=> x' w'.
rewrite !bindA bindretf; bind_ext; case=> x'' w''.
by rewrite bindretf catA.
Qed.

HB.instance Definition _ :=
 isMonad_ret_bind.Build MO bindOretf bindOmret bindOA.

Lemma MO_mapE (A B : UU0) (f : A -> B) (m : MO A) :
  ([the functor of MO] # f) m = (M # (fun x => (f x.1, x.2))) m.
Proof.
rewrite [in LHS]/actm /= /bindO /= [in RHS]fmapE.
congr (_ _).
apply funext => -[] ? ?.
by  rewrite bindretf cats0.
Qed.

Definition liftO A (m : M A) : MO A := m >>= (fun x => Ret (x, [::])).

Let retliftO : MonadMLaws.ret liftO.
Proof.
move=> a; rewrite /liftO /= /retO; apply funext => o /=.
by rewrite bindretf.
Qed.

Let bindliftO : MonadMLaws.bind liftO.
Proof.
move=> A B m f; rewrite {1}/liftO.
rewrite !bindE !fmapE /= /join_of_bind /bindO /= 2!joinE !bindA.
bind_ext => a.
rewrite /= !bindretf /liftO bindA.
bind_ext => b.
by rewrite bindretf /= bindretf.
Qed.

HB.instance Definition outputTmonadM := isMonadM_ret_bind.Build
  M [the monad of MO] liftO retliftO bindliftO.

End output_monad_transformer.

Definition outputT (R : UU0) := fun M => [the monad of MO R M].

HB.instance Definition _ (R : UU0) := isMonadT.Build (outputT R)
  (fun M => [the monadM M [the monad of MO R M] of @liftO R M]).

Section continuation_monad_tranformer.
Local Obligation Tactic := idtac.
Variables (r : UU0) (M : monad).

Definition MC : UU0 -> UU0 := fun A => (A -> M r) -> M r %type.

Definition retC : FId ~~> MC := fun (A : UU0) (a : A) k => k a.

Definition bindC A B (m : MC A) f : MC B := fun k => m (f^~ k).

Let bindCretf : BindLaws.left_neutral bindC retC.
Proof. by []. Qed.

Let bindCmret : BindLaws.right_neutral bindC retC.
Proof. by []. Qed.

Let bindCA : BindLaws.associative bindC.
Proof. by []. Qed.

HB.instance Definition _ :=
  isMonad_ret_bind.Build MC bindCretf bindCmret bindCA.

Lemma MC_mapE (A B : UU0) (f : A -> B) (m : MC A) :
  ([the functor of MC] # f) m = fun k : B -> M r => m (k \o f).
Proof. by []. Qed.

Definition liftC A (x : M A) : MC A := fun k => x >>= k.

Let retliftC : MonadMLaws.ret liftC.
Proof.
move => A; rewrite /liftC; apply funext => a /=.
by apply funext => s; rewrite bindretf.
Qed.

Let bindliftC : MonadMLaws.bind liftC.
Proof.
move => A B m f; rewrite /liftC; apply funext => cont.
by rewrite 3!bindA.
Qed.

HB.instance Definition contTmonadM := isMonadM_ret_bind.Build
  M [the monad of MC] liftC retliftC bindliftC.

End continuation_monad_tranformer.

Definition contT (r : UU0) := fun M => [the monad of MC r M].

HB.instance Definition _ (r : UU0) := isMonadT.Build (contT r)
  (fun M => [the monadM M [the monad of MC r M] of @liftC r M]).

Definition abortT r X (M : monad) A : contT r M A := fun _ : A -> M r => Ret X.
Arguments abortT {r} _ {M} {A}.

Section contMonad_of_contT.
Variables (r : UU0) (M : monad).
Let N := MC r M.

Let Callcc (A B : UU0) : ((A -> N B) -> N A) -> N A :=
  fun k f => k (fun a => fun=> f a) f.

Let Callcc0 (A B : UU0) (g : (A -> N B) -> N A) (k : B -> N B) :
  @Callcc _ _ (fun f => g (fun x => f x >>= k)) = @Callcc _ _ g.
Proof. by []. Qed.

Let Callcc1 (A B : UU0) (m : N B) : @Callcc _ _ (fun _ : B -> N A => m) = m.
Proof. by []. Qed.

Let Callcc2 (A B C : UU0) (m : N A) x (k : A -> B -> N C) :
  @Callcc _ _ (fun f : _ -> N _ => m >>= (fun a => f x >>= (fun b => k a b))) =
  @Callcc _ _ (fun f : _ -> N _ => m >> f x).
Proof. by []. Qed.

Let Callcc3 (A B : UU0) (m : N A) b :
  @Callcc _ _ (fun f : B -> N B => m >> f b) = @Callcc _ _ (fun _ : B -> N B => m >> Ret b).
Proof. by []. Qed.

HB.instance Definition _ := @isMonadContinuation.Build
  (MC r M) Callcc Callcc0 Callcc1 Callcc2 Callcc3.

End contMonad_of_contT.

Section continuation_monad_transformer_examples.

Fixpoint for_loop (M : monad) (it min : nat) (body : nat -> contT unit M unit) : M unit :=
  if it <= min then Ret tt
  else if it is it'.+1 then
      (body it') (fun _ => for_loop it' min body)
      else Ret tt.

Section for_loop_lemmas.
Variable M : monad.
Implicit Types body : nat  -> contT unit M unit.

Lemma loop0 i body : for_loop i i body = Ret tt.
Proof.
by case i => //= n; rewrite ltnS leqnn.
Qed.

Lemma loop1 i j body : for_loop (i.+1 + j) i body =
  (body (i + j)) (fun _ => for_loop (i + j) i body).
Proof.
rewrite /=.
by case : ifPn ; rewrite ltnNge leq_addr.
Qed.

Lemma loop2 i j body :
  body (i + j) = abortT tt -> for_loop (i + j).+1 i body = Ret tt.
Proof.
move=> Hbody /=.
case : ifPn => Hcond.
- reflexivity.
- by rewrite Hbody /= /abortT.
Qed.

End for_loop_lemmas.
(* TODO : instantiate with RunStateMonad *)

Definition foreach (M : monad) (items : list nat) (body : nat -> contT unit M unit) : M unit :=
  foldr
    (fun x next => (body x) (fun _ => next))
    (Ret tt)
    items.

(* Lemma loop3 : forall i j body, *)
(*      foreach (i + j).+1 i body = Ret tt -> body (i + j) = @abort_tt m unit. *)
(* Proof. *)
(* move => i j body /=. *)
(* case : ifPn => //; rewrite ltnNge; rewrite leq_addr. *)
(* by []. *)
(* move => _ /= Hfor. *)
(* have Hcont2 : forall cont, body (i + j) = @abort_tt m unit -> body (i + j) cont = Ret tt. *)
(*   (* split. *) *)
(*   rewrite /= /abort_tt /abort. *)
(*   by rewrite funeqE. *)
(* have Hcont1 : (forall cont, body (i + j) cont = Ret tt) -> body (i + j) = @abort_tt m unit.   *)
(*   move => Hcont. *)
(*   rewrite /= /abort_tt /abort. *)
(*   rewrite funeqE => k. *)
(*   exact: Hcont. *)
(* apply Hcont1. *)
(* move => cont. *)
(* rewrite Hcont2 //. *)

(* set bl := (fun _ : unit => foreach (i + j) i body). *)
(* (* Check (fun _ : unit => foreach (i + j) i body). *) *)
(* generalize (Hcont1 bl). *)

(* move => bl. *)
(* Qed *)

Section sum.
Variables M : stateMonad nat.

Let sum n : M unit := for_loop n O
  (fun i : nat => liftC (get >>= (fun z => put (z + i)))).

Lemma sum_test n :
  sum n = get >>= (fun m => put (m + sumn (iota 0 n))).
Proof.
elim: n => [|n ih].
  rewrite /sum.
  rewrite loop0.
  rewrite (_ : sumn (iota 0 0) = 0) //.
  rewrite -[LHS]bindskipf.
  rewrite -getputskip.
  rewrite bindA.
  bind_ext => a.
  rewrite addn0.
  rewrite -[RHS]bindmret.
  bind_ext.
  by case.
rewrite /sum -add1n loop1 /liftC bindA; bind_ext => m.
rewrite -/(sum n) {}ih -bindA.
rewrite putget bindA bindretf putput.
congr put.
by rewrite add0n (addnC 1) iotaD /= sumn_cat /= add0n addn0 /= addnAC addnA.
Qed.

Example sum_from_0_to_10 : M unit :=
  foreach (iota 100 0) (fun i => if i > 90 then
                            abortT tt
                          else
                            liftC (get >>= (fun z => put (z + i)))).

End sum.

End continuation_monad_transformer_examples.

(* laws about lifted fail *)

Lemma bindLfailf (M : failMonad) S :
  BindLaws.left_zero (@bind (stateT S M)) (Lift _ _ ^~ fail).
Proof.
move=> A B g /=; rewrite /liftS; apply funext => s; rewrite bindfailf.
set x := (X in X >>= _ = _).
by rewrite (_ : x = fail) ?bindfailf// /x bindfailf.
Qed.

Lemma bindmLfail (M : failR0Monad) S :
  BindLaws.right_zero (@bind (stateT S M)) (Lift _ _ ^~ fail).
Proof.
move=> A B m /=; rewrite /liftS/=; apply/funext => s; rewrite bindfailf.
set x := (X in _ >>= X = _).
rewrite (_ : x = fun=> fail) ?bindmfail//.
by apply/funext=> -[b s']; rewrite /x/= bindfailf.
Qed.

Section lifting.
Variables (E : functor) (M : monad) (op : E.-operation M)
          (N : monad) (e : monadM M N).
Definition lifting (f : E \o N ~~> N) :=
  forall X : UU0, e X \o op X = f X \o (E # e X).
End lifting.

Section liftingt.
Variables (E : functor) (M : monad) (op : E.-operation M)
          (t : monadT).
Definition lifting_monadT := lifting op (Lift t M).
End liftingt.

Section proposition17.

Section psi.
Variables (E : functor) (M : monad).

Definition psi' (n : E ~~> M) : E \o M ~~> M := fun X => Join \o n (M X).

Lemma natural_psi' (n : E ~> M) : naturality [the functor of E \o M] M (psi' n).
Proof.
move=> A B h; rewrite /psi'.
rewrite -/(Join \o n (M A)) [LHS]compA natural.
by rewrite -compA (natural n).
Qed.

HB.instance Definition _ (n : E ~> M) := isNatural.Build
  [the functor of E \o M] M (psi' n) (natural_psi' n).

Lemma algebraic_psi' (n : E ~> M) : algebraicity (psi' n).
Proof.
move=> A B g t.
rewrite bindE.
rewrite -(compE (M # g)).
rewrite {1}/psi'.
rewrite [in LHS](compA (M # g) Join).
rewrite /=.
rewrite -[in X in _ = Join X]compE.
rewrite -[in RHS](natural n).
transitivity (Join ((M # (Join \o (M # g))) (n (M A) t))); last first.
  rewrite -(compE _ (n (M A)) t).
  congr (Join ((M # _ \o _ ) t)).
  apply funext => ma.
  by rewrite bindE.
rewrite -[in X in Join X = _]compE.
rewrite (natural join).
rewrite functor_o.
rewrite -[in RHS]FCompE.
rewrite -[RHS]compE.
rewrite [in RHS]compA.
by rewrite joinA.
Qed.

HB.instance Definition _ (n : E ~> M) := isAOperation.Build
  E M (psi' n) (algebraic_psi' n).
Definition psi (n : E ~> M) := [the E.-aoperation M of psi' n].

Lemma psiE (n : E ~> M) A : psi n A = Join \o n (M A).
Proof. by []. Qed.

End psi.

Section phi.
Variables (E : functor) (M : monad).

Definition phi' (op : E.-operation M) : E ~~> M := fun X => op X \o (E # Ret).

Lemma natural_phi' (op : E.-operation M) : naturality E M (phi' op).
Proof.
move=> A B h; rewrite /phi'.
rewrite compA.
rewrite (natural op).
rewrite -compA.
rewrite -[in RHS]compA.
congr (_ \o _).
rewrite /=.
rewrite -2!(@functor_o E).
by rewrite (natural ret) FIdE.
Qed.

HB.instance Definition _ (op : E.-operation M) := isNatural.Build
  E M (phi' op) (natural_phi' op).

Definition phi (op : E.-operation M) := [the _ ~> _ of phi' op].

Lemma phiE (op : E.-operation M) (X : UU0) : phi op X = op X \o (E # Ret).
Proof. by []. Qed.

End phi.

Section bijection.
Variables (E : functor) (M : monad).

Lemma psiK (op : E ~> M) : phi (psi op) = op.
Proof.
apply/nattrans_ext => A.
rewrite phiE /= psiE; apply funext => m /=.
rewrite -(compE (op _)) -(natural op) -(compE Join).
by rewrite compA joinMret.
Qed.

Lemma phiK (op : E.-aoperation M) : psi (phi op) = op.
Proof.
apply/aoperation_ext => A.
rewrite /=.
rewrite psiE phiE; apply funext => m /=.
rewrite -(compE (op _)) joinE.
rewrite (algebraic op).
rewrite -(compE (E # _)) -functor_o.
rewrite -(compE (op _)).
set x := _^~ id.
rewrite (_ : x = Join); last first.
  apply funext => mma.
  by rewrite /x bindE functor_id (*TODO: lemma*).
by rewrite joinretM functor_id compfid.
Qed.

End bijection.
End proposition17.

Section uniform_algebraic_lifting.
Variables (E : functor) (M : monad) (op : E.-aoperation M).
Variables (N : monad) (e : monadM M N).

Definition alifting := psi (e \v phi op).

Lemma aliftingE : alifting =
  (fun X => Join \o e (N X) \o phi op (N X)) :> (_ ~~> _).
Proof. by rewrite /alifting/= /vcomp; unlock. Qed.

Theorem uniform_algebraic_lifting : lifting op e alifting.
Proof.
move=> X.
apply funext => Y.
rewrite /alifting.
rewrite [in RHS]/=.
rewrite psiE.
rewrite vcompE.
rewrite phiE.
rewrite !compE.
rewrite (_ : (E # Ret) ((E # e X) Y) =
             (E # (M # e X)) ((E # Ret) Y)); last first.
  rewrite -[in LHS]compE -functor_o.
  rewrite -[in RHS]compE -functor_o.
  by rewrite (natural ret) FIdE.
set x := (Z in Join (e (N X) Z)).
rewrite (_ : x =
             (M # e X) (op (M X) ((E # Ret) Y))); last first.
  rewrite -(compE (M # e X)).
  by rewrite (natural op).
transitivity (e X (Join (op (M X) ((E # Ret) Y)))); last first.
  rewrite joinE.
  rewrite monadMbind.
  rewrite bindE -(compE _ (M # e X)).
  by rewrite -natural.
by rewrite -[in LHS](phiK op).
Qed.
End uniform_algebraic_lifting.

HB.mixin Record isFunctorial (t : monad -> monad) := {
  hmap : forall {M N : monad}, (M ~> N) -> t M ~> t N ;
  functorial_id : forall M : monad,
    hmap [the _ ~> _ of NId M] = [the _ ~> _ of NId (t M)] ;
  functorial_o : forall (M N P : monad) (t : M ~> N) (s : N ~> P),
    hmap (s \v t) = hmap s \v hmap t }.

#[short(type=functorial)]
HB.structure Definition Functorial := {t of isFunctorial t}.
Arguments hmap _ {M N} _.

HB.mixin Record isFMT (t : monad -> monad) of MonadT t & Functorial t := {
  fmt_ret : forall M N (e : monadM M N),
    MonadMLaws.ret (hmap [the functorial of t] e) ;
  fmt_bind : forall M N (e : monadM M N),
    MonadMLaws.bind (hmap [the functorial of t] e) ;
  natural_hmap : forall (M N : monad) (n : M ~> N),
    hmap [the functorial of t] n \v Lift [the monadT of t] M =
    Lift [the monadT of t] N \v n }.

#[short(type=fmt)]
HB.structure Definition FMT := {t of isFMT t & isFunctorial t & isMonadT t}.

Section fmt_lemmas.

Lemma natural_hmapE (t : fmt) (M N : monad) (n : M ~> N) (X : UU0) :
  hmap t n X \o Lift t M X = Lift t N X \o n X.
Proof.
have /nattrans_ext/(_ X)/= := @natural_hmap t M N n.
by rewrite !vcompE.
Qed.

End fmt_lemmas.

Section exceptFMT.
Variable X : UU0.
Let T := [the monadT of exceptT X].
Definition hmapX' (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) t => tau _ t.

Let naturality_hmapX' (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapX' tau).
Proof.
move=> A B h.
by rewrite /hmapX' 2!MX_mapE (natural tau).
Qed.

HB.instance Definition hmapX (F G : monad) (tau : F ~> G) :=
  isNatural.Build (T F) (T G) (hmapX' tau) (naturality_hmapX' tau).

Let hmapX_NId (M : monad) :
  [the _ ~> _ of hmapX' [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply/nattrans_ext => A. Qed.

Let hmapX_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapX' (s \v t)] =
  [the _ ~> _ of hmapX' s] \v [the _ ~> _ of hmapX' t].
Proof.
by apply/nattrans_ext => /= A; rewrite vcompE /= /hmapX'/= vcompE.
Qed.

HB.instance Definition _ := isFunctorial.Build (exceptT X) hmapX_NId hmapX_v.

Let monadMret_hmapX (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapX' e).
Proof.
move=> A; apply funext => /= a.
by rewrite /hmapX' /retX /= -(compE (e _)) monadMret.
Qed.

Let monadMbind_hmapX (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapX' e).
Proof.
move=> A B m f; rewrite /hmapX' /=.
rewrite !bindE /= !MX_mapE /bindX /= !bind_fmap.
rewrite !monadMbind /=.
congr (bind (e (X + A)%type m) _).
apply funext => -[x/=|//].
by rewrite -(compE (e _)) monadMret.
Qed.

Let hmapX_lift :
  let h := fun F G FG => [the _ ~> _ of hmapX' FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A/=; rewrite !vcompE/=.
rewrite /hmapX' /=.
rewrite /liftX /=.
rewrite /retX /=.
apply funext => ma /=.
rewrite (_ : (fun x : A => Ret (inr x)) = Ret \o inr) //.
rewrite -bind_fmap.
rewrite bindmret.
rewrite (_ : (fun x : A => Ret (inr x)) = Ret \o inr) //.
rewrite -bind_fmap.
rewrite bindmret.
rewrite -(compE (N # inr)).
by rewrite (natural t).
Qed.

HB.instance Definition _ := isFMT.Build (exceptT X)
  monadMret_hmapX monadMbind_hmapX  hmapX_lift.

End exceptFMT.

Section Fmt_stateT.
Variable S : UU0.
Let T := [the monadT of stateT S].
Definition hmapS (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) t s => tau _ (t s).

Let naturality_hmapS (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapS tau).
Proof.
move=> A B h.
rewrite /hmapS /=.
have H : forall G, [the monad of stateT S G] # h = [the functor of MS S G] # h by [].
rewrite !H {H}.
apply funext => m /=.
rewrite !MS_mapE.
apply funext => s /=.
rewrite -(compE  _ (tau (A * S)%type)).
by rewrite natural.
Qed.

HB.instance Definition _ (F G : monad) (tau : F ~> G) := isNatural.Build
  (T F) (T G) (hmapS tau) (naturality_hmapS tau).

Let hmapS_NId (M : monad) :
  [the _ ~> _ of hmapS [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply/nattrans_ext. Qed.

Let hmapS_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapS (s \v t)] =
  [the _ ~> _ of hmapS s] \v [the _ ~> _ of hmapS t].
Proof.
by apply/nattrans_ext => A /=; rewrite vcompE/= /hmapS/= vcompE.
Qed.

HB.instance Definition _ := isFunctorial.Build (stateT S) hmapS_NId hmapS_v.

Let monadMret_hmapS (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapS e).
Proof.
move=> A; apply funext => /= a.
rewrite /hmapS /= /retS /=; apply funext => s.
by rewrite [in LHS]curryE monadMret.
Qed.

Let monadMbind_hmapS (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapS e).
Proof.
move=> A B m f.
rewrite /hmapS /=; apply funext => s.
rewrite /= 2!bindE /= !MS_mapE /bindS /= 2!bind_fmap.
by rewrite monadMbind.
Qed.

Let hmapS_lift :
  let h := fun F G FG => [the _ ~> _ of hmapS FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A /=; rewrite !vcompE/=.
rewrite /hmapS /=.
rewrite /liftS /=.
apply funext => ma /=.
apply funext => s /=.
rewrite ![in LHS]bindE ![in LHS]fmapE ![in LHS]bindE.
rewrite 2!(_ : (fun x : A => Ret (x, s)) = Ret \o (fun x => (x, s))) //.
rewrite functor_o.
rewrite -(compE Join (_ \o _)).
rewrite (compA Join (M # _)).
rewrite joinMret.
rewrite compidf.
rewrite functor_o.
rewrite compA.
rewrite joinMret.
rewrite compidf.
rewrite -(compE _ (t A)).
rewrite -(compE (t _)).
rewrite -natural.
rewrite /=.
rewrite ![in RHS]bindE ![in RHS]fmapE ![in RHS]bindE.
rewrite functor_o.
rewrite -(compE Join (_ \o _)).
rewrite (compA Join (N # _)).
rewrite joinMret.
rewrite compidf.
rewrite functor_o.
rewrite compA.
rewrite joinMret.
rewrite compidf.
by rewrite -(compE _ (t A)).
Qed.

HB.instance Definition _ := isFMT.Build (stateT S)
  monadMret_hmapS monadMbind_hmapS hmapS_lift.

End Fmt_stateT.

Section Fmt_envT.
Variable E : UU0.
Let T := [the monadT of envT E].
Definition hmapEnv (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) t s => tau _ (t s).

Let naturality_hmapEnv (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapEnv tau).
Proof.
move=> A B h.
rewrite /hmapEnv.
rewrite /=.
have H : forall G, [the monad of envT E G] # h = [the functor of MEnv E G] # h by [].
rewrite !H {H}.
apply funext => m /=.
rewrite !MEnv_mapE.
apply funext => s /=.
rewrite -(compE  _ (tau A)).
by rewrite natural.
Qed.

HB.instance Definition _ (F G : monad) (tau : F ~> G) :=
  isNatural.Build (T F) (T G) (hmapEnv tau) (naturality_hmapEnv tau).

Let hmapEnv_NId (M : monad) :
  [the _ ~> _ of hmapEnv [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply nattrans_ext. Qed.

Let hmapEnv_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapEnv (s \v t)] =
  [the _ ~> _ of hmapEnv s] \v [the _ ~> _ of hmapEnv t].
Proof. by apply/nattrans_ext => A /=; rewrite vcompE/= /hmapEnv vcompE. Qed.

HB.instance Definition _ := isFunctorial.Build (envT E) hmapEnv_NId hmapEnv_v.

Let monadMret_hmapEnv (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapEnv e).
Proof.
move=> A; apply funext => /= a.
rewrite /hmapEnv /= /retEnv /=; apply funext => s.
by rewrite -[LHS](compE _ Ret) monadMret.
Qed.

Let monadMbind_hmapEnv (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapEnv e).
Proof.
move=> A B m f.
rewrite /hmapEnv /=; apply funext => s.
rewrite /= 2!bindE /= !MEnv_mapE /bindEnv /= 2!bind_fmap.
by rewrite monadMbind.
Qed.

Let hmapEnv_lift :
  let h := fun F G FG => [the _ ~> _ of hmapEnv FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A /=; rewrite !vcompE/=.
by rewrite /hmapEnv/= /liftEnv/=; exact: funext.
Qed.

HB.instance Definition _ := isFMT.Build (envT E)
  monadMret_hmapEnv monadMbind_hmapEnv hmapEnv_lift.

End Fmt_envT.

Section Fmt_outputT.
Variable R : UU0.
Let T := [the monadT of outputT R].
Definition hmapO (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) => tau _.

Let naturality_hmapO (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapO tau).
Proof.
move=> A B h.
rewrite /hmapO.
rewrite /=.
have H : forall G, [the monad of outputT R G] # h = [the functor of MO R G] # h by [].
rewrite !H {H}.
apply funext => m /=; rewrite !MO_mapE.
rewrite -[in LHS](compE  _ (tau _)).
by rewrite natural.
Qed.

HB.instance Definition _ (F G : monad) (tau : F ~> G) :=
  isNatural.Build (T F) (T G) (hmapO tau) (naturality_hmapO tau).

Let hmapO_NId (M : monad) :
  [the _ ~> _ of hmapO [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply nattrans_ext. Qed.

Let hmapO_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapO (s \v t)] =
  [the _ ~> _ of hmapO s] \v [the _ ~> _ of hmapO t].
Proof. by apply/nattrans_ext => A /=; rewrite vcompE/= /hmapO/= vcompE. Qed.

HB.instance Definition _ := isFunctorial.Build (outputT R) hmapO_NId hmapO_v.

Let monadMret_hmapO (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapO e).
Proof.
move=> A; apply funext => /= a; rewrite /hmapO /= /retO /=.
by rewrite -[LHS](compE _ Ret) monadMret.
Qed.

Let monadMbind_hmapO (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapO e).
Proof.
move=> A B m f.
rewrite /hmapO /=.
rewrite 2!bindE /= !MO_mapE /bindO /= 2!bind_fmap.
rewrite !monadMbind.
bind_ext => -[x w].
rewrite /retO /=.
rewrite monadMbind.
bind_ext => /= -[h t] /=.
rewrite -[LHS](compE _ Ret (h, _)).
by rewrite monadMret.
Qed.

Let hmapO_lift :
  let h := fun F G FG => [the _ ~> _ of hmapO FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A /=; rewrite !vcompE/=.
rewrite /hmapO /= /liftO /=.
apply funext => ma /=.
rewrite -!fmapE.
rewrite -(compE _ (t A)).
by rewrite natural.
Qed.

HB.instance Definition _ := isFMT.Build (outputT R)
  monadMret_hmapO monadMbind_hmapO hmapO_lift.

End Fmt_outputT.


(** ** Weak Head Normalisation *)

From Chapter9 Require Export preservation.

Definition E_ {m} (L: tm m -> Prop)  (s : tm m) : Prop :=
  exists v, star step s v /\ L v.

Fixpoint L {m} (A : ty): tm m -> Prop :=
  match A with
  | Base => fun s => exists v, star step s v /\ value v
  | Fun A1 A2 => fun e => match e with
                      | (lam B s) => forall k (xi: fin m -> fin k) v, L A1 v -> E_ (L A2) (subst_tm (scons v (xi >> var_tm)) s)
                      | _ => False
                      end
  end.

Lemma L_ren {m n} s A (xi: fin m -> fin n) :
  L A s -> L A (ren_tm xi s).
Proof.
  revert m n s xi. induction A; eauto; intros m n s xi.
  - intros (?&?&?).
    exists (x⟨xi⟩). split.
    + substify. eauto using mstep_inst.
    + destruct x; eauto.
  - intros.
    destruct s; try contradiction.
    intros k zeta v H''. cbn in H. specialize (H _ (xi >> zeta) _ H'').
    destruct H as (?&?&?).
    exists x. split; eauto. asimpl. eauto.
Qed.

Definition G {m k} (Gamma : ctx m) : (fin m -> tm k)  -> Prop :=
  fun σ => forall (x : fin m), L (Gamma x) (σ x) .

Definition has_ty_sem {m} (Gamma : ctx m) (s: tm m) (A: ty) : Prop :=
  forall k (sigma: fin m -> tm k), G Gamma sigma -> E_ (L A) (subst_tm sigma s).

Lemma val_inclusion {m} A (e: tm m) :
  L A e -> E_ (L A) e.
Proof. intros. unfold E_. exists e. split; eauto. Qed.

Lemma wn_fundamental_lam {m} Gamma (s: tm m) A:
  has_type Gamma s A -> has_ty_sem Gamma s A.
Proof.
  intros C. unfold has_ty_sem, E_. induction C; subst; intros.
  - eauto.
  - apply val_inclusion. asimpl.
    intros m. intros.
    assert (G (S1 .: Gamma) (v .: (sigma >> ren_tm xi))).     { unfold G. intros [|]; cbn; eauto.
      - cbn in *. specialize (H f). now apply L_ren. }
    asimpl.
    specialize (IHC _ _ H1).
    destruct (IHC) as (v'&?&?).
    exists v'; split; eauto.
    revert H2. rewrite rinstInst_tm. eauto using mstep_inst.
  - destruct (IHC1 _ _  H) as (v1&?&?).
    destruct (IHC2  _ _ H) as (v2&?&?).
    destruct v1; try contradiction.
    cbn in H1.
    destruct (H1 _ id _ H3) as (v&?&?).
    exists v; split; eauto. asimpl.
    enough (star step (app  (lam t v1) v2) v).
    + eapply star_trans.
      eapply mstep_app; eauto. assumption.
    + eapply star_trans.
      * eright. econstructor; eauto. constructor.
      * now asimpl in *.
Qed.


Require Import Equivalence EquivDec Eqdep_dec Morphisms.

Require Import LibUtilsCoqLibAdd LibUtilsDigits.

Definition coerce {A B:Type} (pf:A=B) : A -> B.
Proof.
  destruct pf.
  intro a; exact a.
Defined.

Local Existing Instance Equivalence_pullback.

Local Instance EqDec_pullback {A B} (R:A->A->Prop) {eqR:Equivalence R} {decR:EqDec A R} (f:B->A) :
  EqDec B (fun x y : B => R (f x) (f y)).
Proof.
  intros x y.
  destruct (decR (f x) (f y)).
  - left; trivial.
  - right; trivial.
Defined.

Lemma dec_complement {A} {p:A->Prop} (dec_p: forall x, {p x} + {~ p x}) :
  forall x, {~ p x} + {~ ~ p x}.
Proof.
  intros x.
  destruct (dec_p x).
  - right; tauto.
  - left; trivial.
Defined.

Lemma ne_symm {A} (x y : A) : x <> y <-> y <> x.
Proof.
  split; intros.
  * intros Hxy ; symmetry in Hxy ; firstorder.
  * intros Hxy ; symmetry in Hxy ; firstorder.
Qed.

Definition rv_eq {Ts Td:Type} : (Ts -> Td) -> (Ts -> Td) -> Prop
  :=  pointwise_relation Ts eq.

(* This instance is Local, since it is too general *)
Local Instance rv_eq_equiv
         {Ts Td:Type} :
  Equivalence (@rv_eq Ts Td).
Proof.
  typeclasses eauto.
Qed.

Lemma refl_refl {T} {R:T->T->Prop} {refl:Reflexive R} x y : x = y -> R x y.
Proof.
  intros; subst.
  apply refl.
Qed.

Global Instance sigT_eqdec {A} {B:A->Type} (decA:EqDec A eq) (decB:forall x, EqDec (B x) eq) :
  EqDec (sigT B) eq.
Proof.
  intros [x y] [x' y'].
  destruct (decA x x').
  - red in e; subst.
    destruct (decB _ y y').
    + left.
      congruence.
    + right.
      intros HH.
      apply inj_pair2_eq_dec in HH; [| auto].
      congruence.
  - right.
    congruence.
Defined.

Lemma index_pf_irrel n m pf1 pf2 :
  exist (fun n' : nat => (n' < n)%nat) m pf1 = exist (fun n' : nat => (n' < n)%nat) m pf2.
Proof.
  f_equal.
  apply digit_pf_irrel.
Qed.


Inductive InfWisienka (A : Type) : Type :=
| L1 : A -> InfWisienka A
| N1 : forall {B : Type}, (B -> InfWisienka A) -> InfWisienka A.


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

Require Import Relations Morphisms.
Require Import Program.
Require Memory.
Set Implicit Arguments.

Module Make(Import M: Memory.T).

 Inductive term: Type -> Type -> Type :=
  | comp:   forall {X Y Z: Type}, term X Y -> term Y Z -> term X Z
  | tpure:  forall {X Y: Type}, (X -> Y) -> term Y X
  | pair: forall {X Y Z: Type}, term X Z -> term Y Z -> term (X*Y) Z
  | lookup: forall i:Loc, term (Val i) unit
  | update: forall i:Loc, term unit (Val i).

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

 Definition id  {X: Type}     : term X X      := tpure id.
 Definition pi1 {X Y: Type}   : term X (X*Y)  := tpure fst.
 Definition pi2 {X Y: Type}   : term Y (X*Y)  := tpure snd.
 Definition forget {X}        : term unit X   := tpure (fun _ => tt).
 Definition constant {X: Type} (v: X): term X unit := tpure (fun _ => v).

End Make.


(** Coq coding by choukh, July 2022 **)

Require Import Notions Equivalence NatEmbed PartialFunc CT.
Require Import EnumerabilityFacts.

(* 克莱尼的SMN定理 https://en.wikipedia.org/wiki/Smn_theorem *)
Definition SMN (ϕ : ℕ → ℕ → ℕ → ℕ?) := ∃ S : ℕ → ℕ → ℕ,
  ∀ c x y, ϕ (S c x) y ≡{_} ϕ c ⟨x, y⟩.

Definition SMNᵂ (W : ℕ → ℕ → Prop) := ∃ S : ℕ → ℕ → ℕ,
  ∀ c x y, W (S c x) y ↔ W c ⟨x, y⟩.

(* 综合式 (Synthetic) 邱奇论题 *)
Definition SCT := Σ ϕ : ℕ → ℕ → ℕ → ℕ?,
  (∀ c x, 安定 (ϕ c x)) ∧
  ∀ fᵢ : ℕ → ℕ → ℕ, ∃ cᵢ, ∀ i x, ∃ n, ϕ (cᵢ i) x n = Some (fᵢ i x).

Definition SCTᴮ := Σ ϕ : ℕ → ℕ → ℕ → bool?,
  (∀ c x, 安定 (ϕ c x)) ∧
  ∀ fᵢ : ℕ → ℕ → bool, ∃ cᵢ, ∀ i x, ∃ n, ϕ (cᵢ i) x n = Some (fᵢ i x).

(* 综合式EA *)
Definition SEA := Σ ε : ℕ → ℕ → ℕ?,
  ∀ fᵢ : ℕ → ℕ → ℕ?, ∃ cᵢ, ∀ i, ε (cᵢ i) ≡{_} fᵢ i.

Definition SEAᵖₑ (ε : ℕ → ℕ → ℕ?) :=
  ∀ p : ℕ → ℕ → Prop, 参数化可枚举 p → ∃ cᵢ, 参数化枚举器 p (λ i, ε (cᵢ i)).

Definition SEAᵖₑ_uncurry (ε : ℕ → ℕ → ℕ?) :=
  ∀ p : ℕ → ℕ → Prop, 可枚举 (uncurry p) → ∃ cᵢ, 参数化枚举器 p (λ i, ε (cᵢ i)).

Definition SEAᵖ := Σ ε, SEAᵖₑ ε.

(* 综合式EPF *)
Definition SEPF `{偏函数模型} := Σ ε : ℕ → ℕ ⇀ ℕ,
  ∀ fᵢ : ℕ → ℕ ⇀ ℕ, ∃ cᵢ, ∀ i, ε (cᵢ i) ≡{_} fᵢ i.

Definition SEPFᴮ `{偏函数模型} := Σ ε : ℕ → ℕ ⇀ bool,
  ∀ fᵢ : ℕ → ℕ ⇀ bool, ∃ cᵢ, ∀ i, ε (cᵢ i) ≡{_} fᵢ i.

Theorem CT_SMN_to_SCT : (Σ ϕ, CTᵩ ϕ ∧ SMN ϕ) → SCT.
Proof.
  intros [ϕ H]. exists ϕ.
  destruct H as [[sat def] [S SMN]].
  split; auto. intros f.
  destruct (def (λ' ⟨x, y⟩, f x y)) as [c Hc].
  exists (S c). intros. eapply SMN.
  destruct (Hc ⟨i, x⟩). rewrite GF in H. eauto.
Qed.

Theorem SCT_to_CT : SCT → CT.
Proof.
  intros [ϕ [sat def]]. exists ϕ. split.
  - apply sat.
  - intros f. specialize (def (λ _, f)) as [γ H].
    exists (γ 0). intros. eauto.
Qed.

Lemma SEAᵖₑ_iff_SEAᵖₑ_uncurry (ε : ℕ → ℕ → ℕ?) : SEAᵖₑ ε ↔ SEAᵖₑ_uncurry ε.
Proof.
  split; intros H p Hp.
  - eapply 参数化可枚举反柯里化 in Hp; eauto.
  - apply H. eapply 参数化可枚举反柯里化; eauto.
Qed.

Lemma EAᵖ_SMNᵂ_to_SEAᵖₑ (ea : EAᵖ) : let ε := projT1 ea in SMNᵂ (W ε) → SEAᵖₑ ε.
Proof.
  destruct ea as [ε ea]. simpl.
  intros smn. apply SEAᵖₑ_iff_SEAᵖₑ_uncurry.
  intros p Hp. apply 反柯里化可枚举嵌入 in Hp.
  destruct ((proj1 (ea _)) Hp) as [c Hc].
  destruct smn as [S HS]. exists (λ x, S c x).
  intros x y. unfold 枚举器 in Hc. unfold W in HS.
  now rewrite HS, <- Hc, GF.
Qed.


Require Import List.
Require Import cotrans_derived.
Require Import fixpoints.

Set Implicit Arguments.

Inductive item : Set :=
  | atom (n : nat)
  | cons (l r : item).
Inductive inst :=
  | call
  | prim (op : list item -> list item).
Inductive cfg :=
  Cfg : list inst -> list item -> cfg.

Parameter prog : nat -> option (list inst).

Inductive step : cfg -> cfg -> Prop :=
  | prim_step : forall f code stk,
                  step (Cfg (prim f :: code) stk)
                       (Cfg code (f stk))
  | prim_call : forall label env code code' stk,
                  prog label = Some code' ->
                  step (Cfg (call :: code) ((cons (atom label) env) :: stk))
                       (Cfg code' (env :: stk)).

Module CallLanguage <: language.
Definition cfg := cfg.
Definition step := step.
End CallLanguage.

Module F := HoFixpoints CallLanguage.
Import F.
Import F.C.

(*
Definition RRel : Type := cfg -> (cfg -> Prop) -> Prop.
Definition subrel (A B : RRel) : Prop := forall x P, A x P -> B x P.
Definition mono (F : RRel -> RRel) : Prop := forall A B, subrel A B -> subrel (F A) (F B).

Definition weakenable (R : RRel) : Prop :=
  forall (P Q : cfg -> Prop), (forall x, P x -> Q x) ->
     forall x, (R x P -> R x Q).

Definition weakenize (R : RRel) : RRel :=
  fun x P => exists Q, R x Q /\ (forall x, Q x -> P x).

Definition min_ext (P : RRel -> Prop) (F : RRel -> RRel) : Prop :=
  (forall R, P (F R)) /\
  (forall R, subrel R (F R)) /\
  (forall R R', subrel R R' -> P R' -> subrel (F R) R').

Lemma weakenize_good : min_ext weakenable weakenize.
repeat split;firstorder.
Qed.
 *)

Definition proprop (P : RRel -> RRel -> Prop) : Prop :=
  (forall A B, weakenable A -> weakenable B -> subrel A B ->
        (forall X, weakenable X -> P X A -> P X B)
     /\ (forall X, weakenable X -> P B X -> P A X)).

Inductive ty := num | func (a b : ty).

Fixpoint represents (i : item) (t : ty) (N P : RRel) : Prop :=
  match t with
  | num => match i with
           | atom _ => True
           | _ => False
           end
  | func t1 t2 =>
      (forall arg,
         represents arg t1 P N ->
         (forall code stk r,
           P (Cfg (call :: code) (i :: arg :: r :: stk))
             (fun cfg' =>
              match cfg' with
              | Cfg (call :: _) (r' :: v' :: stk') =>
                 r' = r /\ stk' = stk /\
                   represents v' t2 N P
              | _ => False
              end)))
  end.

Definition subweak (X Y : RRel) : Prop :=
  forall (P Q : cfg -> Prop), (forall x, P x -> Q x) -> forall x, X x P -> Y x Q.

Lemma represents_mixed : forall t (A B X Y : RRel),
  subweak A B -> subweak X Y -> forall i, represents i t B X -> represents i t A Y.

induction t;simpl;intros.
tauto.
assert (represents arg t1 X B) by
  (revert H2;apply IHt1;assumption).
specialize (H1 arg H3 code stk r).
revert H1.
apply H0.
destruct x.
destruct l;trivial.
destruct i0;trivial.
destruct l0;trivial.
destruct l0;trivial.
intuition.
revert H6.
apply IHt2;assumption.
Qed.

Lemma represents_happy : forall t i, proprop (represents i t).
unfold proprop;intros. revert i.
induction t.
unfold represents;split;trivial.
split;simpl;intros.
(* Mono in second arg *)
specialize (H3 arg).
apply IHt1 in H4;[|assumption].
specialize (H3 H4 code stk r).
apply H1 in H3.
revert H3.
(* need to weaken B here *) apply H0.
clear IHt1.
destruct x.
destruct l;[tauto|].
destruct i0;[|tauto].
destruct l0;[tauto|].
destruct l0;[tauto|].
intuition.
apply IHt2;assumption.
(* Anti-mono in first *)
specialize (H3 arg).
apply IHt1 in H4;[|assumption].
specialize (H3 H4 code stk r).
revert H3.
apply H2.
clear IHt1.
destruct x.
destruct l;[tauto|].
destruct i0;[|tauto].
destruct l0;[tauto|].
destruct l0;[tauto|].
intuition.
apply IHt2;assumption.
Qed.

Parameter id_addr : nat.
Axiom id_code : prog id_addr =
 Some (prim (fun stk => match stk with
        | _ :: v :: r :: rest => r :: v :: rest
        | _ => stk
        end)
    :: call :: nil).

Inductive id_spec (N P : RRel) : RRel :=
  | id_call : forall v t,
               represents v t N P ->
              forall r code stk (Q : cfg -> Prop),
                (forall cfg',
                    match cfg' with
                   | Cfg (call :: _) (r' :: v' :: stk') =>
                        r' = r /\ stk' = stk /\
                       represents v' t P N
                   | _ => False
                   end -> Q cfg') ->
               id_spec N P (Cfg (call :: code) (cons (atom id_addr) (atom 0) :: v :: r :: stk)) Q.

Lemma id_spec_anti :
  forall A B, weakenable A -> weakenable B -> subrel A B ->
  forall X, weakenable X -> subrel (id_spec B X) (id_spec A X).
intros.  destruct 1.
pose proof (represents_happy t).
apply id_call with t.
revert H3. apply H5;assumption.
intros.
apply H4.
destruct cfg'.
destruct l;[destruct H6|].
destruct i;[|destruct H6].
destruct l0;[destruct H6|].
destruct l0;[destruct H6|].
intuition.
revert H9. apply H5; assumption.
Qed.

Lemma id_spec_mono :
  forall X Y, weakenable X -> weakenable Y -> subrel X Y ->
  forall A, weakenable A -> subrel (id_spec A X) (id_spec A Y).
intros. destruct 1.
apply id_call with t.
revert H3; apply represents_happy;assumption.
intros. apply H4.
destruct cfg'.
destruct l;[exfalso;assumption|].
destruct i;[|exfalso;assumption].
destruct l0;[exfalso;assumption|].
destruct l0;[exfalso;assumption|].
intuition.
revert H8. apply represents_happy;assumption.
Qed.

Definition mixed_weak (F : RRel -> RRel -> RRel) : Prop :=
  forall (S T : RRel),
    (forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, T x P -> S x Q)) ->
  forall (X Y : RRel),
    (forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, X x P -> Y x Q)) ->
    forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       forall x, F S X x P -> F T Y x Q.

(*
Inductive derived (F : RRel -> RRel)
                   (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dleaf : X x P -> derived F X x P
  | ddone : P x -> derived F X x P
  | dstep : forall y, step x y -> derived F X y P -> derived F X x P
  | drule' : forall Q, subrel Q (derived F X) -> F Q x P -> derived F X x P.
Definition drule : forall F R x P, F (derived F R) x P -> derived F R x P :=
  fun _ _ _ _ H => drule' _ _ (fun _ _ H => H) H.

Inductive stepF (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | DoneF : P x -> stepF X x P
  | StepF : forall y, step x y -> X y P -> stepF X x P.
*)

Definition hoproof Rules Spec : Prop :=
     forall (Neg Pos : RRel)
       (Neg_ev : subrel (derived Rules (Spec Neg Pos)) Neg)
       (Pos_ev : subrel Pos (derived Rules (Spec Neg Pos))),
       subrel (Spec Neg Pos) (stepF (derived Rules (Spec Neg Pos))).

(*
Inductive trans_rule (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dtrans : forall (Q : cfg -> Prop), X x Q ->
             (forall y, Q y -> X y P) -> trans_rule X x P.
*)

Lemma stepF_weak : forall R, weakenable R -> weakenable (stepF R).
unfold weakenable. intros. destruct H1; eauto using stepF.
Qed.

Lemma trans_weak : forall R, weakenable R -> weakenable (trans_rule R).
unfold weakenable. intros. destruct H1; eauto using trans_rule.
Qed.

Lemma derived_weak1 : forall F R,
  mono F ->
  weakenable R -> weakenable (derived (fun X => weakenize (F X)) R).
intros F R F_mono R_weak.
unfold weakenable.
induction 2;try solve[eauto using derived].
assert (weakenize (F Q0) x Q) by
  (destruct H2 as [P0 []]; exists P0; eauto).
clear H2.
apply drule.
destruct H3 as [P0 []];exists P0.
split;[|tauto].
apply F_mono in H0.
apply H0.
assumption.
Qed.

Lemma derived_trans_weak : forall R,
  weakenable R ->
  weakenable (derived trans_rule R).
intros.
induction 2;try solve[eauto using derived].
destruct H3.
apply drule.
apply dtrans with Q1.
apply H1. assumption.
intros.
eapply H2.
apply H4. assumption.
assumption.
Qed.

Definition union_rrel (R1 R2 : RRel) : RRel :=
  fun x P => R1 x P \/ R2 x P.

Inductive lfp (F : RRel -> RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  Lfp' : forall Q, subrel Q (lfp F) -> F Q x P -> lfp F x P.
Definition Lfp : forall F, subrel (F (lfp F)) (lfp F) :=
  fun F x P H => Lfp' x P (fun _ _ H => H) H.

CoInductive reaches (x : cfg) (P : cfg -> Prop) : Prop :=
  | Done : P x -> reaches x P
  | Step : forall y, step x y -> reaches y P -> reaches x P
  .

Lemma id_weakenable :
 forall X Y : RRel, weakenable X -> weakenable Y ->
   weakenable (id_spec X Y).
intros; unfold weakenable; intros.
destruct H2.
eapply id_call; eauto.
Qed.

(*
Definition adj_weak (F : RRel -> RRel) : Prop :=
  forall (X Y : RRel),
    (forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       (forall x, X x P -> Y x Q)) ->
    forall (P Q : cfg -> Prop),
       (forall x, P x -> Q x) ->
       forall x, F X x P -> F Y x Q.
 *)

Lemma id_adj : mixed_weak id_spec.
unfold mixed_weak;intros.
fold (subweak T S) in H.
fold (subweak X Y) in H0.

destruct H2.
apply id_call with t.
revert H2.
apply represents_mixed;assumption.

intros;apply H1;apply H3.
destruct cfg'.
destruct l;[tauto|].
destruct i;[|tauto].
destruct l0;[tauto|].
destruct l0;[tauto|].
intuition.

revert H7;apply represents_mixed;assumption.
Qed.

Lemma id_good :
   forall Neg Pos : RRel,
   weakenable Neg -> weakenable Pos ->
   subrel (derived trans_rule (id_spec Neg Pos)) Neg ->
   subrel Pos (derived trans_rule (id_spec Neg Pos)) ->
   subrel (id_spec Neg Pos) (stepF (derived trans_rule (id_spec Neg Pos))).
intros Neg Pos W_Neg W_Pos H_Neg H_Pos.
unfold subrel;intros.
destruct H.
eapply StepF. constructor. exact id_code.
eapply dstep. constructor. simpl.
eapply ddone.

apply H0.
intuition.
assert (subweak Pos Neg) by firstorder.
revert H. apply represents_mixed;assumption.
Qed.

(* Now need to make sure the soundness can carry through if
   we restrict to only "weakenable" instantiations *)

Require Import Morphisms.
Lemma trans_adj_weak : adj_weak trans_rule.
unfold adj_weak, weak_subrel, subpred, Proper, respectful. firstorder.
Qed.

Lemma trans_sound : forall Claims, derived_stable trans_rule Claims -> sound Claims.
intros. apply deri_sound with trans_rule.
  apply validity_from_m. apply trans_mono. apply trans_valid.
  assumption.
Qed.

Definition id_sound_prop' := @higher_order_stability'
  id_spec id_adj
  trans_rule trans_adj_weak trans_valid trans_sound
  id_good.

Lemma id_sound_prop :
 let derived_lfp :=
       fun Neg : RRel =>
       F.lfp (fun A : RRel => derived trans_rule (id_spec Neg A)):RRel in
 let N := F.union_rrel C.reaches (derived_lfp C.reaches) in
 subrel (id_spec N (derived_lfp N)) C.reaches.
Admitted.

(* Seems like the arguments are swapped between the spec and the represents predicate *)
Lemma id_type : forall N P B (H_pf : subrel (id_spec N P) B),
  subweak N B -> forall A, subweak A P -> forall t,
  represents (cons (atom id_addr) (atom 0)) (func t t) A B.
intros.
simpl.
intros.
apply H_pf. apply id_call with t.
eapply represents_mixed;[| |eassumption];assumption.

intros.
destruct cfg'.
repeat match goal with
|[|- match ?c with _ => _ end] => destruct c;try solve[exfalso;assumption];[idtac]
end.
intuition.
eapply represents_mixed;[| |eassumption];assumption.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m2e224p2e192p2e96m1_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import vst.mergesort.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Require Export Coq.Lists.List.
Require Export Coq.Arith.Arith.
Require Import Program.Wf.

Definition my_mergesort_spec : ident * funspec :=
 DECLARE _my_mergesort
 WITH p: val,  sh : share, il: list Z, gv: globals
 PRE [ tptr tuint , tint ]
    PROP (readable_share sh;
          3 < Zlength il <= Int.max_signed)
    PARAMS (p; Vint (Int.repr (Zlength il - 1 )) )
    GLOBALS(gv)
    SEP  (data_at sh (tarray tuint (Zlength il)) (map Vint (map Int.repr il)) p;
          mem_mgr gv)
 POST [ tvoid ]
    PROP ( ) RETURN ()
    SEP (data_at sh (tarray tuint (Zlength il)) (map Vint (map Int.repr il)) p;
         mem_mgr gv).

Definition Gprog : funspecs :=
  ltac:(with_library prog [
             my_mergesort_spec
 ]).

Lemma body_my_mergesort: semax_body Vprog Gprog f_my_mergesort my_mergesort_spec.
Proof.
  start_function.

  assert_PROP (Zlength il = Zlength (map Vint (map Int.repr il))).
  entailer!.
  forward.
  entailer!.
Qed.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition kepler2_bmap_list := [Build_varinfo Tdouble 1%positive (4) (636e-2);Build_varinfo Tdouble 2%positive (4) (636e-2);Build_varinfo Tdouble 3%positive (4) (636e-2);Build_varinfo Tdouble 4%positive (4) (636e-2);Build_varinfo Tdouble 5%positive (4) (636e-2);Build_varinfo Tdouble 6%positive (4) (636e-2)].

Definition kepler2_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list kepler2_bmap_list) in exact z).

Definition kepler2 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) :=
  cast Tdouble (((((((((x1 * x4)%F64 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64 + ((x2 * x5)%F64 * (((((x1 - x2)%F64 + x3)%F64 + x4)%F64 - x5)%F64 + x6)%F64)%F64)%F64 + ((x3 * x6)%F64 * (((((x1 + x2)%F64 - x3)%F64 + x4)%F64 + x5)%F64 - x6)%F64)%F64)%F64 - ((x2 * x3)%F64 * x4)%F64)%F64 - ((x1 * x3)%F64 * x5)%F64)%F64 - ((x1 * x2)%F64 * x6)%F64)%F64 - ((x4 * x5)%F64 * x6)%F64)%F64).

Definition kepler2_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) kepler2 in exact e').

Derive kepler2_b
SuchThat (forall vmap, prove_roundoff_bound kepler2_bmap vmap kepler2_expr kepler2_b)
As kepler2_bound.
Proof.
idtac "Starting kepler2".
time "kepler2" (
try (subst kepler2_b; intro; prove_roundoff_bound);
try (prove_rndval; interval));
try (prove_roundoff_bound2; error_rewrites;
try (field_simplify_Rabs);
try ((prune_terms (cutoff 60));
 do_interval)).
Qed.

Lemma check_kepler2_bound: ltac:(CheckBound kepler2_b 6.2e-12%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import HJ.Tid.
Require Import HJ.Vars.
Require Import HJ.Phasers.Lang.
Require Import Coq.Lists.List.
Require Import Coq.Lists.SetoidList.
Import Regmode.Notations.
Require Import Aniceto.List.

Open Scope reg_scope.
Module Op.
Inductive Valid (pm:phasermap) (t:tid) : op -> Prop :=
  | valid_ph_new:
    forall p,
    PhNewPre p t pm ->
    Valid pm t (PH_NEW p)
  | valid_ph_signal:
    forall p,
    PhSignalPre p t pm ->
    Valid pm t (PH_SIGNAL p)
  | valid_ph_drop:
    forall p,
    PhDropPre p t pm ->
    Valid pm t (PH_DROP p)
  | valid_signal_all:
    Valid pm t SIGNAL_ALL
  | valid_wait_all:
    (forall p ph,
      Map_PHID.MapsTo p ph pm ->
      forall v,
      Map_TID.MapsTo t v ph ->
      wait_phase v < signal_phase v) ->
    Valid pm t WAIT_ALL
  | valid_drop_all:
    Valid pm t DROP_ALL
  | valid_async:
    forall ps,
    AsyncPre ps t pm ->
    Valid pm t (ASYNC ps).

Section Props.
  Ltac handle_not :=
      right; unfold not; intros N; inversion N;
      subst;
      contradiction;
      fail.

  Let valid_wait_all_dec pm t:
    {Valid pm t WAIT_ALL} + {~ Valid pm t WAIT_ALL}.
  Proof.
    assert (valid_lt:forall v, { wait_phase v < signal_phase v } + { ~ wait_phase v < signal_phase v }). {
      auto using Compare_dec.lt_dec.
    }
    remember (List.forallb (fun kv =>
      match Map_TID.find t (snd kv) with
      | Some v => if valid_lt v then true else false
      | None => true
      end
    ) (Map_PHID.elements pm)).
    symmetry in Heqb.
    destruct b. {
      left.
      apply valid_wait_all; intros.
      rewrite forallb_forall in Heqb.
      assert (i: In (p, ph) (Map_PHID.elements pm)). {
        rewrite Map_PHID_Extra.maps_to_iff_in_elements in H; auto using phid_eq_rw.
      }
      specialize Heqb with (p,ph).
      specialize (Heqb i).
      simpl in *.
      destruct (Map_TID_Extra.find_rw t ph) as [(?,N)|(v',(R,?))]. {
        contradiction N.
        eauto using Map_TID_Extra.mapsto_to_in.
      }
      rewrite R in *.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst.
      destruct (valid_lt v); auto.
      inversion Heqb.
    }
    right.
    rewrite forallb_existsb in Heqb.
    rewrite Bool.negb_false_iff in *.
    apply existsb_exists in Heqb.
    unfold not; intros N.
    destruct Heqb as ((p,ph),(Hi,Hx)).
    apply Map_PHID_Extra.maps_to_iff_in_elements in Hi; auto using phid_eq_rw.
    rewrite Bool.negb_true_iff in *.
    simpl in *.
    destruct (Map_TID_Extra.find_rw t ph) as [(R,N1)|(v',(R,?))]; rewrite R in *; clear R. {
      inversion Hx.
    }
    destruct (valid_lt v'). {
      inversion Hx.
    }
    contradiction n.
    inversion N; subst; eauto.
  Defined.

  Lemma valid_dec pm t o :
    { Valid pm t o } + { ~ Valid pm t o }.
  Proof.
    destruct o.
    - destruct (ph_new_pre_dec p t pm); try handle_not.
      auto using valid_ph_new.
    - destruct (ph_signal_pre_dec p t pm); try handle_not.
      auto using valid_ph_signal.
    - destruct (ph_drop_pre_dec p t pm); try handle_not.
      auto using valid_ph_drop.
    - auto using valid_signal_all.
    - auto using valid_wait_all_dec.
    - auto using valid_drop_all.
    - destruct (async_pre_dec p t pm); try handle_not.
      auto using valid_async.
  Defined.
End Props.
End Op.
Section Valid.
Require Import Coq.ZArith.BinInt.
Require Import HJ.Phasers.PhaseDiff.
Require Import HJ.Phasers.TransDiff.

(**
  Our notion of a valid phaser map is such that
  the transitive difference is a function, which means that
  any [t1 - ... - t2] yields the the same difference [z].
*)

Definition Valid (pm:phasermap) := TransDiffFun (pm_diff pm).
End Valid.


Require Export hexamys.

Lemma almost_pappus : hexamy -> forall P S Q O O' A A' X M,
dist6 P O S O' Q M ->
line Q M <> line O S ->
Col O O' S ->
Col M P Q ->
Col A S P ->
Col A O M ->
Col A' S Q ->
Col A' O' M ->
Col X O Q ->
Col X P O' ->
Col X A A'.
Proof.

intros.
unfold dist6 in *.
geo_norm.
create_inter O S Q M Y.
collapse.
remove_line_occ.

not_eq x x0.
not_eq x1 x2.
not_eq x3 x4.

hexamy_proof  P O S O' Q M  P O' M O Q S.

Qed.


Require Export Maximal_Principle.

(** Zermelo Postulate **)

Module Type Zermelo_Postulate.

Declare Module Max : Maximal_Principle.

Definition En_TB B A : Class :=
  \{ λ k, k ⊂ ∪A /\ (forall a, a ∈ (A ~ B) -> a ∩ k = Φ) /\
  (forall a, a ∈ B -> exists x, a ∩ k = [x]) \}.

Definition En_T A : Class :=
  \{ λ k, exists B, B ⊂ A /\ k ∈ (En_TB B A) \}.

Theorem Zermelo : forall A,
  Ensemble A -> Φ ∉ A ->
  (forall x y, x ∈ A /\ y ∈ A -> x ≠ y -> x ∩ y = Φ) ->
  (exists D, Ensemble D /\ (forall B, B ∈ A -> exists x, B ∩ D = [x])).
Proof.
  intros.
  generalize (classic (A = Φ)); intros; destruct H2.
  - rewrite H2 in *; clear H2; exists Φ; split; intros; auto.
    generalize (Theorem16 B); intros; contradiction.
  - assert (Ensemble (En_T A)).
    { apply Axiom_Amalgamation in H; apply Theorem38 in H; auto.
      assert (En_T A ⊂ pow(∪A)).
      { unfold Subclass; intros; apply Axiom_Scheme in H3; destruct H3.
        destruct H4 as [B H4], H4; unfold En_TB in H5.
        apply Axiom_Scheme in H5; destruct H5, H6.
        unfold PowerClass; apply Axiom_Scheme; split; auto. }
      apply Theorem33 in H3; auto. }
    assert (En_T A ≠ Φ).
    { apply Property_NotEmpty in H2; destruct H2.
      generalize (classic (x = Φ)); intros; destruct H4.
      - rewrite H4 in H2; contradiction.
      - apply Property_NotEmpty in H4; destruct H4.
        apply Property_NotEmpty; exists [x0]; unfold En_T.
        AssE x0; apply Theorem42 in H5; auto.
        apply Axiom_Scheme; split; auto; exists [x]; repeat split.
        + unfold Subclass, Singleton; intros; apply Axiom_Scheme in H6.
          destruct H6; rewrite H7; try apply Theorem19; Ens.
        + unfold En_TB; apply Axiom_Scheme; repeat split; auto; intros.
          * unfold Subclass; intros; apply Axiom_Scheme in H6; destruct H6.
            rewrite H7; try apply Theorem19; Ens; apply Axiom_Scheme; Ens.
          * unfold Setminus in H6; apply Theorem4' in H6; destruct H6.
            assert (x ∈ A /\ a ∈ A); auto; apply H1 in H8.
            { generalize (classic (a ∩ [x0] = Φ)); intros; destruct H9; auto.
              apply Property_NotEmpty in H9; destruct H9.
              apply Theorem4' in H9; destruct H9; apply Axiom_Scheme in H10.
              destruct H10; rewrite H11 in *; try apply Theorem19; Ens.
              assert (x0 ∈ (x ∩ a)); try apply Theorem4'; auto.
              rewrite H8 in H12; generalize (Theorem16 x0); contradiction. }
            { intro; rewrite H9 in H7; unfold Complement in H7.
              apply Axiom_Scheme in H7; destruct H7, H10; unfold Singleton.
              apply Axiom_Scheme; split; auto. }
          * exists x0; apply Axiom_Scheme in H6; destruct H6.
            rewrite H7 in *; try apply Theorem19; Ens.
            apply Axiom_Extent; split; intros.
            -- apply Theorem4' in H8; apply H8.
            -- apply Theorem4'; split; auto; apply Axiom_Scheme in H8.
               destruct H8; rewrite H9; try apply Theorem19; Ens. }
    apply Max.MaxPrinciple in H3.
    + destruct H3 as [C H3]; unfold MaxMember in H3.
      apply H3 in H4; clear H3; destruct H4; exists C; split; Ens.
      unfold En_T in H3; apply Axiom_Scheme in H3; destruct H3.
      destruct H5 as [B H5], H5.
      generalize (classic (B = A)); intro; destruct H7.
      * rewrite H7 in H6; apply Axiom_Scheme in H6; apply H6.
      * double H5; apply Property_Φ in H8; assert (A ~ B <> Φ).
        { intro; apply H8 in H9; symmetry in H9; tauto. }
        clear H7 H8; apply Property_NotEmpty in H9; destruct H9.
        unfold Setminus in H7; apply Theorem4' in H7; destruct H7.
        generalize (classic (x = Φ)); intro; destruct H9;
        try (rewrite H9 in H7; contradiction).
        apply Property_NotEmpty in H9; destruct H9.
        assert ((C ∪ [x0]) ∈ (En_T A)).
        { unfold En_T; apply Axiom_Scheme; split.
          - apply Axiom_Union; split; try apply Theorem42; Ens.
          - exists (B ∪ [x]); repeat split.
            + unfold Subclass; intros; apply Theorem4 in H10.
              destruct H10; auto; apply Axiom_Scheme in H10; destruct H10.
              rewrite H11; try apply Theorem19; Ens.
            + apply Axiom_Scheme; repeat split; intros.
              * apply Axiom_Union; split; try apply Theorem42; Ens.
              * unfold Subclass; intros; apply Theorem4 in H10; destruct H10.
                { apply Axiom_Scheme in H6; apply H6 in H10; auto. }
                { apply Axiom_Scheme in H10; destruct H10.
                  rewrite H11; try apply Theorem19; Ens; unfold Element_U.
                  apply Axiom_Scheme; split; Ens. }
              * apply Axiom_Scheme in H6; unfold Setminus in H10.
                apply Theorem4' in H10; destruct H10; rewrite Theorem8.
                apply Axiom_Scheme in H11; destruct H11.
                assert (a ∈ (B ∪ [x]) <-> a ∈ B \/ a ∈ [x]).
                { split; try apply Theorem4. }
                apply definition_not in H13; auto; clear H12.
                apply not_or_and in H13; destruct H13.
                assert (a ∈ (A ~ B)).
                { unfold Setminus; apply Theorem4'; split; auto.
                  unfold Complement; apply Axiom_Scheme; auto. }
                apply H6 in H14; rewrite H14; clear H14.
                assert (x ∈ A /\ a ∈ A); auto; apply H1 in H14.
                { generalize (classic (a ∩ [x0] = Φ)); intros; destruct H15.
                  - rewrite H15; apply Theorem5.
                  - apply Property_NotEmpty in H15; destruct H15.
                    apply Theorem4' in H15; destruct H15.
                    apply Axiom_Scheme in H16; destruct H16.
                    rewrite H17 in *; try apply Theorem19; Ens.
                    assert (x0 ∈ (x ∩ a)); try apply Theorem4'; auto.
                    rewrite H14 in H18; destruct (Theorem16 _ H18). }
                { intro; rewrite H15 in H13; destruct H13; unfold Singleton.
                  apply Axiom_Scheme; split; auto. }
              * apply Axiom_Scheme in H6; rewrite Theorem8.
                apply Theorem4 in H10; destruct H10.
                { double H10; apply H6 in H11; destruct H11; rewrite H11.
                  clear H11; assert (x ∈ A /\ a ∈ A); auto; apply H1 in H11.
                  - generalize (classic (a ∩ [x0] = Φ)); intros; destruct H12.
                    + rewrite H12; rewrite Theorem6, Theorem17; Ens.
                    + apply Property_NotEmpty in H12; destruct H12.
                      apply Theorem4' in H12; destruct H12.
                      apply Axiom_Scheme in H13; destruct H13.
                      rewrite H14 in *; try apply Theorem19; Ens.
                      assert (x0 ∈ (x ∩ a)); try apply Theorem4'; auto.
                      rewrite H11 in H15; destruct (Theorem16 _ H15).
                  - intro; rewrite <- H12 in H10; unfold Complement in H8.
                    apply Axiom_Scheme in H8; destruct H8; contradiction. }
                { apply Axiom_Scheme in H10; destruct H10.
                  rewrite H11; try apply Theorem19; Ens; clear H10 H11 a.
                  assert (x ∈ (A ~ B)); try apply Theorem4'; auto.
                  apply H6 in H10; rewrite H10, Theorem17; exists x0.
                  apply Axiom_Extent; split; intros.
                  - apply Theorem4' in H11; apply H11.
                  - apply Theorem4'; split; auto; apply Axiom_Scheme in H11.
                    destruct H11; rewrite H12; try apply Theorem19; Ens. } }
        apply H4 in H10; destruct H10; unfold ProperSubclass.
        split; unfold Subclass; intros; try (apply Theorem4; auto).
        apply Axiom_Scheme in H6.
        assert (x ∈ (A ~ B)); try apply Theorem4'; auto.
        apply H6 in H10; intro; assert (x0 ∈ Φ).
        { rewrite <- H10; apply Theorem4'; split; auto; rewrite H11.
          apply Theorem4; right; apply Axiom_Scheme; split; Ens. }
        generalize (Theorem16 x0); intros; contradiction.
    + intros; exists (∪n); split; intros.
      * apply Property_FinChar in H5; auto; split; auto; clear H6.
        destruct H5; unfold Finite_Character; repeat split; auto.
        { intros F H7 F1 H8; destruct H8; unfold En_T in H7.
          apply Axiom_Scheme in H7; destruct H7, H10 as [B H10], H10.
          unfold En_T; apply Axiom_Scheme; assert (Ensemble F1).
          { apply Theorem33 in H8; auto. }
          split; auto; unfold En_TB in H11; apply Axiom_Scheme in H11.
          destruct H11 as [_ H11], H11.
          exists \{ λ a, a ∈ B /\ exists x, a ∩ F1 = [x] \}; repeat split.
          - red; intros; apply Axiom_Scheme in H14; destruct H14, H15.
            apply H10 in H15; auto.
          - apply Axiom_Scheme; repeat split; auto; intros.
            + apply Theorem28 with (y:= F); split; auto.
            + apply Theorem4' in H14; destruct H14; apply Axiom_Scheme in H15.
              destruct H15 as [_ H15]; unfold NotIn in H15.
              apply definition_not with (B:= Ensemble a /\ a∈B /\
              (exists x, a ∩ F1 = [x])) in H15.
              * apply not_and_or in H15; destruct H15.
                { destruct H15; Ens. }
                { apply not_and_or in H15; destruct H15.
                  - assert (a ∈ (A ~ B)).
                    { unfold Setminus; apply Theorem4'; split; auto.
                      unfold Complement; apply Axiom_Scheme; split; Ens. }
                    apply H13 in H16; apply Theorem27;split;try apply Theorem26.
                    rewrite <- H16; unfold Subclass; intros.
                    apply Theorem4' in H17; apply Theorem4'; destruct H17; Ens.
                  - generalize (classic (a ∈ B)); intros; destruct H16.
                    + apply H13 in H16; destruct H16.
                      apply not_ex_all_not with (n:= x) in H15.
                      generalize (classic (a∩F1=Φ)); intros; destruct H17; auto.
                      apply Property_NotEmpty in H17; destruct H17 as [z H17].
                      assert ((a ∩ F1) ⊂ [x]).
                      { unfold Subclass; intros; rewrite <- H16.
                        apply Theorem4' in H18; apply Theorem4'; destruct H18.
                        split; auto. }
                      double H17; apply H18 in H19; unfold Singleton in H19.
                      apply Axiom_Scheme in H19; destruct H19.
                      assert ([x] ⊂ (a ∩ F1)).
                      { unfold Subclass; intros; unfold Singleton in H21.
                        apply Axiom_Scheme in H21; destruct H21.
                        assert (Ensemble x).
                        { apply Theorem42'; rewrite <- H16.
                          apply Theorem33 with (x:= a); Ens; unfold Subclass.
                          intros; apply Theorem4' in H23; apply H23. }
                        rewrite H22, <- H20; try apply Theorem19; Ens. }
                      assert ((a ∩ F1) ⊂ [x] /\ [x] ⊂ (a ∩ F1)); auto.
                      apply Theorem27 in H22; rewrite H22 in H15; tauto.
                    + assert (a ∈ (A ~ B)).
                      { unfold Setminus; apply Theorem4'; split; auto.
                        unfold Complement; apply Axiom_Scheme; split; Ens. }
                      apply H13 in H17; apply Theorem27.
                      split; try apply Theorem26; rewrite <- H17.
                      unfold Subclass; intros; apply Theorem4' in H18.
                      apply Theorem4'; destruct H18; Ens. }
              * split; intros; try apply Axiom_Scheme in H16; try apply Axiom_Scheme; Ens.
            + apply Axiom_Scheme in H14; apply H14. }
        { intros; destruct H7.
          generalize (classic (F ∈ (En_T A))); intros; destruct H9; auto.
          assert (forall B, B ⊂ A -> ~ F ∈ (En_TB B A)).
          { intros; unfold En_T in H9.
            apply definition_not with (B:= Ensemble F /\ exists B, B ⊂ A /\
            F ∈ (En_TB B A)) in H9.
            - apply not_and_or in H9; destruct H9; try tauto.
              apply not_ex_all_not with (n:= B) in H9.
              apply not_and_or in H9; tauto.
            - split; intros; try apply Axiom_Scheme; auto.
              apply Axiom_Scheme in H11; apply H11. }
          set (B:= \{ λ a, a ∈ A /\ a ∩ F <> Φ /\ ~ (exists x, a ∩ F = [x]) \}
            ∪ \{ λ a, a ∈ A /\ a ∩ F <> Φ /\ (exists x, a ∩ F = [x]) \}).
          assert (B ⊂ A).
          { unfold Subclass; intros; apply Theorem4 in H11.
            destruct H11; apply Axiom_Scheme in H11; apply H11. }
          apply H10 in H11; unfold En_TB in H11.
          apply definition_not with (B:= Ensemble F /\ F ⊂ ∪ A /\ (forall a,
          a ∈ (A ~ B) -> a ∩ F = Φ) /\ (forall a, a ∈ B -> exists x,
          a ∩ F = [x])) in H11.
          - apply not_and_or in H11; destruct H11; try tauto.
            apply not_and_or in H11; destruct H11.
            + assert (forall z, z ⊂ F /\ Finite z -> z ⊂ ∪ A).
              { intros; apply H8 in H12; unfold En_T in H12.
                apply Axiom_Scheme in H12; destruct H12, H13, H13.
                unfold En_TB in H14; apply Axiom_Scheme in H14; apply H14. }
              destruct H11; unfold Subclass; intros.
              assert ([z] ⊂ F /\ Finite ([z])).
              { split; try apply Finite_Single; Ens; unfold Subclass; intros.
                unfold Singleton in H13; apply Axiom_Scheme in H13; destruct H13.
                rewrite H14; try apply Theorem19; Ens. }
              apply H12 in H13; apply H13; unfold Singleton.
              apply Axiom_Scheme; split; Ens.
            + apply not_and_or in H11; destruct H11.
              * apply not_all_ex_not in H11; destruct H11 as [a H11].
                apply imply_to_and in H11; destruct H11.
                unfold Setminus in H11; apply Theorem4' in H11; destruct H11.
                apply Axiom_Scheme in H13; destruct H13.
                unfold NotIn in H14; apply definition_not with (B:= a ∈
                \{λ a, a∈A /\ a ∩ F <> Φ /\ ~ (exists x, a ∩ F = [x])\} \/
                a ∈ \{ λ a, a ∈ A /\ a ∩ F <> Φ /\ (exists x, a ∩ F = [x]) \})
                in H14.
                { apply not_or_and in H14; destruct H14.
                  apply definition_not with (B:= Ensemble a /\ a ∈ A /\
                  a ∩ F <> Φ /\ ~ (exists x, a ∩ F = [x])) in H14.
                  - apply definition_not with (B:= Ensemble a /\ a ∈ A /\
                    a ∩ F <> Φ /\ (exists x, a ∩ F = [x])) in H15; try tauto.
                    split; intros; try apply Axiom_Scheme; auto.
                    apply Axiom_Scheme in H16; auto.
                  - split; intros; try apply Axiom_Scheme; auto.
                    apply Axiom_Scheme in H16; auto. }
                { split; intros; try apply Theorem4; auto. }
              * apply not_all_ex_not in H11; destruct H11 as [a H11].
                apply imply_to_and in H11; destruct H11.
                apply Theorem4 in H11; destruct H11.
                { apply Axiom_Scheme in H11; clear B H12; destruct H11,H12,H13.
                  assert (~ (forall x y, x ∈ (a ∩ F) /\ y ∈ (a ∩ F) -> x = y)).
                  { intro; apply Property_NotEmpty in H13; destruct H13, H14.
                    exists x; apply Axiom_Extent; split; intros.
                    - add (x ∈ (a ∩ F)) H14; apply H15 in H14; rewrite H14.
                      unfold Singleton; apply Axiom_Scheme; Ens.
                    - unfold Singleton in H14; apply Axiom_Scheme in H14.
                      destruct H14; rewrite H16; try apply Theorem19; Ens. }
                  destruct H15; intros; destruct H15.
                  generalize (classic (x = y)); intros; destruct H17; auto.
                  apply Theorem4' in H15; apply Theorem4' in H16.
                  destruct H15, H16.
                  assert ([x|y] ⊂ F /\ Finite ([x|y])).
                  { split.
                    - unfold Subclass; intros; apply Theorem46 in H20; Ens.
                      destruct H20; rewrite H20; auto.
                    - unfold Unordered; apply Theorem168.
                      split; apply Finite_Single; Ens. }
                  apply H8 in H20; apply Axiom_Scheme in H20.
                  destruct H20, H21 as [B H21], H21; unfold En_TB in H22.
                  apply Axiom_Scheme in H22; destruct H22, H23.
                  generalize (classic (a ∈ B)); intros; destruct H25.
                  - apply H24 in H25; destruct H25.
                    assert ([x | y] ⊂ a).
                    { unfold Subclass; intros; apply Theorem46 in H26; Ens.
                      destruct H26; rewrite H26; auto. }
                    apply Theorem30 in H26; rewrite Theorem6' in H26.
                    rewrite H26 in H25; clear H26; destruct H17.
                    assert (x ∈ [x0] /\ y ∈ [x0]).
                    { rewrite <- H25; split; apply Theorem46; Ens. }
                    destruct H17; apply Axiom_Scheme in H17.
                    apply Axiom_Scheme in H26; destruct H17, H26.
                    assert (x0 ∈ μ).
                    { apply Theorem19; apply Theorem42'; rewrite <- H25.
                      apply Theorem46; Ens. }
                    rewrite H27, H28; auto.
                  - assert (a ∈ (A ~ B)).
                    { unfold Setminus; apply Theorem4'; split; auto.
                      unfold Complement; apply Axiom_Scheme; split; Ens. }
                    apply H24 in H26. clear H24.
                    assert ([x | y] ⊂ a).
                    { unfold Subclass; intros; apply Theorem46 in H24; Ens.
                      destruct H24; rewrite H24; auto. }
                    apply Theorem30 in H24; rewrite Theorem6' in H24.
                    rewrite H24 in H26; clear H24.
                    assert (x ∈ Φ). { rewrite <- H26; apply Theorem46; Ens. }
                    generalize (Theorem16 x); intros; contradiction. }
                { apply Axiom_Scheme in H11; destruct H11, H13, H14; tauto. }
          - split; intros; try apply Axiom_Scheme;
            try apply Axiom_Scheme in H12; auto. }
      * unfold Subclass; intros; apply Axiom_Scheme; split; Ens.
Qed.

Hint Resolve Zermelo : Axiom_of_Choice.

End Zermelo_Postulate.


Require Import Coq.Arith.Arith.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EnumEnsembles.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.MathGraph.
Require Import CertiGraph.graph.FiniteGraph.
Require Import CertiGraph.graph.reachable_computable.
Require Import Coq.Lists.List.

Section LIST_MODEL.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Variable G : PreGraph Vertex Edge.

  Definition is_list (x: Vertex) : Prop :=
    exists p, valid_path G p /\ forall y, reachable G x y -> exists (py: path), unique (fun pa => G |= pa is x ~o~> y satisfying (fun _ => True)) py /\ Subpath G py p.

  Definition graph_list_isomorphism (l: list Vertex) (root: Vertex) : Prop :=
    (forall s d, reachable G root s /\ reachable G root d /\ G |= s ~> d <-> exists l1 l2, l = l1 ++ s :: d :: l2) /\ (forall v, reachable G root v <-> In v l) /\ NoDup l.

  Context {is_null: DecidablePred Vertex}.
  Context {MA: MathGraph G is_null}.
  Context {LF: LocalFiniteGraph G}.

  Lemma list_expand_nil_or_single: forall root l r,
      vvalid G root -> is_list root -> l = @new_working_list _ _ is_null nil (map (dst G) (edge_func G root)) (root :: r) -> l = nil \/ (exists v, l = v :: nil /\ G |= root ~> v).
  Proof.
    intros. destruct l. 1: left; auto. destruct l.
    + right. exists v; split; auto. assert (In v (v :: nil)) by apply in_eq. rewrite H1 in H2. rewrite in_new_working_list in H2. destruct H2 as [? [? ?]].
      rewrite app_nil_l in H2. rewrite <- edge_func_step in H2. split; [|split]; auto. rewrite step_spec in H2. destruct H2 as [e [? [? ?]]].
      destruct (valid_graph G e H2) as [_ ?]. hnf in H7. rewrite H6 in H7. destruct H7; [exfalso |]; auto.
    + exfalso. destruct LF in H1. unfold edge_func in H1. simpl in H1. destruct (local_enumerable root) as [l' [? ?]].
      simpl in H1. unfold Ensembles.In in i. destruct H0 as [lf [? ?]].
      assert (forall v', In v' (v :: v0 :: l) -> reachable G root v'). {
        intros. rewrite H1 in H3. rewrite in_new_working_list in H3. rewrite app_nil_l in H3. destruct H3 as [? [? ?]].
        rewrite in_map_iff in H3. destruct H3 as [e [? ?]]. exists (root, e :: nil). split; split; simpl; auto.
        + rewrite i in H6. destruct H6. unfold strong_evalid. rewrite H7. rewrite H3. do 3 (split; auto).
          destruct (valid_graph G e H6) as [_ ?]. hnf in H8. rewrite H3 in H8. destruct H8; [exfalso | ]; auto.
        + hnf. rewrite Forall_forall. intros; auto.
      } unfold new_working_list in H1. symmetry in H1. apply filter_2_cons in H1. destruct H1 as [l1 [l2 [l3 [? [? [? [? [? ?]]]]]]]]. simpl in H1. apply map_2_mid in H1.
      destruct H1 as [y1 [y2 [m1 [m2 [m3 [? [? [? [? [? ?]]]]]]]]]]. rewrite H1 in n. apply NoDup_app_r in n. apply NoDup_cons_2 in n.
      assert (reachable G root v) by apply H3, in_eq. assert (reachable G root v0) by apply H3, in_cons, in_eq. apply H2 in H14. apply H2 in H15.
      destruct H14 as [pv [[? ?] ?]]. destruct H15 as [pv0 [[? ?] ?]].
      assert (G |= (root, y1 :: nil) is root ~o~> v satisfying (fun _ => True)). {
        split; split; intros; auto. 2: hnf; rewrite Forall_forall; intros; auto. simpl. unfold strong_evalid. rewrite H12.
        assert (In y1 l') by (rewrite H1; rewrite in_app_iff; right; apply in_eq). rewrite i in H20. destruct H20. rewrite H21.
        apply reachable_by_path_is_reachable in H14. apply reachable_foot_valid in H14. split; auto.
      } pose proof (H16 _ H20).
      assert (G |= (root, y2 :: nil) is root ~o~> v0 satisfying (fun _ => True)). {
        split; split; intros; auto. 2: hnf; rewrite Forall_forall; intros; auto. simpl. unfold strong_evalid. rewrite H13.
        assert (In y2 l') by (rewrite H1; rewrite in_app_iff; right; right; rewrite in_app_iff; right; apply in_eq). rewrite i in H22. destruct H22. rewrite H23.
        apply reachable_by_path_is_reachable in H15. apply reachable_foot_valid in H15. split; auto.
      } pose proof (H18 _ H22). apply n. rewrite in_app_iff. right.
      assert (In_path G v lf) by (apply (In_path_Subpath _ pv); auto; rewrite H21, <- H12; right; exists y1; simpl; tauto).
      assert (In_path G v0 lf) by (apply (In_path_Subpath _ pv0); auto; rewrite H23, <- H13; right; exists y2; simpl; tauto).
      pose proof (valid_path_reachable _ _ _ _ H0 H24 H25). destruct H26; destruct H26 as [[vl pl] ?].
      - assert (G |= (path_glue (root, y1 :: nil) (vl, pl)) is root ~o~> v0 satisfying (fun _ => True)) by (apply reachable_by_path_merge with v; auto).
        unfold path_glue, fst, snd in H27. rewrite <- app_comm_cons, app_nil_l in H27. apply H18 in H27. rewrite H23 in H27. inversion H27. apply in_eq.
      - assert (G |= (path_glue (root, y2 :: nil) (vl, pl)) is root ~o~> v satisfying (fun _ => True)) by (apply reachable_by_path_merge with v0; auto).
        unfold path_glue, fst, snd in H27. rewrite <- app_comm_cons, app_nil_l in H27. apply H16 in H27. rewrite H21 in H27. inversion H27. apply in_eq.
  Qed.

  (* Print Assumptions list_expand_nil_or_single. *)

  Definition list_composed_by_edges (l: list Vertex) : Prop := forall l1 l2 s d, l = l1 ++ s :: d :: l2 -> G |= s ~> d.

  Lemma list_composed_by_edges_nil: list_composed_by_edges nil.
  Proof. repeat intro. assert (@length Vertex nil = length (l1 ++ s :: d :: l2)) by (rewrite H; tauto). rewrite app_length in H0; simpl in H0. intuition. Qed.

  Lemma list_composed_by_edges_single: forall v, list_composed_by_edges (v :: nil).
  Proof.
    repeat intro. exfalso. assert (length (v :: nil) = length (l1 ++ s :: d :: l2)) by (rewrite H; tauto). rewrite app_length in H0. simpl in H0. intuition.
  Qed.

  Lemma lcbe_rev_cons: forall v l, list_composed_by_edges (rev (v :: l)) -> list_composed_by_edges (rev l).
  Proof.
    intros. rewrite <- (app_nil_l l), app_comm_cons, rev_app_distr in H. simpl in H. unfold list_composed_by_edges in *. intros.
    specialize (H l1 (l2 +:: v) s d). apply H. rewrite H0. rewrite <- app_assoc. simpl. auto.
  Qed.

  Lemma lcbe_rev_cons_inv: forall v root l, G |= root ~> v -> list_composed_by_edges (rev (root :: l)) -> list_composed_by_edges (rev (v :: root :: l)).
  Proof.
    intros. rewrite <- (app_nil_l (root :: l)), app_comm_cons, rev_app_distr. simpl rev at 2. unfold list_composed_by_edges in *. intros. destruct l2.
    + simpl in H1. rewrite <- (app_nil_l (d :: nil)), (app_comm_cons nil (d :: nil) s) in H1. rewrite app_assoc in H1.
      do 2 (apply app_inj_tail in H1; destruct H1). subst. auto.
    + assert (v0 :: l2 <> nil) by (intro; inversion H2). apply exists_last in H2. destruct H2 as [l' [a ?]]. rewrite e in H1.
      rewrite app_comm_cons, (app_comm_cons (d :: l') (a :: nil) s), app_assoc in H1. apply app_inj_tail in H1. destruct H1. apply (H0 l1 l'); auto.
  Qed.

  Lemma is_list_edge: forall root v, G |= root ~> v -> is_list root -> is_list v.
  Proof.
    intros. unfold is_list in *. destruct H0 as [p [? ?]]. exists p. split; auto. intros.
    destruct H2 as [[v' pv] ?]. assert (v' = v) by (destruct H2 as [[? _] _]; simpl in H2; auto). subst v'. destruct H as [? [? ?]]. rewrite step_spec in H4.
    destruct H4 as [e [? [? ?]]].
    assert (forall pp, G |= pp is v ~o~> y satisfying (fun _ => True) -> G |= (path_glue (root, e :: nil) pp) is root ~o~> y satisfying (fun _ => True)). {
      intros. apply reachable_by_path_merge with v; auto. split; split; simpl; auto.
      + unfold strong_evalid. rewrite H5, H6. split; auto.
      + hnf. rewrite Forall_forall. intros; auto.
    }
    pose proof (H7 _ H2). unfold path_glue, fst, snd in H8. rewrite <- app_comm_cons, app_nil_l in H8. pose proof (reachable_by_path_is_reachable _ _ _ _ _ H8).
    apply H1 in H9. clear H1. destruct H9 as [py [[? ?] ?]]. pose proof (H9 _ H8). exists (v, pv). split; split; auto.
    + intros. specialize (H7 _ H12). destruct x' as [x px]. assert (x = v) by (destruct H12 as [[? _] _]; simpl in H12; auto). subst x.
      unfold path_glue, fst, snd in H7. rewrite <- app_comm_cons, app_nil_l in H7. specialize (H9 _ H7). rewrite H9 in H11. inversion H11. auto.
    + simpl. destruct H10. subst py. simpl in *. clear -H10. unfold incl in *. intros. apply H10. right; auto.
    + simpl. destruct H10. subst py. simpl in *. unfold In_path. clear -H6 H10. right. exists e. split; intuition.
  Qed.

  Lemma construct_reachable_edge:
    forall lim root r, vvalid G root -> is_list root -> list_composed_by_edges (rev (root :: r)) -> list_composed_by_edges (rev (@construct_reachable _ _ _ _ G is_null _ (lim, root :: nil, r))).
  Proof.
    intros lim root r. remember (lengthInput (lim, root :: nil, r)) as n. assert (lengthInput (lim, root :: nil, r) <= n) by intuition. clear Heqn.
    revert n lim root r H. induction n; intros.
    + simpl in H. rewrite construct_reachable_unfold. destruct (le_dec lim (length r)); [apply (lcbe_rev_cons root) | exfalso]; intuition.
    + rewrite construct_reachable_unfold. unfold lengthInput in H, IHn. destruct (le_dec lim (length r)). 1: apply (lcbe_rev_cons root); auto.
      remember (@new_working_list _ _ is_null nil (map (dst G) (edge_func G root)) (root :: r)).
      assert (l = nil \/ exists v, l = (v :: nil) /\ G |= root ~> v) by (apply (list_expand_nil_or_single _ _ r); auto). destruct H3.
      - clear Heql. subst l. simpl. rewrite construct_reachable_unfold. auto.
      - destruct H3 as [v [? ?]]. rewrite H3. simpl. apply IHn.
        * simpl. clear - H n0. intuition.
        * hnf in H4. intuition.
        * apply (is_list_edge root); auto.
        * apply lcbe_rev_cons_inv; auto.
  Qed.

  Lemma is_list_no_self_loop: forall root s, vvalid G root -> is_list root -> reachable G root s -> G |= s ~> s -> False.
  Proof.
    intros. destruct H2 as [? [? ?]]. rewrite step_spec in H4. destruct H4 as [e [? [? ?]]].
    assert (G |= (s, e :: nil) is s ~o~> s satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H5, H6. split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    } destruct H0 as [pf [? ?]]. apply H8 in H1. clear H8. destruct H1 as [ps [[? ?] ?]]. destruct ps as [v ps].
    assert (v = root) by (destruct H1 as [[? _] _]; simpl in H1; auto). subst v. pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H7). unfold path_glue, fst, snd in H10.
    apply H8 in H10. inversion H10. pose proof (f_equal (@length Edge) H12). rewrite app_length in H11. simpl in H11. intuition.
  Qed.

  Lemma is_list_edge_dst_the_same: forall root s d v, vvalid G root -> is_list root -> reachable G root s -> G |= s ~> d -> G |= s ~> v -> d = v.
  Proof.
    intros. assert (reachable G root d) by (apply reachable_edge with s; auto). assert (reachable G root v) by (apply reachable_edge with s; auto).
    destruct H0 as [pf [? ?]]. apply H6 in H4. destruct H4 as [pd [[? ?] ?]]. apply H6 in H5. destruct H5 as [pv [[? ?] ?]].
    assert (In_path G v pf) by (apply In_path_Subpath with pv; auto; destruct H5 as [[_ ?] _]; apply pfoot_in; auto).
    assert (In_path G d pf) by (apply In_path_Subpath with pd; auto; destruct H4 as [[_ ?] _]; apply pfoot_in; auto).
    pose proof (valid_path_reachable _ _ _ _ H0 H11 H12). clear H8 H10 H11 H12. destruct H2 as [? [? ?]]. rewrite step_spec in H10. destruct H10 as [ed [? [? ?]]].
    destruct H3 as [? [? ?]]. rewrite step_spec in H15. destruct H15 as [ev [? [? ?]]]. destruct H1 as [ps ?].
    assert (G |= (s, ed :: nil) is s ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H11, H12; split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    }
    assert (G |= (s, ev :: nil) is s ~o~> v satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H16, H17; split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    } destruct ps as [vs ps]. assert (vs = root) by (destruct H1 as [[? _] _]; simpl in H1; auto). subst vs.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H18). unfold path_glue, fst, snd in H20.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H19). unfold path_glue, fst, snd in H21. clear H4 H5. pose proof (H7 _ H20). pose proof (H9 _ H21). destruct H13.
    + destruct H13 as [[v' pv'] ?]. assert (v' = v) by (destruct H13 as [[? _] _]; simpl in H13; auto). subst v'.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H21 H13). unfold path_glue, fst, snd in H22. apply H7 in H22. rewrite H4 in H22. inversion H22.
      pose proof (f_equal (@length Edge) H24). rewrite !app_length in H23. simpl in H23. assert (length pv' = 0) by intuition. destruct pv'. 2: inversion H25.
      clear H23 H25. rewrite app_nil_r in H24. apply app_inj_tail in H24. destruct H24. subst ed. rewrite H12 in H17. auto.
    + destruct H13 as [[d' pd'] ?]. assert (d' = d) by (destruct H13 as [[? _] _]; simpl in H13; auto). subst d'.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H20 H13). unfold path_glue, fst, snd in H22. apply H9 in H22. rewrite H5 in H22. inversion H22.
      pose proof (f_equal (@length Edge) H24). rewrite !app_length in H23. simpl in H23. assert (length pd' = 0) by intuition. destruct pd'. 2: inversion H25.
      clear H23 H25. rewrite app_nil_r in H24. apply app_inj_tail in H24. destruct H24. subst ed. rewrite H12 in H17. auto.
  Qed.

  Lemma is_list_edge_src_the_same: forall root s d v, vvalid G root -> is_list root -> reachable G root s -> reachable G root v -> G |= s ~> d -> G |= v ~> d -> s = v.
  Proof.
    intros. destruct H3 as [? [? ?]]. rewrite step_spec in H6. destruct H6 as [es [? [? ?]]]. destruct H4 as [? [? ?]]. rewrite step_spec in H10. destruct H10 as [ev [? [? ?]]].
    assert (G |= (s, es :: nil) is s ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto; [unfold strong_evalid; rewrite H7, H8; split; auto | hnf; rewrite Forall_forall; intros; auto].
    }
    assert (G |= (v, ev :: nil) is v ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto; [unfold strong_evalid; rewrite H11, H12; split; auto | hnf; rewrite Forall_forall; intros; auto].
    } destruct H1 as [[vs ps] ?]. destruct H2 as [[vv pv] ?].
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H13). unfold path_glue, fst, snd in H15.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H2 H14). unfold path_glue, fst, snd in H16. destruct H0 as [pf [? ?]].
    pose proof (reachable_by_path_is_reachable _ _ _ _ _ H16). apply H17 in H18. destruct H18 as [pp [[? ?] ?]]. apply H19 in H15. apply H19 in H16. rewrite H15 in H16.
    inversion H16. apply app_inj_tail in H23. destruct H23. subst es. rewrite H7 in H11. auto.
  Qed.

  Lemma construct_reachable_tail_preserve: forall lim p r, exists l', @construct_reachable _ _ _ _ G is_null _ (lim, p, r) = l' ++ r.
  Proof.
    intros lim p r. remember (lengthInput (lim, p, r)) as n. assert (lengthInput (lim, p, r) <= n) by intuition. clear Heqn. revert lim p r H. induction n; intros.
    + simpl in H. rewrite construct_reachable_unfold. destruct p. exists nil; rewrite app_nil_l; auto. destruct (le_dec lim (length r)).
      exists nil; rewrite app_nil_l; auto. exfalso; intuition.
    + simpl in H. rewrite construct_reachable_unfold. destruct p. exists nil; rewrite app_nil_l; auto. destruct (le_dec lim (length r)). exists nil; rewrite app_nil_l; auto.
      remember (@new_working_list _ _ is_null p (map (dst G) (edge_func G v)) (v :: r)). simpl. simpl in IHn. specialize (IHn lim l (v :: r)).
      assert (lim - length (v :: r) <= n) by (simpl; intuition). apply IHn in H0. destruct H0 as [l1 ?]. rewrite app_cons_assoc in H0. exists (l1 +:: v). auto.
  Qed.

  Theorem is_list_is_list: forall root, vvalid G root -> EnumCovered Vertex (reachable G root) -> is_list root -> {l | graph_list_isomorphism l root}.
  Proof.
    intros. remember (@construct_reachable _ _ _ _ G is_null _ (length (proj1_sig X), root :: nil, nil)). destruct (finite_reachable_computable' _ _ X l H Heql).
    hnf in H1. exists (rev l). split; [|split].
    + intros. destruct X as [ss [? ?]]. simpl in Heql. unfold Ensembles.In in i.
      assert (list_composed_by_edges (rev (root :: nil))) by (simpl; apply list_composed_by_edges_single). apply (construct_reachable_edge (length ss) _ nil H H0) in H3.
      hnf in H3. rewrite <- Heql in H3. split; intros.
      - destruct H4 as [? [? ?]]. pose proof H4. rewrite <- H1, in_rev in H4. apply in_split in H4. destruct H4 as [l1 [l2 ?]]. exists l1. destruct l2.
        * exfalso. pose proof H5. rewrite <- H1, in_rev, H4 in H8. rewrite in_app_iff in H8. simpl in H8. destruct H8 as [? | [? | ?]]; auto.
          2: subst d; apply (is_list_no_self_loop root s); auto. destruct l1. 1: inversion H8.
          assert (v = root). {
            rewrite construct_reachable_unfold in Heql. destruct (le_dec (length ss) (length nil)). 1: rewrite Heql in H4; simpl in H4; inversion H4.
            remember (@new_working_list _ _ is_null nil (map (dst G) (edge_func G root)) (root :: nil)). simpl in Heql.
            destruct (construct_reachable_tail_preserve (length ss) l0 (root :: nil)) as [l' ?]. rewrite <- Heql in H9. rewrite H9 in H4.
            rewrite rev_unit in H4. simpl in H4. inversion H4. auto.
          } subst v. simpl in H8. destruct H8.
          1: {
            subst d. destruct H0 as [pf [? ?]]. apply H8 in H5. clear H8. destruct H5 as [pr [[? ?] ?]].
            assert (G |= (root, nil) is root ~o~> root satisfying (fun _ => True)) by
                (split; split; simpl; auto; red; simpl; auto).
            destruct H7 as [[vr ps] ?]. destruct H6 as [? [? ?]]. rewrite step_spec in H12. destruct H12 as [e [? [? ?]]].
            assert (G |= (s, e :: nil) is s ~o~> root satisfying (fun _ => True)). {
              split; split; simpl; auto.
              + unfold strong_evalid. rewrite H13, H14. split; auto.
              + hnf. rewrite Forall_forall; intros; auto.
            } pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H7 H15). unfold path_glue, fst, snd in H16. apply H8 in H10. apply H8 in H16. rewrite H10 in H16.
            inversion H16. destruct ps; simpl in H19; inversion H19.
          }
          1: {
            apply in_split in H8. destruct H8 as [l0 [l2 ?]]. subst l1. assert (root :: l0 <> nil) by (intro HS; inversion HS). apply exists_last in H8.
            destruct H8 as [l' [a ?]]. rewrite app_comm_cons, e in H4. rewrite <- app_cons_assoc, <- app_assoc in H4. simpl in H4. specialize (H3 _ _ _ _ H4).
            assert (a = s) by (apply (is_list_edge_src_the_same root _ d); auto; rewrite <- H1, in_rev, H4, in_app_iff; right; apply in_eq). subst a.
            assert (NoDup (rev l)) by (apply Permutation_NoDup with (l := l); auto; apply Permutation_rev). rewrite H4 in H8. apply NoDup_app_r in H8.
            apply NoDup_cons_2 in H8. apply H8. simpl. right. rewrite in_app_iff. right. apply in_eq.
          }
        * specialize (H3 _ _ _ _ H4). assert (d = v) by (apply (is_list_edge_dst_the_same root s); auto). subst v. exists l2; auto.
      - destruct H4 as [l1 [l2 ?]]. split; [|split]; [apply H1; rewrite in_rev; rewrite H4; rewrite in_app_iff; right ..|]; [apply in_eq | right; apply in_eq |].
        apply (H3 l1 l2); auto.
    + intros; rewrite <- in_rev, H1; tauto.
    + apply Permutation_NoDup with (l := l); auto. apply Permutation_rev.
  Qed.

  (* Print Assumptions is_list_is_list. *)

End LIST_MODEL.