Require Import VST.floyd.proofauto.
Require Import VST.progs.revarray.
Require Import VST.floyd.sublist.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition reverse_spec :=
 DECLARE _reverse
  WITH a0: val, sh : share, contents : list int, size: Z
  PRE [ _a OF (tptr tint), _n OF tint ]
          PROP (0 <= size <= Int.max_signed; writable_share sh)
          LOCAL (temp _a a0; temp _n (Vint (Int.repr size)))
          SEP (data_at sh (tarray tint size) (map Vint contents) a0)
  POST [ tvoid ]
     PROP() LOCAL()
     SEP(data_at sh (tarray tint size) (map Vint (rev contents)) a0).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [reverse_spec; main_spec]).

Definition flip_ends {A} lo hi (contents: list A) :=
  sublist 0 lo (rev contents)
  ++ sublist lo hi contents
  ++ sublist hi (Zlength contents) (rev contents).

Definition reverse_Inv a0 sh contents size :=
 (EX j:Z,
  (PROP  (0 <= j; j <= size-j)
   LOCAL  (temp _a a0; temp _lo (Vint (Int.repr j)); temp _hi (Vint (Int.repr (size-j))))
   SEP (data_at sh (tarray tint size) (flip_ends j (size-j) contents) a0)))%assert.

Lemma Zlength_flip_ends:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_ends i j al) = Zlength al.
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. omega.
Qed.
Hint Rewrite @Zlength_flip_ends using (autorewrite with sublist; omega) : sublist.

Lemma flip_fact_1: forall A size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_ends j (size - j) contents = rev contents.
Proof.
  intros.
  unfold flip_ends.
  rewrite <- (Zlen_le_1_rev (sublist j (size-j) contents))
      by (autorewrite with sublist; omega).
  rewrite !sublist_rev by (autorewrite with sublist; omega).
 rewrite <- !rev_app_distr, ?H.
 autorewrite with sublist; auto.
Qed.

Lemma flip_fact_3:
 forall A (al: list A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
sublist 0 j (flip_ends j (size - j) al) ++
sublist (size - j - 1) (size - j) al ++
sublist (j + 1) size
  (sublist 0 (size - j - 1) (flip_ends j (size - j) al) ++
   sublist j (j + 1) (flip_ends j (size - j) al) ++
   sublist (size - j) size (flip_ends j (size - j) al)) =
flip_ends (j + 1) (size - (j + 1)) al.
Proof.
intros.
unfold flip_ends.
rewrite <- H.
autorewrite with sublist.
rewrite (sublist_split 0 j (j+1)) by (autorewrite with sublist; omega).
rewrite !app_ass.
f_equal. f_equal.
rewrite !sublist_rev, <- ?H by omega.
rewrite Zlen_le_1_rev by (autorewrite with sublist; omega).
f_equal; omega.
rewrite (sublist_app2 (size-j) size)
 by (autorewrite with sublist; omega).
autorewrite with sublist.
rewrite sublist_app'
 by (autorewrite with sublist; omega).
autorewrite with sublist.
f_equal.
f_equal; omega.
autorewrite with sublist.
  rewrite <- (Zlen_le_1_rev (sublist j (1+j) al))
      by (autorewrite with sublist; omega).
rewrite !sublist_rev, <- ?H by omega.
 rewrite <- !rev_app_distr, <- ?H.
 autorewrite with sublist.
 f_equal; f_equal; omega.
Qed.

Lemma flip_ends_map:
  forall A B (F: A -> B) lo hi (al: list A),
  flip_ends lo hi (map F al) = map F (flip_ends lo hi al).
Proof.
intros.
unfold flip_ends.
rewrite !map_app.
rewrite !map_sublist, !map_rev, Zlength_map.
auto.
Qed.

Lemma flip_fact_2:
  forall {A}{d: Inhabitant A} (al: list A) size j,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al =
  Znth (size - j - 1) (flip_ends j (size - j) al).
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. auto.
Qed.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
forward.  (* lo = 0; *)
forward. (* hi = n; *)

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
Exists 0.
entailer!.
unfold flip_ends; autorewrite with sublist; auto.
* (* Prove that loop invariant implies typechecking condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
forward. (* t = a[lo]; *)
{
  entailer!.
  clear - H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by list_solve.
  apply I.
}
forward.  (* s = a[hi-1]; *)
{
  entailer!.
  clear - H H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by list_solve.
  apply I.
}
rewrite <- flip_fact_2 by (rewrite ?Zlength_flip_ends; omega).
forward. (*  a[hi-1] = t; *)
forward. (* a[lo] = s; *)
forward. (* lo++; *)
forward. (* hi--; *)
(* Prove postcondition of loop body implies loop invariant *)
 Exists (Z.succ j).
 entailer!.
 f_equal; f_equal; omega.
 simpl.
 apply derives_refl'.
 unfold data_at.    f_equal.
 clear - H0 HRE H1.
 unfold Z.succ.
 rewrite <- flip_fact_3 by auto.
 rewrite <- (Znth_map (Zlength (map Vint contents)-j-1) Vint) by (autorewrite with sublist in *; list_solve).
 forget (map Vint contents) as al. clear contents.
 remember (Zlength al) as size.
 repeat match goal with |- context [reptype ?t] => change (reptype t) with val end.
 unfold upd_Znth.
 rewrite !Znth_cons_sublist by (repeat rewrite Zlength_flip_ends; try omega).
 rewrite ?Zlength_app, ?Zlength_firstn, ?Z.max_r by omega.
 rewrite ?Zlength_flip_ends by omega.
 rewrite ?Zlength_sublist by (rewrite ?Zlength_flip_ends ; omega).
 unfold Z.succ. rewrite <- Heqsize. autorewrite with sublist.
 replace (size - j - 1 + (1 + j)) with size by (clear; omega).
 reflexivity.
* (* after the loop *)
forward. (* return; *)
rewrite map_rev. rewrite flip_fact_1; try omega; auto.
cancel.
Qed.

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.

forward_call  (*  revarray(four,4); *)
  (gv _four, Ews, four_contents, 4).
   split; [computable | auto].
forward_call  (*  revarray(four,4); *)
    (gv _four,Ews, rev four_contents,4).
   split; [computable | auto].
rewrite rev_involutive.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_reverse.
semax_func_cons body_main.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
     Functor.Representable.Hom_Func.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat
     Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
     NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Functor.Functor_Extender.

(**
Given a functor p : C -> C' and a functor F : C -> D, the local right
kan extension of F along p is functor G : C' -> D together with natural
transformation η : G ∘ p -> F:
#

          F
      C ——————–————> D
      | \          ↗
    p |  \ η     /
      |    ↘   / G
      |      /
      |    /
      ↓  /
      C'

#

such that for any G' : C' -> D and η' : G' ∘ p -> F we have a unique natrual
transformation ε : G' → G such that the following diagram
(natural transformations η, η' and ε) commute:
 #

          F
      C —————–——————–——–——————————–> D
      | \ \       _______________↗  ↗
    p |  \  \η' /      G'         /
      | η \   ↘/               /
      |    \  /   ε          /
      |     \/ —————–—>  / G
      |     /\        /
      |    /  ↘    /
      |   /     /
      |  /   /
      ↓ / /
      C'

#

In the follwing, we separate this notion into three parts:
  1. Local Kan extension Cones (LoKan_Cone)
      is a functor G together with a natural transformation η : G ∘ p -> F

  2. Local Kan extesion Cone Morphisms (Lokan_Cone_Morph)
      is a natrual transformation from underlying functor of the domain cone to
      the underlying functor of the co-domain cone such that makes it makes the
      natural transformations commute (see defintion above).

  3. Lokan Right Kan Extensions (Local_Right_KanExt)
     is in principle the terminal cone in the category† defined above (objects
     are cones and arrows are cone morphisms).

______________________
#

 #
†) We separately show that these cones and cone morphisms create a category. We
   will use this to show that local kan extensions (as terminal objects of this
   category) are unique.

*)
Section KanExtension.
  Context {C C' : Category} (p : (C --> C')%functor).

  Section Right.
    Context {D : Category} (F : (C --> D)%functor).

    Record LoKan_Cone : Type :=
      {
        cone_apex : (C' --> D)%functor;
        cone_edge : ((cone_apex ∘ p) --> F)%nattrans
      }.

    Coercion cone_apex : LoKan_Cone >-> Functor.
    Coercion cone_edge : LoKan_Cone >-> NatTrans.

    Section LoKan_Cone_Morph.
      Context (Cn Cn' : LoKan_Cone).

      Record LoKan_Cone_Morph : Type :=
        {
          cone_morph : (Cn --> Cn')%nattrans;
          cone_morph_com :
            Cn = (Cn' ∘ (cone_morph
                           ∘_h (NatTrans_id p)))%nattrans :> (_ --> _)%nattrans
        }.

      Coercion cone_morph : LoKan_Cone_Morph >-> NatTrans.

    End LoKan_Cone_Morph.

    Record Local_Right_KanExt :=
      {
        LRKE : LoKan_Cone;
        LRKE_morph_ex : ∀ (Cn : LoKan_Cone), LoKan_Cone_Morph Cn LRKE;
        LRKE_morph_unique :
          ∀ (Cn : LoKan_Cone)
            (h h' : LoKan_Cone_Morph Cn LRKE), h = h' :> (_ --> _)%nattrans
      }.

    Coercion LRKE : Local_Right_KanExt >-> LoKan_Cone.

    (** The predicate form of local right kan extensions. *)
    Record is_Local_Right_KanExt (Cn_apex : (C' --> D)%functor) :=
      {
        isLRKE_Cn_edge : ((Cn_apex ∘ p) --> F)%nattrans;
        isLRKE_morph_ex : ∀ (Cn : LoKan_Cone), LoKan_Cone_Morph
                                                 Cn
                                                 {|cone_apex :=
                                                     Cn_apex;
                                                   cone_edge := isLRKE_Cn_edge
                                                 |};
        isLRKE_morph_unique : ∀ (Cn : LoKan_Cone)
                                (h h' : LoKan_Cone_Morph
                                          Cn
                                          {|cone_apex := Cn_apex;
                                            cone_edge := isLRKE_Cn_edge
                                          |}),
            h = h' :> (_ --> _)%nattrans
      }.

    (** The predicate from implies the compact form. *)
    Definition is_Local_Right_KanExt_Local_Right_KanExt
               {Cn_apex : (C' --> D)%functor}
               (ilrke : is_Local_Right_KanExt Cn_apex) : Local_Right_KanExt :=
      {|
        LRKE := {|cone_apex := Cn_apex; cone_edge := @isLRKE_Cn_edge _ ilrke|};
        LRKE_morph_ex := @isLRKE_morph_ex _ ilrke;
        LRKE_morph_unique := @isLRKE_morph_unique _ ilrke
      |}.

    (** The compact form implies the preicate form. *)
    Definition Local_Right_KanExt_is_Local_Right_KanExt
               (lrke : Local_Right_KanExt)
      : is_Local_Right_KanExt lrke :=
      {|
        isLRKE_Cn_edge := lrke;
        isLRKE_morph_ex := @LRKE_morph_ex lrke;
        isLRKE_morph_unique := @LRKE_morph_unique lrke
      |}.

    (** The predicate form of local right kan extensions for cones. *)
    Record is_Cone_Local_Right_KanExt (Cn : LoKan_Cone) :=
      {
        isCLRKE_morph_ex : ∀ (Cn' : LoKan_Cone), LoKan_Cone_Morph Cn' Cn;
        isCLRKE_morph_unique :
          ∀ (Cn' : LoKan_Cone) (h h' : LoKan_Cone_Morph Cn' Cn),
            h = h' :> (_ --> _)%nattrans
      }.

    (** The predicate from implies the compact form. *)
    Definition is_Cone_Local_Right_KanExt_Local_Right_KanExt {Cn : LoKan_Cone}
               (ilrke : is_Cone_Local_Right_KanExt Cn) : Local_Right_KanExt :=
      {|
        LRKE := Cn;
        LRKE_morph_ex := @isCLRKE_morph_ex _ ilrke;
        LRKE_morph_unique := @isCLRKE_morph_unique _ ilrke
      |}.

    (** The compact form implies the preicate form. *)
    Definition Local_Right_KanExt_is_Cone_Local_Right_KanExt
               (lrke : Local_Right_KanExt)
      : is_Cone_Local_Right_KanExt lrke :=
      {|
        isCLRKE_morph_ex := @LRKE_morph_ex lrke;
        isCLRKE_morph_unique := @LRKE_morph_unique lrke
      |}.

  End Right.

End KanExtension.

(** The local left kan extension is simply defined as the dual of local
    right kan extension. *)
Section Left.
  Context {C C' : Category} (p : (C --> C')%functor)
          {D : Category} (F : (C --> D)%functor).

  Definition Local_Left_KanExt := Local_Right_KanExt (p^op) (F^op).

  Definition is_Local_Left_KanExt (Cn_apex : (C' --> D)%functor) :=
    is_Local_Right_KanExt (p^op) (F^op) (Cn_apex^op).

End Left.

Arguments cone_apex {_ _ _ _ _} _.
Arguments cone_edge {_ _ _ _ _} _.
Arguments LoKan_Cone_Morph {_ _ _ _ _} _ _.
Arguments cone_morph {_ _ _ _ _ _ _} _.
Arguments cone_morph_com {_ _ _ _ _ _ _} _.
Arguments LRKE {_ _ _ _ _} _.
Arguments LRKE_morph_ex {_ _ _ _ _} _ _.
Arguments LRKE_morph_unique {_ _ _ _ _} _ _ _ _.

(** The local kan extension defined using hom-functors. In short:
    HLRKE : C' -> D is the local right kan extension of F : C -> D
    along p : C -> C' if the following isomorphism holds:

    Hom_{D^C}(–, F) ∘ (Left_Functor_Extender p D)ᵒᵖ ≃ Hom_{D^C'}(–, HLRKE)

    Note that: (Left_Functor_Extender p D) : (D^C') -> (D^C).
 *)
Section Hom_Local_Right_KanExt.
  Context {C C' : Category} (p : (C --> C')%functor)
          {D : Category} (F : (C --> D)%functor).

  Definition Hom_Local_Right_KanExt_Isomorphism (HLRKE : (C' --> D)%functor) :=
    (((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D)))
          ∘ (Left_Functor_Extender p D)^op)%functor ≃
      (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ HLRKE (Hom_Func (Func_Cat C' D))))
      %natiso.

  Record Hom_Local_Right_KanExt :=
    {
      HLRKE : (C' --> D)%functor;
      HLRKE_Iso : Hom_Local_Right_KanExt_Isomorphism HLRKE
    }.

  Coercion HLRKE : Hom_Local_Right_KanExt >-> Functor.

End Hom_Local_Right_KanExt.

Section Hom_Local_Left_KanExt.
  Context {C C' : Category} (p : (C --> C')%functor)
          {D : Category} (F : (C --> D)%functor).

  Definition Hom_Local_Left_KanExt :=
    Hom_Local_Right_KanExt (p^op) (F^op).

End Hom_Local_Left_KanExt.

Arguments HLRKE {_ _ _ _ _} _.
Arguments HLRKE_Iso {_ _ _ _ _} _.


(** Brzozowski derivatives and its properties *)

Set Implicit Arguments.

Require Import
        Syntax.Regex
        Derivatives.Smart.

Fixpoint deriv (a : ascii)(e : regex) : regex :=
  match e with
  | #0 => #0
  | #1 => #0
  | $ c =>
    match ascii_dec a c with
    | left _ => #1
    | right _ => #0
    end
  | (e1 @ e2) =>
    if null e1 then
      ((deriv a e1) :@: e2) :++: (deriv a e2)
    else
      (deriv a e1) :@: e2
  | (e1 :+: e2) =>
    (deriv a e1) :++: (deriv a e2)
  | (e1 ^*) =>
     (deriv a e1) :@: (e1 :^*:)
  end.

Lemma choice_inv : forall e e1 e2 s, e = e1 :+: e2 -> s <<- e -> s <<- e1 \/ s <<- e2.
Proof.
  intros e e1 e2 s Heq H ; substs ; inverts* H.
Qed.

Theorem deriv_sound
  : forall e a s
  , s <<- (deriv a e)
    -> (String a s) <<- e.
Proof.
  Local Hint Resolve
        cat_smart_sound
        cat_smart_complete
        choice_smart_sound
        choice_smart_complete
        star_smart_sound
        star_smart_complete.
  induction e ; intros a' s H ; simpl in * ; try solve [ inverts* H ] ;
    repeat (match goal with
            (** empty case *)
            | [H : _ <<- #0 |- _] =>
              inverts* H
            (** lambda case *)
            | [H : _ <<- #1 |- _] =>
              inverts* H
            | [H: context[ascii_dec ?e ?e'] |- _] =>
              destruct* (ascii_dec e e')
            (** choice case *)
            | [H : _ <<- (_ :++: _) |- _] =>
              lets J : choice_smart_sound H ;
              clear H ; inverts* J
            (** concatenation case *)
            | [H : _<<- (_ :@: _) |- _] =>
              lets J : cat_smart_sound H ; clear H ; inverts* J
            end ; substs*).
            remember (null e1) as N. destruct* N.
            lets J : choice_smart_sound H.
            eapply choice_inv in J ; eauto.
            destruct* J.
            apply cat_smart_sound in H0.
            inverts* H0.
            symmetry in HeqN.
            assert (Hn : "" <<- e1).
               apply null_sound.
               unfolds.
               rewrite HeqN ; auto.
            apply IHe2 in H0 ; eauto.
            apply cat_smart_sound in H.
            inverts* H.
Qed.

Hint Resolve deriv_sound.

Theorem deriv_complete
  :  forall e a s
  ,  (String a s) <<- e
  -> s <<- deriv a e.
Proof.
  Local Hint Immediate
        cat_smart_sound
        cat_smart_complete
        choice_smart_sound
        choice_smart_complete
        star_smart_sound
        star_smart_complete.
  induction e ; intros a' s H ; simpl in * ; try inverts* H ;
    repeat (match goal with
            (** empty case *)
            | [H : _ <<- #0 |- _] =>
              inverts* H
            (** lambda case *)
            | [H : _ <<- #1 |- _] =>
              inverts* H
            (** character case *)
            | [H : _ <<- ($ _) |- _] =>
              inverts* H
            (** concatenation *)
            | [ |- context[if (ascii_dec ?e ?e') then _ else _]] =>
              remember (ascii_dec e e') as NN ; destruct* NN ; try contradiction
            end ; substs*).
            destruct s0. simpl in *.
            substs. apply null_complete in H2.
            unfolds in H2. destruct* (null e1). contradiction.
            injects H5. remember (null e1) as NN ; destruct* NN.
            eapply choice_smart_complete.
            apply IHe1 in H2.
            apply InLeft. apply cat_smart_complete ; eauto.
            injects H4.
            apply cat_smart_complete.
            apply IHe in H1.
            eapply InCat ; eauto.
Qed.

Hint Immediate deriv_complete.


From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts MoreEnumerabilityFacts.

Require Import List.
Import ListNotations.
From Undecidability.Shared Require Import Dec.

Set Implicit Arguments.

Set Default Proof Using "Type".

(* ** Pre-order properties *)

Section Properties.

  Variables (X : Type) (P : X -> Prop)
            (Y : Type) (Q : Y -> Prop)
            (Z : Type) (R : Z -> Prop).

  Fact reduces_reflexive : P ⪯ P.
  Proof. exists (fun x => x); red; tauto. Qed.

  Fact reduces_transitive : P ⪯ Q -> Q ⪯ R -> P ⪯ R.
  Proof.
    unfold reduces, reduction.
    intros (f & Hf) (g & Hg).
    exists (fun x => g (f x)).
    intro; rewrite Hf, Hg; tauto.
  Qed.

  (* ** An equivalent dependent definition *)

  Fact reduces_dependent :
    P ⪯ Q <-> inhabited (forall x, { y | P x <-> Q y }).
  Proof.
    constructor.
    - intros [f Hf]. constructor. intros x. now exists (f x).
    - intros [f]. exists (fun x => proj1_sig (f x)).
      intros x. exact (proj2_sig (f x)).
  Qed.

  Fact reduces_complement : P ⪯ Q -> complement P ⪯ complement Q.
  Proof.
    intros [f Hf].
    exists f. intros x. specialize (Hf x). split.
    all: intros H Hc; apply H, Hf, Hc.
  Qed.

End Properties.

Module ReductionChainNotations.

(* DLW: Thx to M. Wuttke for the tip, see coq-club ML *)

Ltac redchain2Prop_rec xs :=
  lazymatch xs with
  | pair ?x (pair ?y ?xs) =>
    let z := redchain2Prop_rec (pair y xs) in
    constr:(x ⪯ y /\ z)
  | pair ?x ?y => constr:(x ⪯ y)
  end.

Ltac redchain2Prop xs :=
  let z := redchain2Prop_rec xs
  in  exact z.

Declare Scope reduction_chain.
Delimit Scope reduction_chain with redchain_scope.
Notation "x '⪯ₘ' y" := (pair x y) (at level 80, right associativity, only parsing) : reduction_chain.
Notation "'⎩' xs '⎭'" := (ltac:(redchain2Prop (xs % redchain_scope))) (only parsing).

(*
Definition Undec_Problem := { X : Type & X -> Prop }.

Definition undec_problem X (P : X -> Prop) : Undec_Problem := existT _ X P.

Notation "⎩ p ⎭" := (@undec_problem _ p) (format "⎩ p ⎭").

Infix "⪯ₚ" := (fun p q : Undec_Problem => projT2 p ⪯ projT2 q : Prop) (at level 70).

Reserved Notation "p '⪯ₗ' q 'by' l" (at level 70).

Section reduction_chain.

  Inductive reduction_chain : Undec_Problem -> Undec_Problem -> list Undec_Problem -> Prop :=
    | reduction_chain_nil  : forall p, p ⪯ₗ p by nil
    | reduction_chain_cons : forall p q r l, p ⪯ₚ q -> q ⪯ₗ r by l -> p ⪯ₗ r by q::l
  where "p '⪯ₗ' q 'by' l" := (reduction_chain p q l).

  Fact reduction_chain_reduces p q l : p ⪯ₗ q by l -> p ⪯ₚ q.
  Proof.
    induction 1 as [ p | p q r l H1 _ ? ].
    + apply reduces_reflexive.
    + apply reduces_transitive with (1 := H1); trivial.
  Qed.

  Fact reduction_chain_app p q r l m : p ⪯ₗ q by l -> q ⪯ₗ r by m -> p ⪯ₗ r by l++m.
  Proof.
    induction 1; intros; auto.
    constructor 2; auto.
  Qed.

End reduction_chain.

Notation "p '⪯ₗ' q 'by' l" := (reduction_chain p q l).

Tactic Notation "red" "chain" "stop" := constructor 1.
Tactic Notation "red" "chain" "step" constr(H) := constructor 2; [ apply H | ].
Tactic Notation "red" "chain" "app" constr(H) := apply reduction_chain_app with (1 := H).
*)

End ReductionChainNotations.

Lemma dec_red X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> decidable q -> decidable p.
Proof.
  unfold decidable, decider, reduces, reduction, reflects.
  intros [f] [d]. exists (fun x => d (f x)). intros x. rewrite H. eapply H0.
Qed.

Lemma red_comp X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> (fun x => ~ p x) ⪯ (fun y => ~ q y).
Proof.
  intros [f]. exists f. intros x. red in H. now rewrite H.
Qed.

Section enum_red.

  Variables (X Y : Type) (p : X -> Prop) (q : Y -> Prop).
  Variables (f : X -> Y) (Hf : forall x, p x <-> q (f x)).

  Variables (Lq : _) (qe : list_enumerator Lq q).

  Variables (x0 : X).

  Variables (d : eq_dec Y).

  Local Fixpoint L L' n :=
    match n with
    | 0 => []
    | S n => L L' n ++ (filter (fun x => Dec (In (f x) (cumul Lq n))) (cumul L' n))
    end.

  Local Lemma enum_red L' :
    list_enumerator__T L' X ->
    list_enumerator (L L') p.
  Proof using qe Hf.
    intros HL'.
    split.
    + intros H.
      eapply Hf in H. eapply (cumul_spec qe) in H as [m1]. destruct (cumul_spec__T HL' x) as [m2 ?].
      exists (1 + m1 + m2). cbn. apply in_app_iff. right.
      apply filter_In. split.
      * eapply cum_ge'; eauto; lia.
      * eapply Dec_auto. eapply cum_ge'; eauto; lia.
    + intros [m H]. induction m.
      * inversion H.
      * cbn in H. apply in_app_or in H. destruct H; [now auto|].
        apply filter_In in H. destruct H as [_ H].
        destruct (Dec _) in H; [|easy].
        eapply Hf. eauto.
  Qed.

End enum_red.

Lemma enumerable_red X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> discrete Y -> enumerable q -> enumerable p.
Proof.
  intros [f] [] % enum_enumT [] % discrete_iff [L] % enumerable_enum.
  eapply list_enumerable_enumerable.
  eexists. eapply enum_red; eauto.
Qed.

Lemma semi_decidable_red (X Y : Type) (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> semi_decidable q -> semi_decidable p.
Proof.
  intros [f Hf] [g Hg]. exists (fun x n => g (f x) n).
  firstorder.
Qed.

Theorem not_decidable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> ~ enumerable (complement p) ->
  ~ decidable q /\ ~ decidable (complement q).
Proof.
  intros. split; intros ?.
  - eapply H1. eapply dec_red in H2; eauto.
    eapply dec_compl in H2. eapply dec_count_enum; eauto.
  - eapply H1. eapply dec_red in H2; eauto.
    eapply dec_count_enum; eauto. now eapply red_comp.
Qed.

Theorem not_coenumerable X Y (p : X -> Prop) (q : Y -> Prop) :
  p ⪯ q -> enumerable__T X -> ~ enumerable (complement p) -> discrete Y ->
  ~ enumerable (complement q).
Proof.
  intros. intros ?. eapply H1. eapply enumerable_red in H3; eauto.
  now eapply red_comp.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable r_ : Prop.
Variable q_ : Prop.
Variable p_ : Prop.
Variable goal_ : Prop.

Variable assump_1 : (True -> (p_ \/ (q_ \/ r_))).
Variable goal_p_2 : (p_ -> goal_).
Variable goal_q_3 : (q_ -> goal_).
Variable goal_r_4 : (r_ -> goal_).

Theorem or3_5 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This file axiomatizes the relational form of the axiom of choice *)

Axiom relational_choice :
  forall (A B : Type) (R : A->B->Prop),
   (forall x : A, exists y : B, R x y) ->
     exists R' : A->B->Prop,
       subrelation R' R /\ forall x : A, exists! y : B, R' x y.


(** **********************************************************

Benedikt Ahrens, Ralph Matthes

SubstitutionSystems

2015

************************************************************)

Require Export UniMath.Tactics.EnsureStructuredProofs.
Require Import UniMath.Foundations.PartD.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.

Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .

Declare Scope subsys.
Delimit Scope subsys with subsys.
Notation "G • F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35) : subsys.
Notation "α ⋆ β" := (horcomp β α) (at level 20) : subsys.

Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25) : subsys.
Notation "Z ∘ α" := (post_whisker α Z) : subsys.

Notation "` T" := (alg_carrier _ T) (at level 3, format "` T") : subsys.
Notation "α •• Z" :=  (# (pre_composition_functor_data _ _ _ Z) α) (at level 25) : subsys.
Notation "A ⊗ B" := (make_catbinprod A B) : subsys.
Notation "A ⊠ B" := (category_binproduct A B) (at level 38) : subsys.
Notation "'ℓ'" := (pre_composition_functor(*_data*) _ _ _) : subsys.
Notation "Z 'p•' Z'" := (ptd_compose _ Z Z') (at level 25) : subsys. (** used to stand for (ptd_composite _ _ Z Z') *)

(** The forgetful functor from pointed endofunctors to endofunctors *)
Notation "'U'" := (functor_ptd_forget _ ) : subsys.


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

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

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

Theorem rspec_equiv (m : mem) (b : block) (ofs : ptrofs) (l : nat) :
  strlen m b ofs l
  <->
  strlen_rspec' m b ofs l.
Proof.
  split; intro S.
  - induction S.
    + constructor; assumption.
    + econstructor; try eassumption.
      apply Int.eq_false; assumption.
  - induction S.
    + constructor; assumption.
    + econstructor; try eassumption.
      intro C; contradict H2.
      rewrite C, Int.eq_true.
      discriminate.
Qed.


(* Test des definitions inductives imbriquees *)

Inductive X : Set :=
    cons1 : list X -> X.

Inductive Y : Set :=
    cons2 : list (Y * Y) -> Y.

(* Test inductive types with local definitions (arity) *)

Inductive eq1 : forall A:Type, let B:=A in A -> Prop :=
  refl1 : eq1 True I.

Check
 fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
   let B := A in
     fun (a : A) (e : eq1 A a) =>
       match e in (@eq1 A0 B0 a0) return (P A0 a0) with
       | refl1 => f
       end.

Inductive eq2 (A:Type) (a:A)
  : forall B C:Type, let D:=(A*B*C)%type in D -> Prop :=
  refl2 : eq2 A a unit bool (a,tt,true).

(* Check inductive types with local definitions (parameters) *)

Inductive A (C D : Prop) (E:=C) (F:=D) (x y : E -> F) : E -> Set :=
    I : forall z : E, A C D x y z.

Check
  (fun C D : Prop =>
   let E := C in
   let F := D in
   fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type)
     (f : forall z : C, P z (I C D x y z)) (y0 : C)
     (a : A C D x y y0) =>
   match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with
   | I _ _ _ _ x0 => f x0
   end).

Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set :=  {p : C; q : E}.

Check
  (fun C D : Set =>
   let E := C in
   let F := D in
   fun (x y : E -> F) (P : B C D x y -> Type)
     (f : forall p0 q0 : C, P (Build_B C D x y p0 q0))
     (b : B C D x y) =>
   match b as b0 return (P b0) with
   | Build_B _ _ _ _ x0 x1 => f x0 x1
   end).

(* Check inductive types with local definitions (constructors) *)

Inductive I1 : Set := C1 (_:I1) (_:=0).

Check (fun x:I1 =>
  match x with
  | C1 i n => (i,n)
  end).

(* Check implicit parameters of inductive types (submitted by Pierre
  Casteran and also implicit in BZ#338) *)

Set Implicit Arguments.
Unset Strict Implicit.

CoInductive LList (A : Set) : Set :=
  | LNil : LList A
  | LCons : A -> LList A -> LList A.

Arguments LNil [A].

Inductive Finite (A : Set) : LList A -> Prop :=
  | Finite_LNil : Finite LNil
  | Finite_LCons :
      forall (a : A) (l : LList A), Finite l -> Finite (LCons a l).

(* Check positivity modulo reduction (cf bug BZ#983) *)

Record P:Type := {PA:Set; PB:Set}.

Definition F (p:P) := (PA p) -> (PB p).

Inductive I_F:Set := c : (F (Build_P nat I_F)) -> I_F.

(* Check that test for binders capturing implicit arguments is not stronger
   than needed (problem raised by Cedric Auger) *)

Set Implicit Arguments.
Inductive bool_comp2 (b: bool): bool -> Prop :=
| Opp2: forall q, (match b return Prop with
                  | true => match q return Prop with
                              true => False |
                              false => True end
                  | false => match q return Prop with
                              true => True |
                              false => False end end) -> bool_comp2 b q.

(* This one is still to be made acceptable...

Set Implicit Arguments.
Inductive I A : A->Prop := C a : (forall A, A) -> I a.

 *)

(* Test recursively non-uniform parameters (was formerly in params_ind.v) *)

Inductive list (A : Set) : Set :=
  | nil : list A
  | cons : A -> list (A -> A) -> list A.

(* Check inference of evars in arity using information from constructors *)

Inductive foo1 : forall p, Prop := cc1 : foo1 0.

(* Check cross inference of evars from constructors *)

Inductive foo2 : forall p, Prop := cc2 : forall q, foo2 q | cc3 : foo2 0.

(* An example with reduction removing an occurrence of the inductive type in one of its argument *)

Inductive IND1 (A:Type) := CONS1 : IND1 ((fun x => A) IND1).

(* These types were considered as ill-formed before March 2015, while they
   could be accepted considering that the type IND1 above was accepted *)

Inductive IND2 (A:Type) (T:=fun _ : Type->Type => A) := CONS2 : IND2 A -> IND2 (T IND2).

Inductive IND3 (A:Type) (T:=fun _ : Type->Type => A) := CONS3 : IND3 (T IND3) -> IND3 A.

Inductive IND4 (A:Type) := CONS4 : IND4 ((fun x => A) IND4) -> IND4 A.

(* This type was ok before March 2015 *)

Inductive IND5 (A : Type) (T := A) : Type := CONS5 : IND5 ((fun _ => A) 0) -> IND5 A.

(* An example of nested positivity which was rejected by the kernel
   before 24 March 2015 (even with Unset Elimination Schemes to avoid
   the _rect bug) due to the wrong computation of non-recursively
   uniform parameters in list' *)

Inductive list' (A:Type) (B:=A) :=
| nil' : list' A
| cons' : A -> list' B -> list' A.

Inductive tree := node : list' tree -> tree.

(* This type was raising an anomaly when building the _rect scheme,
   because of a bug in Inductiveops.get_arity in the presence of
   let-ins and recursively non-uniform parameters. *)

Inductive L (A:Type) (T:=A) : Type := C : L nat -> L A.

(* This type was raising an anomaly when building the _rect scheme,
   because of a wrong computation of the number of non-recursively
   uniform parameters when conversion is needed, leading the example to
   hit the Inductiveops.get_arity bug mentioned above (see #3491) *)

Inductive IND6 (A:Type) (T:=A) := CONS6 : IND6 T -> IND6 A.

Module TemplateProp.

  (** Check lowering of a template universe polymorphic inductive to Prop *)

  Inductive Foo (A : Type) : Type := foo : A -> Foo A.

  Check Foo True : Prop.

End TemplateProp.

Module PolyNoLowerProp.

  (** Check lowering of a general universe polymorphic inductive to Prop is _failing_ *)

  Polymorphic Inductive Foo (A : Type) : Type := foo : A -> Foo A.

  Fail Check Foo True : Prop.

End PolyNoLowerProp.

(* Test building of elimination scheme with noth let-ins and
   non-recursively uniform parameters *)

Module NonRecLetIn.

  Unset Implicit Arguments.

  Inductive Ind (b:=2) (a:nat) (c:=1) : Type :=
  | Base : Ind a
  | Rec : Ind (S a) -> Ind a.

  Check Ind_rect (fun n (b:Ind n) => b = b)
    (fun n => eq_refl)
    (fun n b c => f_equal (Rec n) eq_refl) 0 (Rec 0 (Base 1)).

End NonRecLetIn.

(* Test treatment of let-in in the definition of Records *)
(* Should fail with "Sort expected" *)

Fail Inductive foo (T : Type) : let T := Type in T :=
  { r : forall x : T, x = x }.


Inductive Functional {A B} : list (A * B) -> Prop :=
  | empty_fn : Functional nil
  | extend_fn : `{Functional l -> Unmapped l a -> Functional ((a,b)::l)}.
Hint Constructors Functional.

Lemma in_functional_mapsto : forall A B (eq_dec : dec_type A) (l : list (A * B)) (F : Functional l)
                                    a b (H : In (a,b) l), MapsTo l a b.
Proof.
  induction l as [|(a,b) l' IH];
  intros F a' b' H; inversion H;[ (* finishes base case *)
    inject_pair; subst; constructor; auto
  |inversion F as [|? ? ? Hfun Hunmapped]; subst;
   destruct (eq_dec a a'); [subst; contradict Hunmapped; apply in_not_unmapped with (b:=b')
                           |constructor]]; auto.
Qed.

Remark functional_exchange : forall A B (l : list (A * B)) a b (F: Functional ((a,b)::l)) b', Functional ((a,b')::l).
Proof. intros; inversion F; crush. Qed.

Lemma functional_join : `{Functional l -> Functional (list_join eq_dec combine base l' a c l)}.
Proof.
  induction l as [|(a,b) l_ IH]; simpl;
  [intros; repeat constructor
  |intros l' a' c F].
  destruct (eq_dec a' a) as [Heq|Hneq];
  [subst; apply functional_exchange with (b := b)
  |constructor; inversion F; [apply IH|apply unmapped_join]]; auto.
Qed.

(*

Lemma unmapped_join2 : forall l a a' b c l'
                             (Hcontain : (forall a c, in_list_list l a c -> in_list_list l' a c)
                                          \/ (b = (base l' c))),
                        Unmapped l a' ->
                        MapsTo (list_join eq_dec combine base l' a c l) a' b ->
                        (b = (base l' c)) /\ a = a'.
Proof.
  induction l as [|(a_,b_) l_ IH];
  simpl; intros a a' b c l' Hcontain Hunmap Hmap;
  [inversion Hmap as [|? ? ? ? ? ? Hbad]; subst; split; solve [auto|reflexivity|inversion Hbad]
  |].
  destruct (eq_dec a a_) as [Heq | Hneq];
    [inversion Hunmap as [|? ? ? ? Hunmap' Hneq]; subst;
     inversion Hmap as [|? ? ? ? ? ? Hbad]; split; try solve [reflexivity|
                                             rewrite unmapped_not_mapped in Hunmap';
                                             [apply Hunmap' in Hbad; contradiction
                                             |auto]]
    |].
  inversion Hmap as [|? ? ? ? ? ? Hbad]; subst; contradict Hneq; auto.
  apply IH with (b := b) (c := c) (l' := l').
  inversion Hcontain as [L|R].
  specialize L with a_ b_
  intros a_' c_' Hin; inversion Hin as [bs_ [Hmap_ Hsetin_]];
  apply Hcontain; destruct (eq_dec a_' a_) as [Heq_|Hneq_];
  [subst
    |exists bs_; repeat constructor]; auto.
  unfold in_list_list.
  Focus 2.

    [intros a_' c_' Hin
    |inversion Hunmap
    |]; auto.

;
  inversion Hmap; [(* a_' = a_ *)
                   rewrite unmapped_not_mapped in Hunmap; [
                    (* rewritten *)
                    subst; match goal with [bad : ?a <> ?a |- _] => contradict bad; auto end
                    |(* satisfy hyp *)assumption]
                   |subst].
  Check unmapped_not_mapped.

   [specialize Hunmap with b; contradict Hunmap; constructor
   |assumption
   |
   |assumption].
  .
  ; constructor; auto | auto].

 subst; repeat constructor|]
  constructor.
Qed.
Admitted.*)

(*
Require Import Setoid.

Lemma no_longer_tail_replacement : forall κ κ' κ'' κmore,
                                     length κmore > 0 ->
                                     ~ Tail_replacement κ (κmore ++ κ) κ' κ''.
Proof.
  induction κ as [|φ κ_].
  intros; intro bad; inversion bad; rewrite app_nil_r in H2; contradict H; subst; simpl; omega.
  intros; intro bad; inversion bad; subst.
  apply no_circular_app in H2; [contradiction|assumption].
  assert (~ Tail_replacement κ_ ((κmore ++ [φ]) ++ κ_) κ' κ''').
  apply IHκ_ with (κmore := κmore ++ [φ]).
  rewrite app_length; omega.
  rewrite app_assoc_reverse in H0; simpl in H0; contradiction.
Qed.

Lemma replace_is_replacement : forall κ κ' κ'' κ''',
                       (Tail_replacement κ κ' κ'' κ''' <-> replacetail_kont κ κ' κ'' = Some κ''').
Proof.
  induction κ as [|φ κ_ IH];
  [(* base case *)
  intros; inversion H; subst; split; intro H'; inversion H'; subst; simpl; constructor; auto
  |
  intros; inversion H; subst; split; intro H';
  [(* inversion case 1, first split *)
  inversion H' as [| foo bar baz qux boo baa]; subst; unfold replacetail_kont; split_refl kont_eq_dec (φ :: κ_);
    inversion baa; [match goal with [B : ?k = ?f :: ?k |- _] => apply no_circular_cons in B; contradiction end
                 |subst;apply no_longer_tail_replacement with (κmore := [φ]) in baa; [contradiction|simpl;omega]]
  (* second split *)
  |unfold replacetail_kont in H'; split_refl kont_eq_dec (φ :: κ_);
  injection H'; intros; subst; constructor; auto
  (* inversion case 2, first split *)
  |inversion H'; subst;
   [unfold replacetail_kont; split_refl kont_eq_dec (φ0 :: κ'0)
   |rewrite IH in H6;
   apply kont_tail_cons in H; auto]
  |]].

  unfold replacetail_kont; fold replacetail_kont; rewrite H6;
  destruct (kont_eq_dec (φ :: κ_) (φ0 :: κ'0)) as [Heq | Hneq];
    [inversion H0; subst;
     [apply no_circular_app with (l := [φ0]) in Heq; [contradiction|simpl;omega]
     |injection Heq; intros; subst;
      assert (bad : replacetail_kont (φ1 :: κ') (φ0 :: φ1 :: κ') κ'' = None) by
          (apply no_longer_tail_replacement2 with (κmore := [φ0]); simpl; auto);
      rewrite bad in H6; discriminate]
    |auto].

  unfold replacetail_kont in H'; fold replacetail_kont in H'.
  destruct (kont_eq_dec (φ :: κ_) (φ0 :: κ'0)) as [Heq | Hneq];
    [injection H'; injection Heq; intros; subst; constructor
    |].

  assert (R : exists κ''_, (replacetail_kont κ_ (φ0 :: κ'0) κ'') = Some κ''_).
  destruct (replacetail_kont κ_ (φ0 :: κ'0) κ'') as [κ''_|];
    [injection H';intros;subst; exists κ''_; auto
    |discriminate].
  destruct R as [κ''_ repeq].
  assert (R' : φ :: κ''_ = κ''').
  destruct (replacetail_kont κ_ (φ0 :: κ'0) κ'') as [κ''__|];
    [injection H'; injection repeq; intros; subst; auto
    |discriminate].
  rewrite <- R'.
  apply push_replacement.
  rewrite <- IH in repeq; [| apply kont_tail_cons in H]; auto.
Qed.
*)

(* inv_invariant *)
(*
  intros s s' Hinv Hord Hstep.
  inversion Hord as [? ? ? ? ? Mord Kord ctxord];
  inversion Hinv as [? ? ? ? ? Hdom tκctx Φ seq]; subst; injection seq; intros; subst; clear seq.
  Ltac doinvert Un κ tκ φ H ctx Hin :=
    inversion Un as [|κ tκ φ H|ctx tκ κ H Hin];
    try (set (ctx := (context (var 0) (@nil (Name * Addr)) (@nil (Addr * AbsVal))));
         set (Hin := 0)).
  Ltac noinvert Un κ tκ φ H ctx Hin := set (κ := (@nil Frame));
                                       set (tκ := mt);
                                       set (φ := (ar (var 0) (@nil (Name * Addr))));
                                       set (H := 0);
                                       set (ctx := (context (var 0) (@nil (Name * Addr)) (@nil (Addr * AbsVal))));
                                       set (Hin := 0).
  Ltac part1 ctx tκctx := apply inv; try solve [apply unroll_push; auto
                           |repeat constructor; auto
                           |auto
                           |apply Dom_join_left; firstorder
                           |apply Dom_join_right; firstorder
                           |intros blah blorg; apply tκctx; inversion blorg; subst; auto
                           |inversion Hctx; subst; try solve [discriminate
                                                              |constructor; auto
                                                             |auto]].
  set (idκ := fun κ : Kont => κ).
  Ltac part2 p Φ M Ξ inpoint fnκ trypop :=
    let κ' := fresh "κ'" in
    let κ'' := fresh "κ''" in
    let φ := fresh "φ" in
    intros [ce cρ cσ ct] Hindom tκ' Hinctx;
    constructor;
    [(* reach *)
      destruct (Φ (context ce cρ cσ ct) Hindom tκ') as [Hreach Hmemo]; auto;
     subst p; auto;
     intros κ' unroll'; pose (Hreach' := Hreach κ' unroll'); destruct Hreach' as [κ [eunroll [t' [t'' [π HT]]]]];
     ((trypop;
       match goal with
           [H : StackUnroll Ξ ?κ (kpush (ar ?e ?ρ) ?tκ) |- _] =>
           pose (φ := (ar e ρ)); inversion H as [|κ''|]
       | [H : StackUnroll Ξ ?κ (kpush (fn ?v) ?tκ) |- _] =>
         pose (φ := (fn v)); inversion H as [|κ''|]
       end;
       exists (fnκ κ κ'' φ))
        || exists (fnκ κ));
      split; [|exists t', (tick inpoint)];
     [|exists (shell inpoint κ t'' :: π)]; subst; repeat constructor; auto
    |(* memo *)
    let v := fresh "v" in
    intros v σ'' t' Hmemo;
      assert (HindomM : InDom M (context ce cρ cσ ct)) by
        (destruct Hmemo as [ress [Hmapress Hinress]]; rewrite InDom_is_mapped; [exists ress|exact context_eq_dec]; auto);
      assert (HindomΞ : InDom Ξ (context ce cρ cσ ct)) by (apply Dom_InDom with (l := M); [exact context_eq_dec| | ]; auto);
      destruct (Φ (context ce cρ cσ ct) HindomΞ tκ'); auto].

  inversion Hstep as [x ρ σ a tκs ts Ms Ξs ps Hmap Hpeq Hs'eq |
                      e0 e1 ρ σ tκs ts Ms Ξs ps Hpeq |
                      x e ρ σ tκs ts Ms Ξs ps Hpeq Hs'eq |
                      v σ e ρ tκs ts Ms Ξs ps Hpeq Hs'eq |
                      v σ x e ρ fnv tκs ts Ms Ξs ps Hin_force Hpeq Hs'eq |
                      x e ρ v σ tκs ts Ms Ξs ps a ρ' σ' ts' ctx Hunmapped Hpeq Hs'eq |
                      x e ρ v σ tκs ts Ms Ξs vm σm tm ps a ρ' σ' ctx Hinmemos Hpeq Hs'eq |
                      v σ ctx tκs Ms Ξs t's M's Hin_ctxs Hpeq Hs'eq]; subst;
  [(* var: ε *)
    constructor; auto; part2 p Φ M Ξ (ev (var x) ρ σ) idκ fail
   |(* app: push *)
   constructor; auto;
   [(* ctx_in_dom *)
     intros ctx Hctx; destruct (tκctx ctx); inversion Hctx; auto
    |part2 p Φ M Ξ (ev (app e0 e1) ρ σ) (fun (κ : Kont) => (ar e1 ρ :: κ)) fail]
   |(* lam: ε *)
    constructor; auto; part2 p Φ M Ξ (ev (lam x e) ρ σ) idκ fail
   |(* ar : exchange *)
    constructor; auto;
    [intros ctx Hctx; destruct (tκctx ctx) as [X]; inversion Hctx; subst; [constructor|exists X]; auto
    |part2 p Φ M Ξ (co v σ) (fun (κ κ' : Kont) (φ : Frame) => (fn v :: κ')) idtac]
   |(* fn -> ap : pop *)
   constructor; auto;
    [intros ctx Hctx; destruct (tκctx ctx) as [X]; inversion Hctx; subst;
     solve [constructor; auto | exists X; auto]
    |part2 p Φ M Ξ (co v σ) (fun (κ κ' : Kont) (φ : Frame) => κ') idtac]
   |(* do ap : ε *)
   constructor; auto
   |(* ap memo : ? *)
   |(* ret: pop *)].

  apply Dom_join_right; firstorder.
  intros ctx' Hctx'; inversion Hctx'; subst; try solve [discriminate
                                                              |constructor; auto
                                                             |auto].

  destruct (in_list_join context_eq_dec
                         κs_join
                         κ_singleton
                         κs_join_extensive
                         κ_singleton_extensive
                         Ξ Ξ
                         (context e ρ' σ' ts')
                         tκ
                         (fun (ab : Context * TrunKonts) (H : In ab Ξ) => H)) as [omg [? ?]];
    exists omg; apply MapsTo_In; auto.
    let κ' := fresh "κ'" in
    let κ'' := fresh "κ''" in
    let φ := fresh "φ" in
    intros [ce cρ cσ ct] Hindom tκ' Hinctx;
    constructor.
    (* reach *)
    intros κ' unroll';
    destruct (in_list_join_set_split context_eq_dec trunkont_eq_dec Ξ Ξ ctx tκ Hinctx) as [[ctxeq tκeq]|Hinrest];
    [subst; injection ctxeq; intros; subst ce cρ cσ ct;
     exists κ'; split;[apply unroll_rt with (tκ := tκ'); auto |exists ts',ts',nil; constructor]
    |assert (Hneed : InDom Ξ (context ce cρ cσ ct)) by
        (destruct Hinrest as [tκs [Hmap ?]]; rewrite InDom_is_mapped; [exists tκs|exact context_eq_dec]; auto);
      destruct (Φ (context ce cρ cσ ct) Hneed tκ') as [Hreach Hmemo]; auto].
    .
(* Stuck *)
    destruct Hreach as
    [(* reach *)

     subst p; auto;
     intros κ' unroll'; pose (Hreach' := Hreach κ' unroll'); destruct Hreach' as [κ [t' [t'' [eunroll [π HT]]]]];
     exists (rt ctx);
     exists t', (tick (ap x e ρ v σ)); split;
     [|exists (shell (ap x e ρ v σ) κ t'' :: π)]; subst; repeat constructor; auto
    |(* memo *)
    let v := fresh "v" in
    intros v σ'' t' Hmemo;
      assert (HindomM : InDom M (context ce cρ cσ ct)) by
        (destruct Hmemo as [ress [Hmapress Hinress]]; rewrite InDom_is_mapped; [exists ress|exact context_eq_dec]; auto);
      assert (HindomΞ : InDom Ξ (context ce cρ cσ ct)) by (apply Dom_InDom with (l := M); [exact context_eq_dec| | ]; auto);
      destruct (Φ (context ce cρ cσ ct) HindomΞ tκ'); auto].

  part2 p Φ M Ξ (ap x e ρ v σ) (fun (κ κ' : Kont) (φ : Frame) => (rt ctx)) fail.
                         (*                          (l := Ξ) (l' := Ξ)

(a := (context e ρ' σ' ts'))
                         (c := tκ) *)). forall l l' a c,
    (forall ab, In ab l -> In ab l') ->
  in_list_list (list_join eq_dec combine base l' a c l) a c.

  unfold
  apply in_list_join.
  apply Dom_in_D
    constructor; auto; part2 p Φ M Ξ (ap x e ρ v σ) idκ fail
  .

  part2 p Φ M Ξ (ev (app e0 e1) ρ σ) (fun (κ κ' : Kont) (φ : Frame) => (ar e1 ρ :: κ')) idtac.

  constructor; auto.
  intros ctx Hctx; destruct (tκctx ctx) as [X]; inversion Hctx; subst; [constructor|exists X];auto.
  intros [ce cρ cσ ct] Hindom tκ' Hinctx;
    constructor;
    [(* reach *)
      destruct (Φ (context ce cρ cσ ct) blarg tκ') as [Hreach Hmemo]; auto;
     subst p; auto;
     intros κ' unroll'; pose (Hreach' := Hreach κ' unroll'); destruct Hreach' as [κ [t' [t'' [eunroll [π HT]]]]]
     |].
     ;
     exists (fnκ κ), t', (tick inpoint); split;
     [|exists (shell inpoint κ t'' :: π)]; repeat constructor; auto
    |(* memo *)
    let v := fresh "v" in
    intros v σ'' t' Hmemo;
      assert (HindomM : InDom M (context ce cρ cσ ct)) by
        (destruct Hmemo as [ress [Hmapress Hinress]]; rewrite InDom_is_mapped; [exists ress|exact context_eq_dec]; auto);
      assert (HindomΞ : InDom Ξ (context ce cρ cσ ct)) by (apply Dom_InDom with (l := M); [exact context_eq_dec| | ]; auto);
      destruct (Φ (context ce cρ cσ ct) HindomΞ tκ'); auto].

  part2 p Φ M Ξ (co v σ) (fun κ => (fn v :: κ)).

  Ltac solve_inner point t reach :=
    let tκ' := fresh "tκ'" in
    let cκ := fresh "cκ" in
    let cunroll := fresh "cunroll" in
    let creach := fresh "creach" in
    let cmemo := fresh "cmemo" in
    let t'_ := fresh "t'_" in
    let π := fresh "π" in
    let chκ := fresh "chκ" in
    let cH := fresh "cH" in
    split; [assumption
           |split;[intros chκ cH; destruct (reach chκ) as [t'_ [π ?]];
                   try solve [auto | constructor; auto];
                   exists t'_;
                   exists (Cons (shell point chκ t) π);
                   constructor; [assumption
                                |compute; rewrite <- comparable_ticks with (κ := chκ);
                                 solve [repeat constructor; auto | auto]]
                  |]];
    repeat constructor; auto.
  (* Var lookup *)
  subst; part1 (context ce cρ cσ) tκctx.
  intro tκ'; destruct (Hctx tκ') as [cκ [cunroll [creach cmemo]]];
  exists cκ; solve_inner (ev (var x) ρ σ) t creach.
  intros [cce ccρ ccσ] ccH; pose (Φinst := Φ (context cce ccρ ccσ) ccH); simpl in Φinst.
  intro tκ'; destruct (Φinst tκ') as [κ' [un' [reach' memo']]];
  exists κ'; solve_inner (ev (var x) ρ σ) t reach'.
  (* function eval *)
  subst; part1 (context ce cρ cσ) tκctx.
  intro tκ'; destruct (Hctx (kpush (ar e1 ρ) tκ')) as [cκ [cunroll [creach cmemo]]].
  exists cκ_;
    split; [assumption
           |split;[intros chκ cH
                                                            |]].
  destruct (creach ((ar e1 ρ)::cκ_)) as [t'_ [π ?]]
    inversion cH; subst; auto.
                   try solve [auto | constructor; auto];

 solve_inner (ev (app e0 e1) ρ σ) t creach.

  destruct ctx
  inversion Hctx; subst; try solve [discriminate
                                                              |constructor; auto
                                                             |auto].
 part2 Φ mumble t idκ; repeat split; auto.
    let κ_ := fresh "κ_" in
    let Hunroll_ := fresh "Hunroll_" in
    repeat split; auto;
    intros κ_ Hunroll_;
    inversion Hunroll_ as [|κ__ ? ? Hu__|]; subst;
    destruct (mumble κ__) as [t'_ [π Φreach_path]]; auto;
    exists t'_;
        exists (Cons (shell (ev (app e0 e1) ρ σ) κ__ t) π);
        constructor; [assumption|
                      compute;
                        rewrite <- (comparable_ticks _ _ _ (κ := κ__));
                        solve [constructor; auto
                              |auto]].
  (* lam *)
  subst; part1; part2 Φ mumble t idκ; repeat split; auto.
    let κ_ := fresh "κ_" in
    let Hunroll_ := fresh "Hunroll_" in
    repeat split; auto;
    intros κ_ Hunroll_;
    destruct (mumble κ_) as [t'_ [π Φreach_path]]; auto;
    exists t'_;
        exists (Cons (shell (ev (lam x e) ρ σ) κ_ t) π);
        constructor; [assumption|
                      compute;
                        rewrite <- (comparable_ticks _ _ _ (κ := κ_));
                        solve [constructor; auto
                              |auto]].
  (* evaluated fn, now arg eval *)
    subst; part1; part2 Φ mumble t idκ; repeat split; auto;
    let κ_ := fresh "κ_" in
    let Hunroll_ := fresh "Hunroll_" in
    repeat split; auto;
    intros κ_ Hunroll_;
    inversion Hunroll_ as [|κ__|]; subst;
    destruct (mumble ((ar e ρ)::κ__)) as [t'_ [π Φreach_path]];
      [constructor|];auto;
    exists t'_;
        exists (Cons (shell (co v σ) ((ar e ρ)::κ__) t) π);
        constructor; [assumption
                     |compute; rewrite <- (comparable_ticks _ _ _ (κ := ((ar e ρ)::κ__)));
                      solve [constructor; auto | auto]].
  (* fn -> ap *)
    subst; part1; part2 Φ mumble t idκ; repeat split; auto.
    let κ_ := fresh "κ_" in
    let Hunroll_ := fresh "Hunroll_" in
    repeat split; auto;
    intros κ_ Hunroll_;
    destruct (mumble ((fn fnv)::κ_)) as [t'_ [π Φreach_path]];
    [constructor|]; auto;
    exists t'_;
        exists (Cons (shell (co v σ) ((fn fnv)::κ_) t) π);
        constructor; [assumption|
                      compute;
                        rewrite <- (comparable_ticks _ _ _ (κ := ((fn fnv)::κ_)));
                        solve [constructor; auto
                              |auto]].
  (* do unmemoized ap *)
    part1.
    constructor.
    destruct in_list_join with (eq_dec := context_eq_dec) (combine := κs_join) (base := κ_singleton)
                                                          (l := Ξ) (l' := Ξ) (a := ctx) (c := tκ)
                                                          as [κs [? ?]];
      [intros; apply set_add_intro2
       |intros; simpl
       |
      |exists κs;apply MapsTo_In]; auto.
    let e' := fresh "e'" in
    let ρ'' := fresh "ρ''" in
    let σ'' := fresh "σ''" in
    let tκ' := fresh "tκ'" in
    let κ' := fresh "κ'" in
    let Htκ' := fresh "Htκ'" in
    let Hunroll:= fresh "Hunroll" in
    intros e' ρ'' σ'' tκ' Htκ'.
    destruct (in_list_join_set_split context_eq_dec trunkont_eq_dec)
    with (l := Ξ) (l' := Ξ) (a := ctx) (a' := (context e' ρ'' σ'')) (c := tκ) (c' := tκ')
                  as [[? ?]|ble];
      [unfold in_ctxs in Htκ'; auto
      |(* considered context is the one we extended Ξ with *)
      subst ctx;
        match goal with [H : (context ?uu ?vv ?hh) = (context ?ww ?xx ?yy) |- _] =>
                        injection H; intros aaa bbb ccc; subst ww xx yy end
      |].
    inversion Hctx as [HH|? ? HH|? HH].
    (* mt case *)
    assert (R : tκ' = mt) by congruence; rewrite R.
    exists nil; repeat constructor; auto.
    subst p.
    pose (mar := Φ e ρ' σ' tκ').

match goal with [H' : mt = t
    destruct (Φ e ρ' σ' tκ0) as [stuff boo].
    injection H3; intros aaa bbb ccc; subst e' ρ'' σ''.

    [apply in_list_join2
      |
      |].

    Check in_list_join_split.
    destruct (in_list_join_split context_eq_dec κs_join κ_singleton) with
      (l := Ξ)
      (l' := Ξ)
      (a := ctx)
      (a' := (context e' ρ'' σ''))
      (c := tκ)
      (c' := tκ') as [S0|[S1|S2]]; auto.
    destruct (Φ e' ρ'' σ'' tκ' S0) as [κseen [seenunroll [seenreach seenmemo]]].
    exists κseen; repeat split;
    [apply unroll_with_extension
    |intros κreach reachunroll
    |]; auto.

; specialize seenreach with κreach
 [intros;  | ]; auto.
.: forall l l' a a' c c'
                             (Hcontain : (forall ab, In ab l -> In ab l')),

    destruct Φrinst as [κ' [Hunroll [Φreach Φmemo]]].
    exists (κfn1 κ').

 part2 Φ mumble t idκ; repeat split; auto.
  Focus 3.
  (* return and memoize *)
  inversion Htail as [| | ? ? ? Hunroll Hctxin]; subst;
  [discriminate
  |discriminate
  |match goal with [H : rt ?ctx0 = rt ctx |- _] => injection H; intros; subst end].
  destruct ctx as [e_ ρ_ σ_];
    destruct (Φ e_ ρ_ σ_ tκ' Hin_ctxs) as [κ' [? [? ?]]].

  apply (inv (κ := κ')); try solve [apply unroll_push; auto
                                  |constructor; auto
                                  |auto
                                  |apply Dom_join_left; firstorder].
  intros e'' ρ'' σ'' tκ'' Htκ'';
    pose (Φrinst := (Φ e'' ρ'' σ'' tκ'' Htκ''));
    destruct Φrinst as [κ'' [Hunroll' [Φreach Φmemo]]];
    exists κ'';
    destruct Φreach as [t'_ [π Φreach_path]];
    repeat split; [auto
                  |exists t'_|].

 solve [auto |
      (* reach *)
      exists t'_;
        exists (Cons (shell (co v σ) (rt (context e_ ρ_ σ_)) t) π);
        constructor; [assumption|
                      compute;
                        rewrite <- (comparable_ticks _ _ _ (κ := κ));
                        solve [constructor; auto
                              |auto]]
            |(* memo *) auto].
      part2 Φ point κ t.

  subst; common Φ κ' (co v σ) κ t.

  constructor.
  subst; common Φ κ (co v σ) (rt ctx) t.

  apply inv with (κ := κ); auto; subst.
  (* satisfy hyps of inv first *)
  apply Dom_join_right; auto.
  apply unroll_rt with (tκ := tκ); [apply unroll_with_extension; auto
                                   |apply in_list_join; solve [
                                                            intros; apply set_add_intro1; auto
                                                          | intros; apply set_add_intro2; auto
                                                          | auto]];
  subst.
  intros e'' ρ'' σ'' tκ'' κ'' Htκ'' Hunroll'.
  destruct (in_list_join_split context_eq_dec
                               κs_join
                               κ_singleton
                               κs_join_extensive
                               Ξ
                               Ξ
                               ctx
                               tκ
                               (fun a b => b)
                               (a' := (context e'' ρ'' σ''))
                               (c' := tκ'')) as [Hctx|[Hctx|Hctx]];
    auto.
  (* first case: already there *)
  pose (Φrinst := (Φ e'' ρ'' σ'' tκ'' κ'' Hctx)).
    destruct Φrinst as [Φreach Φmemo];
    destruct Φreach as [t'_ [π Φreach_path]].

                               Ξ' (* l *)
                               Ξ' (* l' *)
                               ctx (* a *)
                               (context e'' ρ'' σ'') (* a' *)
                               tκ (* c *)
                               tκ'' (* c' *).
  (* unmemoized ap inv needs to split on ctx mapped before or is new *)
  part2 Φ (ap x e ρ v σ) κ t.
  inversion Htκ'' as [tκs [Hinp Hinr]].

  pose (Φparinst := (Φ e'' ρ'' σ'' tκ'' κ'' n'')).
  red in Hinp.
  pose (Φrinst := ).
    destruct Φrinst as [Φreach Φmemo];
    destruct Φreach as [t'_ [π Φreach_path]].

  part2 Φ (ap x e ρ v σ) κ t n.
  (* do memoized ap *)

  assert (Htail' : StackUnroll Ξ' κ tκ (ctx :: G)).
  apply unroll_with_extension with (G := G);[assumption|].
  apply sublist_extension with (l'' := [ ctx ]).
 with (G' := (set_add context_eq_dec ctx G)); try solve [auto | apply subset_refl].
  apply unroll_rt with (tκ := tκ); try solve [intro bad; inversion bad].
  unfold in_ctxs.
  apply in_list_join; auto;
  intros; apply set_add_intro2; auto.
  pose (Φrinst := (Φ e ρ' σ' (rt ctx) κ' Htκ' Htail));
    destruct Φrinst as [Φreach Φmemo];
    destruct Φreach as [t'_ [π Φreach_path]].
*)


From Undecidability.Synthetic Require Import DecidabilityFacts SemiDecidabilityFacts.
Require Cantor.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypesDef.

Local Notation "'if!' x 'is' p 'then' a 'else' b" := (match x with p => a | _ => b end) (at level 0, p pattern).

Lemma enumerable_semi_decidable {X} {p : X -> Prop} :
  discrete X -> enumerable p -> semi_decidable p.
Proof.
  unfold enumerable, enumerator.
  intros [d Hd] [f Hf].
  exists (fun x n => if! f n is Some y then d (x,y) else false).
  intros x. rewrite Hf. split.
  - intros [n Hn]. exists n.
    rewrite Hn. now eapply Hd.
  - intros [n Hn]. exists n.
    destruct (f n); inversion Hn.
    eapply Hd in Hn. now subst.
Qed.

Definition enumerator__T' X f := forall x : X, exists n : nat, f n = Some x.
Notation enumerator__T f X := (enumerator__T' X f).
Definition enumerable__T X := exists f : nat -> option X, enumerator__T f X.

Lemma semi_decider_enumerator {X} {p : X -> Prop} {e f} :
  enumerator__T e X -> semi_decider f p -> {g | enumerator g p}.
Proof.
  unfold semi_decider. intros He Hf.
  exists (fun p => let (n, m) := Cantor.of_nat p in
           if! e n is Some x then if f x m then Some x else None else None).
  intros x. rewrite Hf. split.
  - intros [n Hn]. destruct (He x) as [m Hm].
    exists (Cantor.to_nat (m,n)). now rewrite Cantor.cancel_of_to, Hm, Hn.
  - intros [mn Hmn]. destruct (Cantor.of_nat mn) as (m, n).
    destruct (e m) as [x'|]; try congruence.
    destruct (f x' n) eqn:E; inversion Hmn. subst.
    exists n. exact E.
Qed.

Lemma semi_decidable_enumerable {X} {p : X -> Prop} :
  enumerable__T X -> semi_decidable p -> enumerable p.
Proof.
  intros [e He] [f Hf].
  destruct (semi_decider_enumerator He Hf) as [g Hg].
  now exists g.
Qed.

Theorem dec_count_enum {X} {p : X -> Prop} :
  decidable p -> enumerable__T X -> enumerable p.
Proof.
  intros ? % decidable_semi_decidable ?.
  now eapply semi_decidable_enumerable.
Qed.

Theorem dec_count_enum' X (p : X -> Prop) :
  decidable p -> enumerable__T X -> enumerable (fun x => ~ p x).
Proof.
  intros ? % dec_compl ?. eapply dec_count_enum; eauto.
Qed.

Lemma enumerable_enumerable_T X :
  enumerable (fun _ : X => True) <-> enumerable__T X.
Proof.
  split.
  - intros [e He]. exists e. intros x. now eapply He.
  - intros [c Hc]. exists c. intros x. split; eauto.
Qed.

(* Type enumerability facts  *)

Definition nat_enum (n : nat) := Some n.
Lemma enumerator__T_nat :
  enumerator__T nat_enum nat.
Proof.
  intros n. cbv. eauto.
Qed.

Definition unit_enum (n : nat) := Some tt.
Lemma enumerator__T_unit :
  enumerator__T unit_enum unit.
Proof.
  intros []. cbv. now exists 0.
Qed.

Definition False_enum (n : nat) : option False := None.
Lemma enumerator__T_False :
  enumerator__T False_enum False.
Proof.
  intros [].
Qed.

Definition bool_enum (n : nat) := Some (if! n is 0 then true else false).
Lemma enumerator__T_bool :
  enumerator__T bool_enum bool.
Proof.
  intros []. cbv.
  - now exists 0.
  - now exists 1.
Qed.

Definition prod_enum {X Y} (f1 : nat -> option X) (f2 : nat -> option Y) n : option (X * Y) :=
  let (n, m) := Cantor.of_nat n in
  if! (f1 n, f2 m) is (Some x, Some y) then Some (x, y) else None.
Lemma enumerator__T_prod {X Y} f1 f2 :
  enumerator__T f1 X -> enumerator__T f2 Y ->
  enumerator__T (prod_enum f1 f2) (X * Y).
Proof.
  intros H1 H2 (x, y).
  destruct (H1 x) as [n1 Hn1], (H2 y) as [n2 Hn2].
  exists (Cantor.to_nat (n1, n2)). unfold prod_enum.
  now rewrite Cantor.cancel_of_to, Hn1, Hn2.
Qed.

Definition option_enum {X} (f : nat -> option X) n :=
  match n with 0 => Some None | S n => Some (f n) end.
Lemma enumerator__T_option {X} f :
  enumerator__T f X -> enumerator__T (option_enum f) (option X).
Proof.
  intros H [x | ].
  - destruct (H x) as [n Hn]. exists (S n). cbn. now rewrite Hn.
  - exists 0. reflexivity.
Qed.

Definition sigT_enum {X: Type} {P : X -> Type}
  (f : nat -> option X) (fP : forall x, nat -> option (P x)) (n : nat) :
    option {x : X & P x} :=
  let (nx, nP) := Cantor.of_nat n in
  match f nx with
  | Some x =>
    match fP x nP with
    | Some y => Some (existT P x y)
    | _ => None
    end
  | None => None
  end.
Lemma enumerator__T_sigT {X: Type} {P : X -> Type} f fP :
  enumerator__T f X -> (forall x, enumerator__T (fP x) (P x)) ->
  enumerator__T (sigT_enum f fP) {x : X & P x}.
Proof.
  intros Hf HfP [x HPx].
  destruct (Hf x) as [nx Hnx].
  destruct (HfP x (HPx)) as [nP HnP].
  exists (Cantor.to_nat (nx, nP)).
  unfold sigT_enum.
  now rewrite !Cantor.cancel_of_to, Hnx, HnP.
Qed.

Definition sigT2_enum {X: Type} {P : X -> Type} {Q : X -> Type}
  (f : nat -> option X) (fP : forall x, nat -> option (P x)) (fQ : forall x, nat -> option (Q x)) (n : nat) :
    option {x : X & P x & Q x} :=
  let (nx, m) := Cantor.of_nat n in
  let (nP, nQ) := Cantor.of_nat m in
  match f nx with
  | Some x =>
    match fP x nP, fQ x nQ with
    | Some y, Some z => Some (existT2 P Q x y z)
    | _, _ => None
    end
  | None => None
  end.
Lemma enumerator__T_sigT2 {X: Type} {P : X -> Type} {Q : X -> Type} f fP fQ :
  enumerator__T f X -> (forall x, enumerator__T (fP x) (P x)) -> (forall x, enumerator__T (fQ x) (Q x)) ->
  enumerator__T (sigT2_enum f fP fQ) {x : X & P x & Q x}.
Proof.
  intros Hf HfP HfQ [x HPx HQx].
  destruct (Hf x) as [nx Hnx].
  destruct (HfP x (HPx)) as [nP HnP].
  destruct (HfQ x (HQx)) as [nQ HnQ].
  exists (Cantor.to_nat (nx, Cantor.to_nat (nP, nQ))).
  unfold sigT2_enum.
  now rewrite !Cantor.cancel_of_to, Hnx, HnP, HnQ.
Qed.

Require Import List.

Definition finType_enum {X: finType} (n : nat) : option X :=
  nth_error (@enum _ (class X)) n.
Lemma enumerator__T_finType {X: finType} :
  enumerator__T finType_enum X.
Proof.
  intros x.
  assert (H := (@enum_ok _ (class X)) x).
  unfold finType_enum. induction enum as [|y L IH].
  - easy.
  - cbn in H. destruct (Dec (x = y)) as [->|H'].
    + now exists 0.
    + destruct (IH H) as [n Hn]. now exists (S n).
Qed.

Fixpoint all_fins (n : nat) : list (Fin.t n) :=
  match n with
  | 0 => nil
  | S n => Fin.F1 :: map Fin.FS (all_fins n)
  end.

Definition Fin_enum {k: nat} (n : nat) : option (Fin.t k) :=
  nth_error (all_fins k) n.
Lemma enumerator__T_Fin {k: nat} :
  enumerator__T Fin_enum (Fin.t k).
Proof.
  intros t. exists (proj1_sig (Fin.to_nat t)).
  unfold Fin_enum. induction t as [n|n t IH].
  { reflexivity. }
  cbn. destruct (Fin.to_nat t) as [t' H']. cbn in *.
  now rewrite nth_error_map, IH.
Qed.

Opaque Cantor.to_nat Cantor.of_nat.

Fixpoint Vector_enum {X: Type} {k: nat} (f : nat -> option X) (n : nat) : option (Vector.t X k) :=
  match k return option (Vector.t X k) with
  | 0 => Some (@Vector.nil X)
  | S k' =>
    let (nx, m) := Cantor.of_nat n in
    match f nx with
    | Some x =>
      match (@Vector_enum X k' f m) with
      | Some v => Some (@Vector.cons X x k' v)
      | _ => None
      end
    | None => None
    end
  end.
Lemma enumerator__T_Vector {X: Type} {k: nat} (f : nat -> option X) :
  enumerator__T f X -> enumerator__T (Vector_enum f) (Vector.t X k).
Proof.
  intros Hf. induction k as [|k IH].
  { intros t. pattern t. apply (Vector.case0). now exists 0. }
  intros t. rewrite (Vector.eta t).
  destruct (Hf (VectorDef.hd t)) as [nx Hnx].
  destruct (IH (VectorDef.tl t)) as [m Hm].
  exists (Cantor.to_nat (nx, m)).
  cbn. now rewrite Cantor.cancel_of_to, Hnx, Hm.
Qed.

Existing Class enumerator__T'.
(* Existing Class enumerable__T. *)

Lemma enumerator_enumerable {X} {f} :
  enumerator__T f X -> enumerable__T X.
Proof.
  intros H. exists f. eapply H.
Qed.
#[export] Hint Resolve enumerator_enumerable : core.

#[global] Existing Instance enumerator__T_prod.
#[global] Existing Instance enumerator__T_option.
#[global] Existing Instance enumerator__T_bool.
#[global] Existing Instance enumerator__T_False.
#[global] Existing Instance enumerator__T_unit.
#[global] Existing Instance enumerator__T_nat.
#[global] Existing Instance enumerator__T_sigT.
#[global] Existing Instance enumerator__T_sigT2.
#[global] Existing Instance enumerator__T_finType.
#[global] Existing Instance enumerator__T_finType.
#[global] Existing Instance enumerator__T_Fin.
#[global] Existing Instance enumerator__T_Vector.


Require Export Qual.grade.

Set Implicit Arguments.

(* Notes:

   Consider P |- psi a ~~ b

   We need to have P |- psi a (GEq_Grade) so that we do lifting/equality
   substitution. We need to know which variables are relevant (those in P with
   grades <= psi) and which ones are not.

   Reflexivity requires P |- psi a

   Lifting:

           P, x:psi |- phi b
           P |- phi psi a1 ~ a2
           P |- phi b {a1/x} ~~ b {a2/x}
*)

(* relationship to grade *)

Lemma CEq_GEq_Grade :
  (forall P phi phi0 a b,
  CEq P phi phi0 a b -> CGrade P phi phi0 a /\ CGrade P phi phi0 b) /\
  (forall P phi a b,
  GEq P phi a b -> Grade P phi a /\ Grade P phi b).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; split_hyp; split; eauto using leq_join_r.
  all: try solve [fresh_apply_Grade x; eauto;
    repeat spec x; split_hyp; eauto].
Qed.

Lemma GEq_Grade1 :
  (forall P phi a b,
  GEq P phi a b -> Grade P phi a).
Proof. apply CEq_GEq_Grade. Qed.
Lemma GEq_Grade2 :
  (forall P phi a b,
  GEq P phi a b -> Grade P phi b).
Proof. apply CEq_GEq_Grade. Qed.

(* ------------------------------ context stuff ----------------------- *)

(* Graded/Guarded equality is an equivalence/congruence relation, closed under substitution and implies consistency. *)

Lemma CEq_GEq_refl : (forall P phi psi a, CGrade P phi psi a -> CEq P phi psi a a) /\
                     (forall P phi a, Grade P phi a -> GEq P phi a a).
Proof.
  apply CGrade_Grade_mutual.
  all: intros; eauto.
Qed.

Lemma GEq_refl :  (forall P phi a, Grade P phi a -> GEq P phi a a).
  apply CEq_GEq_refl; auto.
Qed.

Lemma CEq_refl : forall P phi a psi, CGrade P phi psi a -> CEq P phi psi a a.
Proof.
  destruct CEq_GEq_refl; auto.
Qed.

Lemma CEq_GEq_sym :
  (forall P phi phi0 a b,
  CEq P phi phi0 a b -> CEq P phi phi0 b a) /\
  (forall P phi a b,
  GEq P phi a b -> GEq P phi b a).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; eauto.
Qed.

Lemma GEq_symmetry :   (forall P phi a b,
  GEq P phi a b -> GEq P phi b a).
Proof. apply CEq_GEq_sym. Qed.

Lemma CEq_GEq_trans :
  (forall P  phi phi0 a b,
  CEq P phi phi0 a b -> forall c, CEq P phi phi0 b c  -> CEq P phi phi0 a c) /\
  (forall P phi a b,
  GEq P phi a b -> forall c, GEq P phi b c -> GEq P phi a c).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; subst; eauto.
  all: try match goal with
    | [ H: GEq ?P ?ps (_ _ ) ?c |- _ ] => inversion H; subst; clear H end.
  all: eauto.

  all: try (fresh_apply_GEq x; eauto; repeat spec x).
  - (* leq *)
    inversion H0. subst. eauto. done.
  - (* nleq *)
    inversion H; subst. done.
    eapply CEq_Nleq; eauto.
Qed.

Lemma GEq_trans : forall P phi a b c, GEq P phi a b -> GEq P phi b c -> GEq P phi a c.
Proof.
  intros.
  destruct CEq_GEq_trans.
  eapply H2; eauto.
Qed.

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

(*
     b1  ->  b2
  phi =     phi .=
     b1' .-> b2'

*)

Lemma CEq_GEq_respects_Step :
  (forall P phi phi0 b1 b1',
  CEq P phi phi0 b1 b1' ->  forall b2, Step b1 b2 ->
       exists b2', (phi0 <= phi -> Step b1' b2') /\ CEq P phi phi0 b2 b2') /\
  (forall P phi b1 b1',
  GEq P phi b1 b1' -> forall b2, Step b1 b2 ->
       exists b2', Step b1' b2' /\ GEq P phi b2 b2').
Proof.
  eapply CEq_GEq_mutual.
  all: intros; subst; eauto.
  all: match goal with [ H : Step _ _ |- _ ] => inversion H; subst end.
  all: try
    let b2' := fresh in
    let ss' := fresh in
    let GE' := fresh in
    match goal with [ H : forall b3, Step ?b1 b3 -> _ , H2 : Step ?b1 ?a' |- _ ] =>
                  destruct (H _ H2) as [b2' [ss' GE']] ; clear H end.
  all: split_hyp.
  all: try solve [
             eexists; split;
             econstructor;
             eauto 3 using CEq_refl, GEq_lc2, CEq_lc2, CEq_uniq].
  (* all: try solve [
             inversion g; subst;
             eexists; split; eauto using GEq_lc2, CEq_lc2]. *)
  all: try solve [
    eexists; split; try (intro h; eauto; done);
    eapply CEq_Leq; eauto].
  all: try solve [
    eexists; split; try (intro h; done);
    eapply CEq_Nleq; eauto 3 using Step_lc2] .

  - (* beta *)
    inversion g. subst.
    pick fresh x. spec x.
    exists (open_tm_wrt_tm b0 a2). split.
    econstructor; eauto using GEq_lc2; eauto using CEq_lc2.
    eapply GEq_open; eauto.
  - (* LetPair beta *)
    inversion g. subst.
    pick fresh x. spec x.
    exists (a_App (open_tm_wrt_tm b2 a4) q_Bot b3). split.
    econstructor; eauto using GEq_lc2; eauto using CEq_lc2.
    econstructor; eauto.
    eapply GEq_open; eauto.
    eapply CEq_Leq; eauto using leq_Bot.
  - (* Proj1 beta *)
    inversion g. subst.
    exists a0. split.
    econstructor; eauto using GEq_lc2, CEq_lc2.
    inversion H9; subst; auto. done.
  - (* Proj2 beta *)
    inversion g; subst.
    eexists b0. split; auto;
    econstructor; eauto using GEq_lc2, CEq_lc2.
  - (* Case beta *)
    inversion g; subst.
    eexists (a_App b1' psi0 a1'). split; auto.
    eapply S_Case1Beta; eauto using GEq_lc2, CEq_lc2.
  - inversion g; subst.
    eexists (a_App b2' psi0 a2'). split; auto.
    eapply S_Case2Beta; eauto using GEq_lc2, CEq_lc2.
Qed.


(* This file contains the specification of a lock module discussed
   in the section on the Fancy update modality and weakest precondition
   in the Iris Lecture Notes.
     Recall from loc. cit. that the point of this
   alternative lock specification is that it allows ones
   to allocate the lock before one knows what the resource
   of the invariant it is going to protect is.
*)

(* Contains definitions of the weakest precondition assertion, and its basic rules. *)
From iris.program_logic Require Export weakestpre.

(* Instantiation of Iris with the particular language. The notation file
   contains many shorthand notations for the programming language constructs, and
   the lang file contains the actual language syntax. *)
From iris.heap_lang Require Export notation lang.

(* Files related to the interactive proof mode. The first import includes the
   general tactics of the proof mode. The second provides some more specialized
   tactics particular to the instantiation of Iris to a particular programming
   language. *)
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode.

(* Definition of invariants and their rules (expressed using the fancy update
   modality). *)
From iris.base_logic.lib Require Export invariants.

(* The exclusive resource algebra *)
From iris.algebra Require Import excl.

Section lock_model.
(* In order to do the proof we need to assume certain things about the
   instantiation of Iris. The particular, even the heap is handled in an
   analogous way as other ghost state. This line states that we assume the Iris
   instantiation has sufficient structure to manipulate the heap, e.g., it
   allows us to use the points-to predicate, and that the ghost state includes
   the exclusive resource algebra over the singleton set (represented using the
   unitR type). *)

  Context `{heapG Σ}.
  Context `{inG Σ (exclR unitR)}.

  (* We use a ghost name with a token to model whether the lock is locked or not.
     The the token is just exclusive ownerwhip of unit value. *)
  Definition locked γ := own γ (Excl ()).

  (* The name of a lock. *)
  Definition lockN (l : loc) := nroot .@ "lock" .@ l.

  (* The lock invariant *)
  Definition is_lock γ l P :=
    inv (lockN l) ((l ↦ (#false) ∗ P ∗ locked γ) ∨
                                l ↦ (#true))%I.

  (* The is_lock predicate is persistent *)
  Global Instance is_lock_persistent γ l Φ : Persistent (is_lock γ l Φ).
  Proof. apply _. Qed.

End lock_model.

Section lock_code.

  (* Here is the standard spin lock code *)

  Definition newlock : val := λ: <>, ref #false.
  Definition acquire : val :=
    rec: "acquire" "l" :=
      if: CAS "l" #false #true then #() else "acquire" "l".
  Definition release : val := λ: "l", "l" <- #false.

End lock_code.

Section lock_spec.
  Context `{heapG Σ}.
  Context `{inG Σ (exclR unitR)}.

  (* Here is the interesting part of this example, namely the new specification
     for newlock, which allows one to get a post-condition which can be instantiated
     with the lock invariant at some point later, when it is known.
     See the discussion in Iris Lecture Notes.
     First we show the specs using triples, and afterwards using weakest preconditions.
  *)

  Lemma wp_newlock_t :
    {{{ True }}} newlock #() {{{v, RET v; ∃ (l: loc) γ, ⌜v = #l⌝ ∧ (∀ P E, P ={E}=∗ is_lock γ l P) }}}.
  Proof.
    iIntros (φ) "Hi Hcont".
    rewrite -wp_fupd /newlock.
    wp_lam.
    wp_alloc l as "HPt".
    iApply "Hcont".
    iExists l.
    iMod (own_alloc (Excl ())) as (γ) "Hld"; first done.
    iExists γ.
    iModIntro. iSplit; first done.
    iIntros (P E) "HP".
    iMod (inv_alloc _ _
           ((l ↦ (#false) ∗ P ∗ locked γ) ∨ l ↦ (#true))%I with "[-]")
      as "Hinv"; last eauto.
    { iNext; iLeft; iFrame. }
  Qed.

  Lemma wp_acquire_t E γ l P :
    nclose (lockN l) ⊆ E →
    {{{ is_lock γ l P }}} acquire (#l) @ E {{{v, RET #v; P ∗ locked γ}}}.
  Proof.
    iIntros (HE φ) "#Hi Hcont"; rewrite /acquire.
    iLöb as "IH".
    wp_rec.
    wp_bind (CmpXchg _ _ _).
    iInv (lockN l) as "[(Hl & HP & Ht)|Hl]" "Hcl".
    - wp_cmpxchg_suc.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iApply "Hcont".
      iFrame.
    - wp_cmpxchg_fail.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iApply ("IH" with "[$Hcont]").
  Qed.

  Lemma wp_release_t E γ l P :
    nclose (lockN l) ⊆ E →
    {{{ is_lock γ l P ∗ locked γ ∗ P }}} release (#l) @ E {{{RET #(); True}}}.
  Proof.
    iIntros (HE φ) "(#Hi & Hld & HP) Hcont"; rewrite /release.
    wp_lam.
    iInv (lockN l) as "[(Hl & HQ & >Ht)|Hl]" "Hcl".
    - iDestruct (own_valid_2 with "Hld Ht") as %Hv. done.
    - wp_store.
      iMod ("Hcl" with "[-Hcont]") as "_"; first by iNext; iLeft; iFrame.
      iApply "Hcont".
      done.
  Qed.

  (* Here are the specifications again, just written using weakest preconditions *)

  Lemma wp_newlock :
    True ⊢ WP newlock #() {{v, ∃ (l: loc) γ, ⌜v = #l⌝ ∧ (∀ P E, P ={E}=∗ is_lock γ l P) }}.
  Proof.
    iIntros "_".
    rewrite -wp_fupd /newlock.
    wp_lam.
    wp_alloc l as "HPt".
    iExists l.
    iMod (own_alloc (Excl ())) as (γ) "Hld"; first done.
    iExists γ.
    iModIntro. iSplit; first done.
    iIntros (P E) "HP".
    iMod (inv_alloc _ _
           ((l ↦ (#false) ∗ P ∗ locked γ) ∨ l ↦ (#true))%I with "[-]")
      as "Hinv"; last eauto.
    { iNext; iLeft; iFrame. }
  Qed.

  Lemma wp_acquire E γ l P :
    nclose (lockN l) ⊆ E →
    is_lock γ l P ⊢ WP acquire (#l) @ E {{v, P ∗ locked γ}}.
  Proof.
    iIntros (HE) "#Hi"; rewrite /acquire.
    iLöb as "IH".
    wp_rec.
    wp_bind (CmpXchg _ _ _).
    iInv (lockN l) as "[(Hl & HP & Ht)|Hl]" "Hcl".
    - wp_cmpxchg_suc.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iFrame.
    - wp_cmpxchg_fail.
      iMod ("Hcl" with "[Hl]") as "_"; first by iRight.
      iModIntro.
      wp_proj.
      wp_if.
      iApply "IH".
  Qed.

  Lemma wp_release E γ l P :
    nclose (lockN l) ⊆ E →
    is_lock γ l P ∗ locked γ ∗ P ⊢ WP release (#l) @ E {{v, True}}.
  Proof.
    iIntros (HE) "(#Hi & Hld & HP)"; rewrite /release.
    wp_lam.
    iInv (lockN l) as "[(Hl & HQ & >Ht)|Hl]" "Hcl".
    - iDestruct (own_valid_2 with "Hld Ht") as %Hv. done.
    - wp_store.
      iMod ("Hcl" with "[-]") as "_"; first by iNext; iLeft; iFrame.
      done.
  Qed.

  Global Opaque newlock release acquire.

  (* We now present a simple client of the lock which cannot be verified with the
     lock specification described in the Chapter on Invariants and Ghost State in the
     Iris Lecture Notes, but which can be specifed and verified with the current
     specification.
  *)
  Definition test : expr :=
    let: "l" := newlock #() in
    let: "r" := ref #0 in
    (λ: <>, acquire "l";; "r" <- !"r" + #1;; release "l").

  Lemma test_spec :
    {{{ True }}} test #() {{{ v, RET v; True }}}.
  Proof.
    iIntros (φ) "Hi HCont"; rewrite /test.
    wp_bind (newlock #())%E.
    iApply (wp_newlock_t); auto.
    iNext.
    iIntros (v) "Hs".
    wp_let.
    wp_bind (ref #0)%E.
    wp_alloc l as "Hl".
    wp_let.
    wp_seq.
    wp_bind (acquire v)%E.
    iDestruct "Hs" as (l' γ) "[% H2]".
    subst.
    iMod ("H2" $! (∃ (n : Z), l ↦ #n)%I with "[Hl]") as "#H3".
    { iExists 0; iFrame. }
    wp_apply (wp_acquire_t with "H3"); auto.
    iIntros (v) "(Hpt & Hlocked)".
    iDestruct "Hpt" as (u) "Hpt".
    wp_seq.
    wp_load.
    wp_op.
    wp_store.
    wp_apply (wp_release_t with "[-HCont]"); auto.
    iFrame "H3 Hlocked".
    iExists _; iFrame.
  Qed.
End lock_spec.

Typeclasses Opaque locked.
Global Opaque locked.
Typeclasses Opaque is_lock.
Global Opaque is_lock.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defcross_1 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_2 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable lemma_betweennotequal_3 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_betweennesssymmetry_4 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defcollinear_5 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_6 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_7 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_8 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_9 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_10 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_11 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_12 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_parallelNC_13 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable lemma_NCorder_14 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable defoppositeside_15 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_16 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_parallelsymmetric_17 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_parallelflip_18 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable proposition_29B_19 : (forall A D G H : Universe, ((par_ A G H D /\ tS_ A G H D) -> congA_ A G H G H D)).
Variable lemma_equalanglessymmetric_20 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglestransitive_21 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_NCdistinct_22 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_layoff_23 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_inequalitysymmetric_24 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_ray4_1_25 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_26 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_27 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable cn_congruencereflexive_28 : (forall A B : Universe, cong_ A B A B).
Variable lemma_equalanglesreflexive_29 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalangleshelper_30 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_rayimpliescollinear_31 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_raystrict_32 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable lemma_NChelper_33 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable proposition_04_34 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable defsameside_35 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_36 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).
Variable lemma_ray5_37 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_samesidereflexive_38 : (forall A B P : Universe, (~(col_ A B P) -> oS_ P P A B)).
Variable lemma_sameside2_39 : (forall A B C E F G : Universe, ((oS_ E F A C /\ (col_ A B C /\ out_ B F G)) -> oS_ E G A C)).
Variable lemma_samesidetransitive_40 : (forall A B P Q R : Universe, ((oS_ P Q A B /\ oS_ Q R A B) -> oS_ P R A B)).
Variable lemma_congruenceflip_41 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable proposition_07_42 : (forall A B C D : Universe, ((A <> B /\ (cong_ C A D A /\ (cong_ C B D B /\ oS_ C D A B))) -> C = D)).

Theorem lemma_Playfairhelper_43 : (forall A B C D E : Universe, ((par_ A B C D /\ (par_ A B C E /\ (cR_ A D B C /\ cR_ A E B C))) -> col_ C D E)).
Proof.
  time tac.
Qed.

End FOFProblem.


From PetitC Require Import InbuiltFunc InbuiltFuncSemantics Memory Output Values Tactics.

From Coq Require Import ZArith.

Lemma inbuilt_func_deterministic :
  forall inbuilt_func arg_vals return_val_option return_val_option' mem out mem' out' mem'' out'',
      inbuilt_func_step inbuilt_func arg_vals return_val_option mem out mem' out' ->
      inbuilt_func_step inbuilt_func arg_vals return_val_option' mem out mem'' out'' ->
      mem' = mem'' /\ out' = out'' /\ return_val_option = return_val_option'.
Proof.
  intros.
  inv H; inv H0;
  repeat split; try reflexivity;
  rewrite <- H1 in H3; apply Nat2Z.inj in H3; subst;
  rewrite <- H2 in H4; injection H4; intros; subst; reflexivity.
Qed.