Require Import GL4ip_PSGL4ip_calcs.
Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import GL4ip_PSGL4ip_list_lems.
Require Import dd_fc.
Require Import PeanoNat.
Require Import strong_inductionT.
Require Import GL4ip_exch.
Require Import GL4ip_wkn.
Require Import GL4ip_PSGL4ip_remove_list.
Require Import GL4ip_PSGL4ip_dec.
Require Import GL4ip_inv_AndR_AndL.
Require Import GL4ip_inv_OrL.
Require Import GL4ip_inv_AtomImpL.
Require Import GL4ip_inv_AndImpL.
Require Import GL4ip_inv_OrImpL.
Require Import GL4ip_inv_ImpImpL_R.
Require Import GL4ip_inv_BoxImpL_R.
Require Import Lia.

Theorem ImpL_adm : forall n s (D0:derrec GL4ip_rules (fun _ => False) s) A B Γ0 Γ1 C,
                                n = derrec_height D0 ->
                               (s = (Γ0 ++ Γ1, A)) ->
                               derrec GL4ip_rules (fun _ => False) (Γ0 ++ B :: Γ1, C) ->
                               derrec GL4ip_rules (fun _ => False) (Γ0 ++ Imp A B :: Γ1, C).
Proof.
assert (DersNilF: dersrec GL4ip_rules (fun _ : (list (MPropF V)) *(MPropF V)  => False) []).
apply dersrec_nil.
(* Setting up the strong induction on the height. *)
pose (strong_inductionT (fun (x:nat) => forall (concl : (list (MPropF V)) *(MPropF V))
  (D0:derrec GL4ip_rules (fun _ => False) concl) A B Γ0 Γ1 C,
                                x = derrec_height D0 ->
                               (concl = (Γ0 ++ Γ1, A)) ->
                               derrec GL4ip_rules (fun _ => False) (Γ0 ++ B :: Γ1, C) ->
                               derrec GL4ip_rules (fun _ => False) (Γ0 ++ Imp A B :: Γ1, C))).
apply d. intros n IH. clear d.
(* Now we do the actual proof-theoretical work. *)
intros s D0. remember D0 as D0'. destruct D0.
(* D0 is a leaf *)
- destruct f.
(* D0 is ends with an application of rule *)
- intros A B Γ0 Γ1 C hei eq D1. subst.
  inversion g ; subst.
  (* IdP *)
  * inversion H ; subst.
    assert (J1: derrec_height D1 = derrec_height D1). auto.
    assert (J2: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ # P :: Γ3, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ # P :: Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_hpadm_list_exch_L _ _ _ J1 _ J2). destruct s.
    apply GL4ip_adm_list_exch_L with (s:=(# P → B :: Γ2 ++ # P :: Γ3, C)).
    apply derI with (ps:=[(B :: Γ2 ++ # P :: Γ3, C)]) ; auto. apply AtomImpL2.
    assert (B :: Γ2 ++ # P :: Γ3 = [] ++ B :: Γ2 ++ # P :: Γ3). auto. rewrite H0.
    assert (# P → B :: Γ2 ++ # P :: Γ3 = [] ++ # P → B :: Γ2 ++ # P :: Γ3). auto. rewrite H1. apply AtomImpL2Rule_I.
    apply dlCons ; auto.
    assert (Γ0 ++ # P → B :: Γ1 = [] ++ [] ++ Γ0 ++ [# P → B] ++ Γ1). auto. rewrite H0.
    assert (# P → B :: Γ2 ++ # P :: Γ3 = [] ++ [# P → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* BotL *)
  * inversion H. subst. assert (InT (Bot V) (Γ0 ++ A → B :: Γ1)). assert (InT (Bot V) (Γ0 ++ Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq.
    apply InT_app_or in H0. destruct H0. apply InT_or_app. auto. apply InT_or_app. right.
    apply InT_cons. auto. apply InT_split in H0. destruct H0. destruct s. rewrite e.
    assert (BotLRule [] (x ++ Bot V :: x0, C)). apply BotLRule_I. apply BotL in H0.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : (list (MPropF V)) *(MPropF V) => False)
    (ps:=[]) (x ++ Bot V :: x0, C) H0 DersNilF). auto.
   (* AndR *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl in IH.
    assert (J1: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J2: derrec_height x0 = derrec_height x0). auto.
    assert (J3: (Γ0 ++ Γ1, B0) =(Γ0 ++ Γ1, B0)). auto.
    pose (IH _ J1 _ _ _ _ _ _ _ J2 J3 D1).
    assert (J4: derrec_height x < S (dersrec_height d)). lia.
    assert (J5: derrec_height x = derrec_height x). auto.
    assert (J6: (Γ0 ++ Γ1, A0) =(Γ0 ++ Γ1, A0)). auto.
    pose (IH _ J4 _ _ _ _ _ _ _ J5 J6 d0). apply derI with (ps:=[(Γ0 ++ A0 → B0 → B :: Γ1, C)]).
    apply AndImpL. apply AndImpLRule_I. apply dlCons ; auto.
  (* AndL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ A0 ∧ B0 :: Γ3, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ A0 ∧ B0 :: Γ3, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ A0 ∧ B0 :: Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: AndLRule [((B :: Γ2) ++ A0 :: B0 :: Γ3, C)] ((B :: Γ2) ++ A0 ∧ B0 :: Γ3, C)). apply AndLRule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (AndL_inv _ _ d0 J2).
    assert (J3: derrec_height x < S (dersrec_height d)). lia.
    assert (J4: derrec_height x = derrec_height x). auto.
    assert (J5: (Γ2 ++ A0 :: B0 :: Γ3, A) = ([] ++ Γ2 ++ A0 :: B0 :: Γ3, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d1). simpl in d2.
    apply derI with (ps:=[(A → B :: Γ2 ++ A0 :: B0 :: Γ3, C)]).
    assert (A → B :: Γ2 ++ A0 :: B0 :: Γ3 = (A → B :: Γ2) ++ A0 :: B0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ A0 ∧ B0 :: Γ3 = (A → B :: Γ2) ++ A0 ∧ B0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H1.
    apply AndL. apply AndLRule_I. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ A0 ∧ B0 :: Γ3 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* OrR1 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    assert (J1: derrec_height x < S (dersrec_height d)). lia.
    assert (J2: derrec_height x = derrec_height x). auto.
    assert (J3: (Γ0 ++ Γ1, A0) =(Γ0 ++ Γ1, A0)). auto.
    pose (IH _ J1 _ _ _ _ _ _ _ J2 J3 D1).
    assert (J4: wkn_L (B0 → B) ((Γ0 ++ [A0 → B]) ++ Γ1, C) ((Γ0 ++ [A0 → B]) ++ B0 → B :: Γ1, C)).
    simpl. apply wkn_LI. repeat rewrite <- app_assoc in J4 ; simpl in J4.
    pose (@GL4ip_adm_wkn_L _ d0 _ _ J4). apply derI with (ps:=[(Γ0 ++ A0 → B :: B0 → B :: Γ1, C)]).
    apply OrImpL.
    assert (Γ0 ++ A0 → B :: B0 → B :: Γ1 = Γ0 ++ A0 → B :: [] ++ B0 → B :: Γ1). auto. rewrite H0.
    assert (Γ0 ++ (A0 ∨ B0) → B :: Γ1 = Γ0 ++ (A0 ∨ B0) → B  :: [] ++ Γ1). auto. rewrite H1.
    apply OrImpLRule_I. apply dlCons ; auto.
  (* OrR2 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    assert (J1: derrec_height x < S (dersrec_height d)). lia.
    assert (J2: derrec_height x = derrec_height x). auto.
    assert (J3: (Γ0 ++ Γ1, B0) =(Γ0 ++ Γ1, B0)). auto.
    pose (IH _ J1 _ _ _ _ _ _ _ J2 J3 D1).
    assert (J4: wkn_L (A0 → B) (Γ0 ++ B0 → B :: Γ1, C) (Γ0 ++ A0 → B :: B0 → B :: Γ1, C)).
    simpl. apply wkn_LI.
    pose (@GL4ip_adm_wkn_L _ d0 _ _ J4). apply derI with (ps:=[(Γ0 ++ A0 → B :: B0 → B :: Γ1, C)]).
    apply OrImpL.
    assert (Γ0 ++ A0 → B :: B0 → B :: Γ1 = Γ0 ++ A0 → B :: [] ++ B0 → B :: Γ1). auto. rewrite H0.
    assert (Γ0 ++ (A0 ∨ B0) → B :: Γ1 = Γ0 ++ (A0 ∨ B0) → B  :: [] ++ Γ1). auto. rewrite H1.
    apply OrImpLRule_I. apply dlCons ; auto.
  (* OrL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ A0 ∨ B0 :: Γ3, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ A0 ∨ B0 :: Γ3, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ A0 ∨ B0 :: Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: OrLRule [((B :: Γ2) ++ A0 :: Γ3, C);((B :: Γ2) ++ B0 :: Γ3, C)] ((B :: Γ2) ++ A0 ∨ B0 :: Γ3, C)). apply OrLRule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (OrL_inv _ _ _ d0 J2). destruct p.
    assert (J3: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J4: derrec_height x0 = derrec_height x0). auto.
    assert (J5: (Γ2 ++ B0 :: Γ3, A) = ([] ++ Γ2 ++ B0 :: Γ3, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d2). simpl in d3.
    assert (J6: derrec_height x < S (dersrec_height d)). lia.
    assert (J7: derrec_height x = derrec_height x). auto.
    assert (J8: (Γ2 ++ A0 :: Γ3, A) =([] ++ Γ2 ++ A0 :: Γ3, A)). auto.
    pose (IH _ J6 _ _ _ _ _ _ _ J7 J8 d1). simpl in d4. pose (dlCons d3 DersNilF). pose (dlCons d4 d5).
    apply derI with (ps:=[(A → B :: Γ2 ++ A0 :: Γ3, C); (A → B :: Γ2 ++ B0 :: Γ3, C)]).
    apply OrL.
    assert (A → B :: Γ2 ++ A0 :: Γ3 = (A → B :: Γ2) ++ A0 :: Γ3). repeat rewrite <- app_assoc ; auto. rewrite H0.
    assert (A → B :: Γ2 ++ B0 :: Γ3 = (A → B :: Γ2) ++ B0 :: Γ3). repeat rewrite <- app_assoc ; auto. rewrite H1.
    assert (A → B :: Γ2 ++ A0 ∨ B0 :: Γ3 = (A → B :: Γ2) ++ A0 ∨ B0 :: Γ3). auto. rewrite H3.
    apply OrLRule_I. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ A0 ∨ B0 :: Γ3 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* ImpR *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply derI with (ps:=[(Γ0 ++ B0 → B :: Γ1, A0 → B0);(Γ0 ++ B :: Γ1, C)]). apply ImpImpL.
    apply ImpImpLRule_I. apply dlCons. apply GL4ip_adm_wkn_L with (s:=(Γ0 ++ Γ1, A0 → B0)) (A:=B0 → B) ; auto.
    2: apply wkn_LI. apply derI with (ps:=[(Γ2 ++ A0 :: Γ3, B0)]). apply ImpR. rewrite <- H2. apply ImpRRule_I.
    apply dlCons ; auto. apply dlCons ; auto.
  (* AtomImpL1 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ # P :: Γ3 ++ # P → A0 :: Γ4, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ # P :: Γ3 ++ # P → A0 :: Γ4, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ # P :: Γ3 ++ # P → A0 :: Γ4 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: AtomImpL1Rule [((B :: Γ2) ++ # P :: Γ3 ++ A0 :: Γ4, C)] ((B :: Γ2) ++ # P :: Γ3 ++ # P → A0 :: Γ4, C)). apply AtomImpL1Rule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (AtomImpL_inv P A0 (B :: Γ2 ++ # P :: Γ3) Γ4 C). repeat rewrite <- app_assoc in d1. simpl in d1. repeat rewrite <- app_assoc in d1.
    simpl in d1. apply d1 in d0. clear d1.
    assert (J3: derrec_height x < S (dersrec_height d)). lia.
    assert (J4: derrec_height x = derrec_height x). auto.
    assert (J5: (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, A) = ([] ++ Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d0). simpl in d1.
    apply derI with (ps:=[(A → B :: Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, C)]).
    assert (A → B ::Γ2 ++ # P :: Γ3 ++ # P → A0 :: Γ4 = (A → B :: Γ2) ++ # P :: Γ3 ++ # P → A0 :: Γ4). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ # P :: Γ3 ++ A0 :: Γ4 = (A → B :: Γ2) ++ # P :: Γ3 ++ A0 :: Γ4). repeat rewrite <- app_assoc. auto. rewrite H1.
    apply AtomImpL1. apply AtomImpL1Rule_I. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ # P :: Γ3 ++ # P → A0 :: Γ4 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* AtomImpL1 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ # P → A0 :: Γ3 ++ # P :: Γ4, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ # P → A0 :: Γ3 ++ # P :: Γ4, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ # P → A0 :: Γ3 ++ # P :: Γ4 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: AtomImpL2Rule [((B :: Γ2) ++ A0 :: Γ3 ++ # P :: Γ4, C)] ((B :: Γ2) ++ # P → A0 :: Γ3 ++ # P :: Γ4, C)). apply AtomImpL2Rule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (AtomImpL_inv P A0 (B :: Γ2) (Γ3 ++ # P :: Γ4) C). repeat rewrite <- app_assoc in d1. simpl in d1. repeat rewrite <- app_assoc in d1.
    simpl in d1. apply d1 in d0. clear d1.
    assert (J3: derrec_height x < S (dersrec_height d)). lia.
    assert (J4: derrec_height x = derrec_height x). auto.
    assert (J5: (Γ2 ++ A0 :: Γ3 ++ # P :: Γ4, A) = ([] ++ Γ2 ++ A0 :: Γ3 ++ # P :: Γ4, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d0). simpl in d1.
    apply derI with (ps:=[(A → B :: Γ2 ++ A0 :: Γ3 ++ # P :: Γ4, C)]).
    assert (A → B ::Γ2 ++ # P → A0 :: Γ3 ++ # P :: Γ4 = (A → B :: Γ2) ++ # P → A0 :: Γ3 ++ # P :: Γ4). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ A0 :: Γ3 ++ # P :: Γ4 = (A → B :: Γ2) ++ A0 :: Γ3 ++ # P :: Γ4). repeat rewrite <- app_assoc. auto. rewrite H1.
    apply AtomImpL2. apply AtomImpL2Rule_I. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ # P → A0 :: Γ3 ++ # P :: Γ4 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
 (* AndImpL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ (A0 ∧ B0) → C0 :: Γ3, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ (A0 ∧ B0) → C0 :: Γ3, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ (A0 ∧ B0) → C0 :: Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: AndImpLRule [((B :: Γ2) ++ (A0 → B0 → C0) :: Γ3, C)] ((B :: Γ2) ++ (A0 ∧ B0) → C0 :: Γ3, C)). apply AndImpLRule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (AndImpL_inv _ _ d0 J2).
    assert (J3: derrec_height x < S (dersrec_height d)). lia.
    assert (J4: derrec_height x = derrec_height x). auto.
    assert (J5: (Γ2 ++ A0 → B0 → C0 :: Γ3, A) = ([] ++ Γ2 ++ A0 → B0 → C0 :: Γ3, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d1). simpl in d2.
    apply derI with (ps:=[(A → B :: Γ2 ++ A0 → B0 → C0 :: Γ3, C)]).
    assert (A → B ::Γ2 ++ (A0 ∧ B0) → C0 :: Γ3 = (A → B :: Γ2) ++ (A0 ∧ B0) → C0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ A0 → B0 → C0 :: Γ3= (A → B :: Γ2) ++ A0 → B0 → C0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H1.
    apply AndImpL. apply AndImpLRule_I. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ (A0 ∧ B0) → C0 :: Γ3 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* OrImpL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: OrImpLRule [((B :: Γ2) ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C)] ((B :: Γ2) ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4, C)). apply OrImpLRule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (OrImpL_inv _ _ d0 J2).
    assert (J3: derrec_height x < S (dersrec_height d)). lia.
    assert (J4: derrec_height x = derrec_height x). auto.
    assert (J5: (Γ2 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, A) = ([] ++ Γ2 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d1). simpl in d2.
    apply derI with (ps:=[(A → B :: Γ2 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C)]).
    assert (A → B :: Γ2 ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4 = (A → B :: Γ2) ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4 = (A → B :: Γ2) ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4). repeat rewrite <- app_assoc. auto. rewrite H1.
    apply OrImpL. apply OrImpLRule_I. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* ImpImpL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ (A0 → B0) → C0 :: Γ3, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ (A0 → B0) → C0 :: Γ3, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B ::Γ2 ++ (A0 → B0) → C0 :: Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    assert (J2: ImpImpLRule [((B :: Γ2) ++ B0 → C0 :: Γ3, A0 → B0);((B :: Γ2) ++ C0 :: Γ3, C)] ((B :: Γ2) ++ (A0 → B0) → C0 :: Γ3, C)). apply ImpImpLRule_I.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (ImpImpL_inv_R _ _ _ d0 J2).
    assert (J3: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J4: derrec_height x0 = derrec_height x0). auto.
    assert (J5: (Γ2 ++ C0 :: Γ3, A) = ([] ++ Γ2 ++ C0 :: Γ3, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d1). simpl in d2.
    apply derI with (ps:=[(A → B :: Γ2 ++ B0 → C0 :: Γ3, A0 → B0);(A → B :: Γ2 ++ C0 :: Γ3, C)]).
    assert (A → B :: Γ2 ++ B0 → C0 :: Γ3 = (A → B :: Γ2) ++ B0 → C0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ C0 :: Γ3 = (A → B :: Γ2) ++ C0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H1.
    assert (A → B :: Γ2 ++ (A0 → B0) → C0 :: Γ3 = (A → B :: Γ2) ++ (A0 → B0) → C0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H3.
    apply ImpImpL. apply ImpImpLRule_I. apply dlCons ; auto.
    apply GL4ip_adm_wkn_L with (s:=(Γ2 ++ B0 → C0 :: Γ3, A0 → B0)) (A:=A → B) ; auto.
    assert ((Γ2 ++ B0 → C0 :: Γ3, A0 → B0) = ([] ++ Γ2 ++ B0 → C0 :: Γ3, A0 → B0)). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert ((A → B :: Γ2 ++ B0 → C0 :: Γ3, A0 → B0) = ([] ++ A → B :: Γ2 ++ B0 → C0 :: Γ3, A0 → B0)). repeat rewrite <- app_assoc. auto. rewrite H1.
    apply wkn_LI. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ (A0 → B0) → C0 :: Γ3 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H2 ; auto. rewrite H1. apply list_exch_LI.
  (* BoxImpL *)
  * inversion X. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply GL4ip_adm_list_exch_L with (s:=(A → B :: Γ2 ++ Box A0 → B0 :: Γ3, C)).
    assert (J1: list_exch_L (Γ0 ++ B :: Γ1, C) (B :: Γ2 ++ Box A0 → B0 :: Γ3, C)).
    assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). auto. rewrite H0.
    assert (B :: Γ2 ++ Box A0 → B0 :: Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H ; auto. rewrite H2. apply list_exch_LI.
    pose (GL4ip_adm_list_exch_L _ D1 _ J1).
    apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p. subst.
    assert (J2: (BoxImpLRule [(XBoxed_list (top_boxes [B] ++ x1 ++ x2) ++ [Box A0], A0);((B :: Γ2) ++ B0 :: Γ3, C)] ((B :: Γ2) ++ Box A0 → B0 :: Γ3, C))).
    apply BoxImpLRule_I.
    destruct (dec_is_boxedT B). destruct i. subst. simpl. intro. intros. inversion H0. subst. exists x3 ; auto.
    auto. intro. intros. apply in_app_or in H0. destruct H0 ; auto. apply in_top_boxes in H0. destruct H0. repeat destruct s.
    destruct p. exfalso. apply f. exists x3. destruct x4 ; auto. simpl in e1. inversion e1. subst. auto. inversion e1. destruct x4.
    simpl in H3. inversion H3. inversion H3.
    destruct (dec_is_boxedT B). assert (top_boxes [B] = [B]). destruct i. simpl. subst. auto. rewrite H0. simpl.
    apply univ_gen_ext_cons ; auto. apply univ_gen_ext_combine ; auto. assert (top_boxes [B] = []).
    simpl. destruct B ; auto. exfalso. apply f ;auto. exists B. auto. rewrite H0. simpl. apply univ_gen_ext_extra ; auto.
    apply univ_gen_ext_combine ; auto.
    repeat rewrite <- app_assoc in J2 ; simpl in J2.
    pose (BoxImpL_inv_R _ _ _ d0 J2).
    assert (J3: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J4: derrec_height x0 = derrec_height x0). auto.
    assert (J5: (Γ2 ++ B0 :: Γ3, A) = ([] ++ Γ2 ++ B0 :: Γ3, A)). auto.
    pose (IH _ J3 _ _ _ _ _ _ _ J4 J5 d1). simpl in d2.
    apply derI with (ps:=[(XBoxed_list (x1 ++ x2) ++ [Box A0], A0);(A → B :: Γ2 ++ B0 :: Γ3, C)]).
    assert (A → B :: Γ2 ++ Box A0 → B0 :: Γ3 = (A → B :: Γ2) ++ Box A0 → B0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H0.
    assert (A → B :: Γ2 ++ B0 :: Γ3 = (A → B :: Γ2) ++ B0 :: Γ3). repeat rewrite <- app_assoc. auto. rewrite H2.
    apply BoxImpL. apply BoxImpLRule_I ; auto. simpl. apply univ_gen_ext_extra ; auto. intro. destruct X0. inversion H3.
    apply univ_gen_ext_combine ; auto. apply dlCons ; auto. apply dlCons ; auto.
    assert (Γ0 ++ A → B :: Γ1 = [] ++ [] ++ Γ0 ++ [A → B] ++ Γ1). auto. rewrite H0.
    assert (A → B :: Γ2 ++ Box A0 → B0 :: Γ3 = [] ++ [A → B] ++ Γ0 ++ [] ++ Γ1). rewrite H ; auto. rewrite H2. apply list_exch_LI.
  (* GLR *)
  * inversion X. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl in IH.
    apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p. subst.
    apply derI with (ps:=[(XBoxed_list (x0 ++ x1) ++ [Box A0], A0);(Γ0 ++ B :: Γ1, C)]).
    apply BoxImpL. apply BoxImpLRule_I ; auto. apply univ_gen_ext_combine ; auto.
    apply dlCons ; auto. apply dlCons ; auto.
Qed.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import Domains.basics.
Require Import Domains.preord.
Require Import Domains.categories.
Require Import Domains.sets.
Require Import Domains.finsets.
Require Import Domains.esets.
Require Import Domains.effective.
Require Import Domains.directed.
Require Import Domains.plotkin.
Require Import Domains.approx_rels.
Require Import Domains.profinite.

(**  * Basis embeddings and EP-pairs

     Here we define the category of embeddings over PLT.  These are used
     to construct the solutions to recursive domain equations.  Here
     we show that the category of basis embeddings is equivalant to
     the more usual category of embedding-projection pairs.  Basis
     embeddings are considerably more convenient to work with than EP-pairs, so
     we prefer them for building bilimits and proving functors continuous.

     Basis embeddings form a category with the effective Plotkin orders
     as objects.  To avoid notational confusion, we use the symbol ⇀
     to refer to embeddings, reserving → for the homs of PLT.
  *)

Record embedding (hf:bool) (A B:PLT.ob hf) :=
  Embedding
  { embed_map :> A -> B
  ; embed_mono : forall a a', a ≤ a' -> embed_map a ≤ embed_map a'
  ; embed_reflects : forall a a', embed_map a ≤ embed_map a' -> a ≤ a'
  ; embed_directed0 : forall y,
      if hf then True else exists x, embed_map x ≤ y
  ; embed_directed2 : forall y a b,
      embed_map a ≤ y ->
      embed_map b ≤ y ->
      exists c, embed_map c ≤ y /\ a ≤ c /\ b ≤ c
  }.
Arguments embed_map [hf] [A] [B] e a.
Arguments embed_mono [hf] [A] [B] e _ _ _.
Arguments embed_reflects [hf] [A] [B] e _ _ _.
Arguments embed_directed0 [hf] [A] [B] e _.
Arguments embed_directed2 [hf] [A] [B] e _ _ _ _ _.

Program Definition embed_ident (hf:bool) (A:PLT.ob hf) : embedding hf A A :=
  Embedding hf A A (fun x => x) _ _ _ _.
Solve Obligations with (intros; auto).
Next Obligation.
  intros. destruct hf; auto. exists y; auto.
Qed.
Next Obligation.
  intros. exists y. intuition.
Qed.

Program Definition embed_compose (hf:bool) A B C
  (g:embedding hf B C) (f:embedding hf A B) : embedding hf A C :=
  Embedding hf A C (fun x => embed_map g (embed_map f x)) _ _ _ _.
Next Obligation.
  intros. apply embed_mono. apply embed_mono. auto.
Qed.
Next Obligation.
  intros. apply (embed_reflects f). apply (embed_reflects g); auto.
Qed.
Next Obligation.
  intros.
  generalize (refl_equal hf).
  pattern hf at 2. case hf; intros.
  pattern hf at 1. rewrite H. auto.
  pattern hf at 1. rewrite H.
  generalize (embed_directed0 g y).
  rewrite H at 1.
  intros [q ?].
  generalize (embed_directed0 f q).
  rewrite H at 1.
  intros [q' ?].
  exists q'.
  transitivity (embed_map g q); auto.
  apply embed_mono. auto.
Qed.
Next Obligation.
  intros.
  destruct (embed_directed2 g y (embed_map f a) (embed_map f b)) as [c [?[??]]]; auto.
  destruct (embed_directed2 f c a b) as [q [?[??]]]; auto.
  exists q. split; auto.
  transitivity (embed_map g c); auto.
  apply embed_mono; auto.
Qed.

Definition embed_order hf A B (E G:embedding hf A B) :=
  forall x, embed_map E x ≤ embed_map G x.

Program Definition embed_order_mixin hf A B : Preord.mixin_of (embedding hf A B) :=
  Preord.Mixin (embedding hf A B) (embed_order hf A B) _ _ .
Solve Obligations with (unfold embed_order; intros; eauto).

Canonical Structure embed_ord hf A B :=
  Preord.Pack (embedding hf A B) (embed_order_mixin hf A B).

Definition embed_comp_mixin hf :=
    (Comp.Mixin _ _ (embed_ident hf) (embed_compose hf)).

Canonical Structure embed_comp hf :=
  Comp.Pack (PLT.ob hf) (embedding hf) (embed_comp_mixin hf).

Program Definition embed_func {hf A B} (E:embedding hf A B) : PLT.ord A → PLT.ord B :=
  Preord.Hom A B (embed_map E) (embed_mono E).
Coercion embed_func : embedding >-> hom.

Definition embed_eq_mixin hf A B := Preord.ord_eq (embed_ord hf A B).

Lemma embed_cat_axioms hf :
  Category.axioms (PLT.ob hf) (embedding hf) (embed_eq_mixin hf) (embed_comp_mixin hf).
Proof.
  intros. constructor.

  intros. split; hnf; simpl; intros; auto.
  intros. split; hnf; simpl; intros; auto.
  intros. split; hnf; simpl; intros; auto.
  intros. split; hnf; simpl; intros.
  transitivity (embed_map f' (embed_map g x)).
  destruct H. apply H.
  apply embed_mono.
  destruct H0. apply H0.
  transitivity (embed_map f' (embed_map g x)).
  apply embed_mono.
  destruct H0. apply H1.
  destruct H. apply H1.
Qed.

Definition EMBED hf :=
  Category (PLT.ob hf) (embedding hf) _ _ (embed_cat_axioms hf).

Notation "A ⇀ B" := (hom (EMBED _) A B) (at level 70, no associativity).

Add Parametric Morphism hf A B :
  (@embed_map hf A B) with signature
        (@Preord.ord_op (embed_ord hf A B)) ==>
        (@Preord.ord_op A) ==>
        (@Preord.ord_op B)
    as embed_map_morphism.
Proof.
  intros.
  transitivity (y x0).
  apply H. apply embed_mono. auto.
Qed.

Add Parametric Morphism hf A B :
  (@embed_map hf A B) with signature
        (@eq_op (CAT_EQ (EMBED hf) A B)) ==>
        (@eq_op (Preord_Eq A)) ==>
        (@eq_op (Preord_Eq B))
    as embed_map_eq_morphism.
Proof.
  intros. split; apply embed_map_morphism; auto.
Qed.

Lemma embed_unlift hf (A B:PLT.ob hf) (f g:A ⇀ B) x :
  f ≤ g -> f x ≤ g x.
Proof.
  intros. apply H; auto.
Qed.

Lemma embed_unlift' hf (A B:PLT.ob hf) (f g:A ⇀ B) x :
  f ≈ g -> f x ≈ g x.
Proof.
  intros.
  destruct H; split; auto.
Qed.

Lemma embed_lift hf (A B:PLT.ob hf) (f g:A ⇀ B) :
  (forall x, f x ≤ g x) -> f ≤ g.
Proof.
  repeat intro; auto.
Qed.

Lemma embed_lift' hf (A B:PLT.ob hf) (f g:A ⇀ B) :
  (forall x, f x ≈ g x) -> f ≈ g.
Proof.
  intros; split; hnf; auto.
Qed.

(** The category of embeddings over _partial_ plotkin orders has
    an initial object.  The category of embeddings over total plotkin
    orders, however, does not.
 *)
Program Definition embed_initiate X : PLT.empty true ⇀ X :=
  Embedding true (PLT.empty true) X (fun x => False_rect _ x) _ _ _ _.
Next Obligation.
  intros. elim a.
Qed.
Next Obligation.
  intros. elim a.
Qed.
Next Obligation.
  intros. reflexivity.
Qed.
Next Obligation.
  intros. elim a.
Qed.

Program Definition PPLT_EMBED_initialized_mixin :=
  Initialized.Mixin
    (PLT.ob true)
    (embedding true)
    (embed_eq_mixin true)
    (PLT.empty true)
    embed_initiate
    _.
Next Obligation.
  repeat intro.
  split; intro x; elim x.
Qed.

Canonical Structure PPLT_EMBED_initialized :=
  Initialized
    (PLT.ob true) (embedding true)
    (embed_eq_mixin true)
    (embed_comp_mixin true)
    (embed_cat_axioms true)
    PPLT_EMBED_initialized_mixin.

Section ep_pairs.
  Variable hf:bool.

  Notation PLT := (PLT.PLT hf).

  Record is_ep_pair (X Y:ob PLT) (e:X → Y) (p:Y → X) :=
  IsEP
  { pe_ident : p ∘ e ≈ id
  ; ep_ident : e ∘ p ≤ id
  }.

  Record ep_pair (X Y:ob PLT) :=
  EpPair
  { embed : X → Y
  ; project : Y → X
  ; ep_correct : is_ep_pair X Y embed project
  }.
  Arguments embed [X] [Y] e.
  Arguments project [X] [Y] e.

  Program Definition ep_id (X:ob PLT) : ep_pair X X :=
    EpPair X X id id _.
  Next Obligation.
    intros. constructor.
    rewrite (cat_ident1 _ _ _ id(X)); auto.
    rewrite (cat_ident1 _ _ _ id(X)); auto.
  Qed.

  Program Definition ep_compose (X Y Z:ob PLT) (g:ep_pair Y Z) (f:ep_pair X Y) :=
    EpPair X Z (embed g ∘ embed f) (project f ∘ project g) _.
  Next Obligation.
    intros.
    destruct g as [e' p' [??]].
    destruct f as [e p [??]]. simpl in *.
    constructor.
    rewrite <- (cat_assoc _ _ _ _ _ p).
    rewrite (cat_assoc _ _ _ _ _ p').
    rewrite pe_ident0.
    rewrite (cat_ident2 _ _ _ e). auto.

    rewrite <- (cat_assoc _ _ _ _ _ e').
    rewrite (cat_assoc _ _ _ _ _ e).
    transitivity (e' ∘ p'); auto.
    apply PLT.compose_mono; auto.
    transitivity (id ∘ p').
    apply PLT.compose_mono; auto.
    rewrite (cat_ident2 _ _ _ p').
    auto.
  Qed.

  Lemma ep_pair_embed_eq_proj_eq : forall X Y e e' p p',
    is_ep_pair X Y e p ->
    is_ep_pair X Y e' p' ->
    e ≈ e' -> p ≈ p'.
  Proof.
    intros.
    split.
    transitivity (id ∘ p).
    rewrite (cat_ident2 _ _ _ p). auto.
    destruct H0.
    transitivity ((p' ∘ e') ∘ p).
    apply PLT.compose_mono; auto.
    rewrite <- H1.
    rewrite <- (cat_assoc _ _ _ _ _ p').
    transitivity (p' ∘ id).
    apply PLT.compose_mono.
    destruct H. auto.
    auto.
    rewrite (cat_ident1 _ _ _ p'). auto.
    transitivity (id ∘ p').
    rewrite (cat_ident2 _ _ _ p'). auto.
    destruct H.
    transitivity ((p ∘ e) ∘ p').
    apply PLT.compose_mono; auto.
    rewrite H1.
    rewrite <- (cat_assoc _ _ _ _ _ p).
    transitivity (p ∘ id).
    apply PLT.compose_mono.
    destruct H0. auto.
    auto.
    rewrite (cat_ident1 _ _ _ p). auto.
  Qed.

  Program Definition ep_pair_eq_mixin X Y : Eq.mixin_of (ep_pair X Y) :=
    Eq.Mixin _ (fun f g => embed f ≈ embed g) _ _ _.
  Next Obligation.
    simpl. reflexivity.
  Qed.
  Next Obligation.
    simpl. auto.
  Qed.
  Next Obligation.
    simpl. eauto.
  Qed.

  Definition ep_pair_comp_mixin : Comp.mixin_of (PLT.ob hf) ep_pair :=
    Comp.Mixin _ ep_pair ep_id ep_compose.

  Canonical Structure ep_pair_eq X Y := Eq.Pack (ep_pair X Y) (ep_pair_eq_mixin X Y).
  Canonical Structure ep_pair_comp := Comp.Pack _ ep_pair ep_pair_comp_mixin.

  Lemma ep_cat_axioms :
    Category.axioms _ ep_pair ep_pair_eq_mixin ep_pair_comp_mixin.
  Proof.
    constructor; simpl; intros.
    red. simpl. apply (cat_ident1 _ _ _ (embed f)).
    red. simpl. apply (cat_ident2 _ _ _ (embed f)).
    red. simpl. apply (cat_assoc _ _ _ _ _ (embed f)).
    red. simpl. apply (cat_respects _ _ _ _ _ _ _ _ H H0).
  Qed.

  Canonical Structure PLT_EP :=
    Category (PLT.ob hf) ep_pair ep_pair_eq_mixin ep_pair_comp_mixin ep_cat_axioms.

  Definition find_inhabitant' : forall A (P:eset A) (H:einhabited P),
    { a:A | a ∈ P }.
  Proof.
    intros. destruct (find_inhabitant A P H).
    exists x.
    destruct s as [n [??]].
    exists n. rewrite H0. auto.
  Qed.

  Definition choose' A P H := proj1_sig (find_inhabitant' A P H).

  Section ep_pair_embed_func.
    Variables X Y:ob PLT.
    Variable ep : ep_pair X Y.

    Let e := embed ep.
    Let p := project ep.
    Let Hep := ep_correct X Y ep.

    Section embed_func.
      Variable x:X.

      Lemma ep_semidec : forall y, semidec ((x,y) ∈ PLT.hom_rel e /\ (y,x) ∈ PLT.hom_rel p).
      Proof.
        intro.
        apply semidec_conj.
        apply semidec_iff with (y ∈ erel_image (PLT.ord X) (PLT.ord Y) (PLT.dec X)
          (PLT.hom_rel e) x).
        intros. apply erel_image_elem.
        apply semidec_in. apply PLT.dec.
        apply semidec_iff with (y ∈ erel_inv_image (PLT.ord Y) (PLT.ord X) (PLT.dec X)
          (PLT.hom_rel p) x).
        intros. apply erel_inv_image_elem.
        apply semidec_in. apply PLT.dec.
      Qed.

      Definition embed_image :=
        esubset (fun y => (x,y) ∈ PLT.hom_rel e /\ (y,x) ∈ PLT.hom_rel p)
           ep_semidec
           (eff_enum (PLT.ord Y) (PLT.effective Y)).

      Lemma embed_image_inhabited : einhabited embed_image.
      Proof.
        apply member_inhabited.
        generalize (pe_ident _ _ _ _ Hep).
        intros.
        assert ((x,x) ∈ PLT.hom_rel (p ∘ e)).
        apply H.
        apply ident_elem. auto.
        apply PLT.compose_hom_rel in H0.
        destruct H0 as [y [??]].
        exists y. unfold embed_image.
        apply esubset_elem.
        intros. destruct H3; split.
        apply member_eq with (x,a); auto.
        destruct H2; split; split; auto.
        apply member_eq with (a,x); auto.
        destruct H2; split; split; auto.
        split.
        apply eff_complete.
        split; auto.
      Qed.
    End embed_func.

    Program Definition ep_embed : Preord.hom (PLT.ord X) (PLT.ord Y) :=
      Preord.Hom X Y
        (fun x => choose' (PLT.ord Y) (embed_image x) (embed_image_inhabited x)) _.
    Next Obligation.
      intros.
      unfold choose'.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image a) (embed_image_inhabited a))
        as [y ?]. simpl.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image b) (embed_image_inhabited b))
        as [y' ?]. simpl.

      unfold embed_image in *.
      apply esubset_elem in m.
      apply esubset_elem in m0.
      destruct m as [_ [??]].
      destruct m0 as [_ [??]].
      destruct Hep.
      cut ((y',y) ∈ PLT.hom_rel id).
      intros. simpl in H4.
      apply ident_elem in H4. auto.
      apply ep_ident0.
      simpl.
      apply PLT.compose_hom_rel; auto.
      exists a. split; auto.
      apply PLT.hom_order with y' b; auto.
      intros. destruct H2; split.
      apply member_eq with (b,a0); auto.
      split; split; auto.
      apply member_eq with (a0,b); auto.
      split; split; auto.
      intros. destruct H2; split.
      apply member_eq with (a,a0); auto.
      split; split; auto.
      apply member_eq with (a0,a); auto.
      split; split; auto.
    Qed.

    Lemma embed_func_reflects : forall x x',
      ep_embed#x ≤ ep_embed#x' -> x ≤ x'.
    Proof.
      intros x x'. unfold ep_embed. simpl. unfold choose'.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image x) (embed_image_inhabited x))
        as [y ?]. simpl.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image x') (embed_image_inhabited x'))
        as [y' ?]. simpl.
      intros.
      unfold embed_image in *.
      apply esubset_elem in m.
      apply esubset_elem in m0.
      destruct m. destruct m0.
      destruct Hep.
      cut ((x',x) ∈ PLT.hom_rel id).
      simpl; intros. apply ident_elem in H4. auto.
      apply pe_ident0.
      simpl. apply PLT.compose_hom_rel.
      exists y'. intuition.
      apply PLT.hom_order with y x; auto.
      intros. destruct H2; split.
      apply member_eq with (x',a); auto.
      split; split; auto.
      apply member_eq with (a,x'); auto.
      split; split; auto.
      intros. destruct H2; split.
      apply member_eq with (x,a); auto.
      split; split; auto.
      apply member_eq with (a,x); auto.
      split; split; auto.
    Qed.

    Lemma embed_func_directed0 : forall y,
      if hf then True else exists x, ep_embed#x ≤ y.
    Proof.
      intros.
      generalize (refl_equal hf).
      pattern hf at 2; case hf; intros.
      pattern hf at 1; rewrite H; auto.
      destruct (PLT.hom_directed _ _ _ p y nil).
      hnf.
      pattern hf at 1. rewrite H. auto.
      hnf; intros. apply nil_elem in H0. elim H0.
      destruct H0.
      pattern hf at 1. rewrite H.
      exists x. apply erel_image_elem in H1.
      unfold embed_func; simpl.
      unfold choose'.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image x) (embed_image_inhabited x))
        as [y' ?]. simpl in *.
      unfold embed_image in m.
      apply esubset_elem in m.
      destruct m as [_ [??]].
      destruct Hep.
      cut ((y,y') ∈ PLT.hom_rel id).
      simpl; auto.
      intros. apply ident_elem in H4. auto.
      apply ep_ident0.
      simpl. apply PLT.compose_hom_rel.
      exists x; auto.
      intros. destruct H4; split.
      apply member_eq with (x,a); auto.
      split; split; auto.
      apply member_eq with (a,x); auto.
      split; split; auto.
    Qed.

    Lemma embed_func_directed2 : forall y, forall a b,
      ep_embed#a ≤ y ->
      ep_embed#b ≤ y ->
      exists c, ep_embed#c ≤ y /\ a ≤ c /\ b ≤ c.
    Proof.
      intro. intros.
      unfold ep_embed in *. simpl in *.
      unfold choose' in *.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image a) (embed_image_inhabited a))
        as [ya ?]. simpl in *.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image b) (embed_image_inhabited b))
        as [yb ?]. simpl in *.
      unfold embed_image in m.
      unfold embed_image in m0.
      apply esubset_elem in m.
      apply esubset_elem in m0.
      destruct m as [_ [??]].
      destruct m0 as [_ [??]].
      assert ((y,a) ∈ PLT.hom_rel p).
      apply PLT.hom_order with ya a; auto.
      assert ((y,b) ∈ PLT.hom_rel p).
      apply PLT.hom_order with yb b; auto.
      destruct (PLT.hom_directed _ _ _ p y (a::b::nil)%list).
      apply elem_inh with a. apply cons_elem; auto.
      hnf; simpl; intros.
      apply erel_image_elem.
      apply cons_elem in H7. destruct H7.
      apply PLT.hom_order with y a; auto.
      apply cons_elem in H7. destruct H7.
      apply PLT.hom_order with y b; auto.
      apply nil_elem in H7. elim H7.
      destruct H7.
      apply erel_image_elem in H8.
      rename x into q.
      exists q.
      split.
      destruct (find_inhabitant' (PLT.ord Y) (embed_image q) (embed_image_inhabited q))
        as [yq ?]. simpl in *.
      unfold embed_image in m.
      apply esubset_elem in m.
      destruct m as [_ [??]].
      destruct Hep.
      cut ((y,yq) ∈ PLT.hom_rel id).
      simpl; intros. apply ident_elem in H11. auto.
      apply ep_ident0.
      simpl.
      apply PLT.compose_hom_rel.
      exists q. split; auto.

      intros. destruct H11. split.
      apply member_eq with (q,a0); auto.
      split; split; auto.
      apply member_eq with (a0,q); auto.
      split; split; auto.
      split; apply H7; auto.
      apply cons_elem; auto.
      apply cons_elem; right.
      apply cons_elem; auto.
      intros. destruct H3. split.
      apply member_eq with (b,a0); auto.
       split; split; auto.
      apply member_eq with (a0,b); auto.
      split; split; auto.
      intros. destruct H3. split.
      apply member_eq with (a,a0); auto.
      split; split; auto.
      apply member_eq with (a0,a); auto.
      split; split; auto.
    Qed.

    Definition ep_embedding : embedding hf X Y :=
      Embedding hf X Y
        (Preord.map _ _ ep_embed)
        (Preord.axiom _ _ ep_embed)
        embed_func_reflects
        embed_func_directed0
        embed_func_directed2.

  End ep_pair_embed_func.

  Section embed_func_ep_pair.
    Variables X Y:ob PLT.
    Variable embed : embedding hf X Y.

    Definition project_rel :=
      esubset_dec (PLT.ord Y × PLT.ord X)%cat_ob
         (fun yx => fst yx ≥ embed#(snd yx))
         (fun yx => eff_ord_dec Y (PLT.effective Y) (embed#(snd yx)) (fst yx))
         (eprod (eff_enum Y (PLT.effective Y)) (eff_enum X (PLT.effective X))).

    Lemma project_rel_elem : forall y x,
      embed#x ≤ y <-> (y,x) ∈ project_rel.
    Proof.
      intros. split; intros.
      unfold project_rel.
      apply esubset_dec_elem.
      intros.
      change (fst y0) with (π₁#y0)%cat_ops.
      change (snd y0) with (π₂#y0)%cat_ops.
      rewrite <- H0. auto.
      split; auto.
      apply eprod_elem; split; apply eff_complete; auto.
      unfold project_rel in H.
      apply esubset_dec_elem in H.
      destruct H; auto.
      intros.
      change (fst y0) with (π₁#y0)%cat_ops.
      change (snd y0) with (π₂#y0)%cat_ops.
      rewrite <- H1. auto.
    Qed.

    Program Definition project_hom : Y → X :=
      PLT.Hom hf Y X project_rel _ _.
    Next Obligation.
      intros.
      apply project_rel_elem in H1.
      apply project_rel_elem.
      transitivity x; auto.
      transitivity (embed#y); auto.
    Qed.
    Next Obligation.
      red. intro y.
      apply prove_directed.
      generalize (refl_equal hf). pattern hf at 2. case hf; intros.
      pattern hf at 1. rewrite H. auto.
      pattern hf at 1. rewrite H.
      generalize (embed_directed0 embed y).
      rewrite H at 1.
      intros [x ?].
      exists x.
      apply erel_image_elem.
      apply project_rel_elem. auto.

      intros.
      apply erel_image_elem in H.
      apply erel_image_elem in H0.
      apply project_rel_elem in H.
      apply project_rel_elem in H0.
      destruct (embed_directed2 embed y x y0) as [z [?[??]]]; auto.
      exists z; split; auto. split; auto.
      apply erel_image_elem.
      apply project_rel_elem. auto.
    Qed.

    Definition embed_rel :=
      esubset_dec (PLT.ord X×PLT.ord Y)%cat_ob
         (fun xy => embed#(fst xy) ≥ snd xy)
         (fun xy => eff_ord_dec Y (PLT.effective Y) (snd xy) (embed#(fst xy)))
         (eprod (eff_enum X (PLT.effective X)) (eff_enum Y (PLT.effective Y))).

    Lemma embed_rel_elem : forall y x,
      embed#x ≥ y <-> (x,y) ∈ embed_rel.
    Proof.
      intros; split; intros.
      unfold embed_rel.
      apply esubset_dec_elem.
      intros.
      change (fst y0) with (π₁#y0)%cat_ops.
      change (snd y0) with (π₂#y0)%cat_ops.
      rewrite <- H0. auto.
      split; auto.
      apply eprod_elem; split; apply eff_complete; auto.
      unfold embed_rel in H.
      apply esubset_dec_elem in H.
      destruct H; auto.
      intros.
      change (fst y0) with (π₁#y0)%cat_ops.
      change (snd y0) with (π₂#y0)%cat_ops.
      rewrite <- H1. auto.
    Qed.

    Program Definition embed_hom : X → Y :=
      PLT.Hom hf X Y embed_rel _ _.
    Next Obligation.
      intros.
      apply embed_rel_elem in H1.
      apply embed_rel_elem.
      transitivity y; auto.
      transitivity (embed#x); auto.
    Qed.
    Next Obligation.
      hnf. simpl; intros.
      hnf. simpl; intros.
      exists (embed#(x:X)).
      split.
      hnf; simpl; intros.
      apply H in H0.
      apply erel_image_elem in H0.
      apply embed_rel_elem in H0. auto.
      apply erel_image_elem.
      apply embed_rel_elem.
      auto.
    Qed.

    Lemma embed_func_is_ep_pair : is_ep_pair X Y embed_hom project_hom.
    Proof.
      constructor.

      split.
      hnf; simpl; intros.
      destruct a as [x x'].
      apply PLT.compose_hom_rel in H.
      apply ident_elem.
      destruct H as [y [??]].
      apply embed_rel_elem in H.
      apply project_rel_elem in H0.
      apply (embed_reflects embed).
      transitivity y; auto.

      hnf; simpl; intros.
      destruct a as [x x'].
      apply ident_elem in H.
      apply PLT.compose_hom_rel.
      exists (embed#(x:X)).
      split.
      apply embed_rel_elem. auto.
      apply project_rel_elem. auto.

      hnf; simpl; intros.
      destruct a as [y y'].
      apply PLT.compose_hom_rel in H.
      apply ident_elem.
      destruct H as [x [??]].
      apply project_rel_elem in H.
      apply embed_rel_elem in H0.
      transitivity (embed#x); auto.
    Qed.

    Definition embed_ep_pair :=
      EpPair X Y embed_hom project_hom embed_func_is_ep_pair.

  End embed_func_ep_pair.

  Arguments ep_embedding [X] [Y] ep.
  Arguments embed_ep_pair [X] [Y] _.

  Lemma embed_ep_roundtrip1 : forall X Y (ep:ep_pair X Y),
    embed_ep_pair (ep_embedding ep) ≈ ep.
  Proof.
    intros. split; hnf; simpl; intros.
    destruct a.
    apply embed_rel_elem in H.
    simpl in H.
    unfold choose' in H.
    match goal with [ _ : appcontext[find_inhabitant' ?A ?X ?Y] |- _ ] =>
      destruct (find_inhabitant' A X Y); simpl in *
    end.
    unfold embed_image in m.
    apply esubset_elem in m.
    destruct m as [?[??]].
    apply PLT.hom_order with c x; auto.

    intros.
    destruct H2. split.
    apply member_eq with (c,a); auto.
    split; split; auto.
    apply member_eq with (a,c); auto.
    split; split; auto.

    destruct a.
    apply embed_rel_elem.
    simpl. unfold choose'.
    match goal with [ |- appcontext[find_inhabitant' ?A ?X ?Y] ] =>
      destruct (find_inhabitant' A X Y); simpl in *
    end.
    unfold embed_image in m.
    apply esubset_elem in m. intuition.
    cut ((x,c0) ∈ PLT.hom_rel id).
    simpl; intros. apply ident_elem in H1. auto.
    generalize (ep_correct X Y ep). intros [??].
    apply ep_ident0. simpl.
    apply PLT.compose_hom_rel.
    eauto.

    intros.
    destruct H2. split.
    apply member_eq with (c,a); auto.
    split; split; auto.
    apply member_eq with (a,c); auto.
    split; split; auto.
  Qed.

  Lemma embed_ep_roundtrip2 : forall X Y (e : X ⇀ Y),
    e ≈ ep_embedding (embed_ep_pair e).
  Proof.
    intros. split; hnf; simpl; intros.
    unfold choose'.
    match goal with [ |- appcontext[find_inhabitant' ?A ?X ?Y] ] =>
      destruct (find_inhabitant' A X Y); simpl in *
    end.
    unfold embed_image in m.
    apply esubset_elem in m.
    intuition.
    unfold embed_hom in H1.
    simpl in *.
    apply embed_rel_elem in H1.
    apply project_rel_elem in H2.
    simpl in *; auto.

    intros. destruct H1; split.
    apply member_eq with (x,a); auto.
    split; split; auto.
    apply member_eq with (a,x); auto.
    split; split; auto.

    unfold choose'.
    match goal with [ |- appcontext[find_inhabitant' ?A ?X ?Y] ] =>
      destruct (find_inhabitant' A X Y); simpl in *
    end.
    unfold embed_image in m.
    apply esubset_elem in m.
    intuition.
    simpl in *.
    apply embed_rel_elem in H1.
    auto.

    intros. destruct H1; split.
    apply member_eq with (x,a); auto.
    split; split; auto.
    apply member_eq with (a,x); auto.
    split; split; auto.
  Qed.
End ep_pairs.

Arguments embed [hf] [X] [Y] e.
Arguments project [hf] [X] [Y] e.
Arguments ep_embedding [hf] [X] [Y] ep.
Arguments embed_ep_pair [hf] [X] [Y] _.

Canonical Structure PLT_EP.
Canonical Structure ep_pair_eq.
Canonical Structure ep_pair_comp.

Program Definition embedForget hf : functor (EMBED hf) (PLT.PLT hf) :=
  Functor (EMBED hf) (PLT.PLT hf) (fun X => X) (fun X Y f => embed_hom hf X Y f) _ _ _.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct a.
  apply embed_rel_elem in H0.
  apply ident_elem.
  rewrite H0.
  destruct H. apply H.
  destruct a.
  apply embed_rel_elem.
  apply ident_elem in H0.
  rewrite H0. destruct H. apply H1.
Qed.
Next Obligation.
  simpl; intros.
  split; hnf; simpl; intros.
  destruct a as [a c].
  apply embed_rel_elem in H0.
  destruct H.
  apply PLT.compose_hom_rel.
  exists (g a).
  split.
  apply embed_rel_elem. auto.
  apply embed_rel_elem.
  rewrite H0. apply H.
  destruct a as [a c].
  apply PLT.compose_hom_rel in H0.
  destruct H0 as [y [??]].
  apply embed_rel_elem.
  simpl in *.
  apply embed_rel_elem in H0.
  apply embed_rel_elem in H1.
  rewrite H1. rewrite H0.
  destruct H. apply H2.
Qed.
Next Obligation.
  repeat intro. split; hnf; simpl; intros.
  destruct a as [a b].
  apply embed_rel_elem in H0. apply embed_rel_elem.
  rewrite H0. destruct H. apply H.
  destruct a as [a b].
  apply embed_rel_elem in H0. apply embed_rel_elem.
  rewrite H0. destruct H. apply H1.
Qed.


(* Declare ML Module "plugin". *)

(*
Declare ML Module "extlib".
Declare ML Module "reif".

Section PartialApply.

  Fixpoint funtype (ls : list Type) (r : Type) : Type :=
    match ls with
      | nil => r
      | cons a b => a -> funtype b r
    end.

  Fixpoint apply_ls (ls : list Type) (T : Type) (R : T -> Type) (V : T)
    : funtype ls (forall x : T, R x) -> funtype ls (R V) :=
    match ls with
      | nil => fun F => F V
      | cons a b => fun F => fun x : a => apply_ls b T R V (F x)
    end.
End PartialApply.

Require Import List.

Ltac refl_app cc e :=
  match e with
    | (fun _ => _) =>
      let rec getTypes As :=
        match As with
          | tt => constr:(@nil Type)
          | (?A, ?B) =>
            match type of A with
              | _ -> ?TT =>
                let r := getTypes B in
                constr:((TT : Type) :: r)
            end
        end
      in
      let rec papply cc F T Tb Ts As :=
        match T with
          | ?T1 -> ?TT =>
            match Ts with
              | ?T :: ?T' =>
                match As with
                  | (?A, ?A') =>
                    let cc' f Ts As :=
                      let Ts' := constr:((T : Type) :: Ts) in
                      let As' := constr:((A, As)) in
                      cc f Ts' As'
                    in
                    let Tb := constr:((T:Type) :: Tb) in
                    papply cc' F TT Tb T' A'
                end
            end
          | forall x : ?T1, @?T2 x =>
            match Ts with
              | _ :: ?T' =>
                match As with
                  | ((fun _ => ?A), ?A') =>
                    let TT' := eval simpl in (T2 A) in
                    let f' := eval simpl in (@apply_ls Tb T1 T2 A F) in
                    papply cc f' TT' Tb T' A'
                end
            end
          | _ =>
            cc F Ts As
        end
      in
      match e with
        | fun x => ?F (@?A x) (@?B x) (@?C x) (@?D x) (@?E x) =>
          let As := constr:((A,(B,(C,(D,(E,tt)))))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) (@?B x) (@?C x) (@?D x) =>
          let As := constr:((A,(B,(C,(D,tt))))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) (@?B x) (@?C x) =>
          let As := constr:((A,(B,(C,tt)))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) (@?B x) =>
          let As := constr:((A,(B,tt))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) =>
          let As := constr:((A,tt)) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F =>
          let As := constr:(tt) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
      end
    | _ =>
      let rec refl cc e As :=
        match e with
          | ?A ?B =>
            let Ta := type of A in
            match Ta with
              | _ -> ?TT =>
                let As := constr:((B, As)) in
                let Tb := type of B in
                let cc f Ts args :=
                  let Ts' := constr:(List.app Ts (cons (Tb : Type) nil)) in
                  cc f Ts' args
                in
                refl cc A As
              | forall x : ?T1, @?T2 x =>
                let cc f Ts args :=
                  let Tb  := type of B in
                  let f'  := eval simpl in (@apply_ls Ts T1 T2 B f) in
                  cc f' Ts args
                in
                refl cc A As
              end
          | _ =>
            let Ts := constr:(@nil Type) in
            cc e Ts As
        end
        in
        let b := constr:(tt) in
        refl cc e b
  end.

Ltac cc1 x ts args :=
  idtac "$$$ plugin" x ts args.
Ltac cc2 x ts args :=
  idtac "$$$ ltac" x ts args.

Definition tutu (x : Type) ( y : x ) (s : Type) (z : nat) (z2 : nat) (u : x) := 1.
Goal tutu bool true nat 3 3  false = 2.
  match goal with
      |- ?l = _ =>  refl_app_cps l cc1
  end.
  match goal with
      |- ?l = _ =>  refl_app cc2 l
  end.
Abort.

Definition bar : forall ( x: Type), nat -> forall (y : Type), x -> y -> x := fun _ _ _ e _ => e.

Definition bar2 : forall ( x: Type), nat -> forall (y : Type), nat -> forall (z : Type),  x -> y -> z -> z. Admitted.

Goal forall a b c d e, bar a b c d e = d.
intros.
  match goal with
      |- ?l = _ => refl_app_cps l cc1
  end.
  match goal with
      |- ?l = _ =>  refl_app cc2 l
  end.
Abort.

Goal forall Hx Hy Hz a b c d e, bar2 Hx a Hy b Hz c d e = e.
intros.
match goal with
    |- ?l = _ => refl_app_cps l cc1
end.
match goal with
    |- ?l = _ =>  refl_app cc2 l
end.

Abort.

Goal (fun x => x + x) = (fun x => 2).
match goal with
    |- ?l = _ => refl_app_cps l cc1
end.
match goal with
    |- ?l = _ =>  refl_app cc2 l
end.
Abort.

Variable A B : Type.
Definition test1 (stn : A) (sm : B) : B. Admitted.
Goal  forall a b, test1 a b = b. intros.
match goal with |- ?l = _  => refl_app_cps l cc1 end.
match goal with |- ?l = _  => refl_app cc2 l end.
Abort.

Definition test2 : A * B -> B. Admitted.
Goal  (fun x y => test2 (x, y)) = (fun _ b => b). intros.
match goal with |- ?l = _  => refl_app cc2 l end.
match goal with |- ?l = _  => refl_app_cps l cc1 end.
Abort.
Require Import String.
Require Bedrock. Require ReifyExpr.
Definition test_dep_0 (n : nat) (arg : bool) := True.
Definition test_dep (n : nat) (arg : bool) := n = 0 -> arg = arg.
Goal True.
reify_expr (test_dep_0 1 true).
reify_expr (test_dep 1 true).
Abort.
(* Require Bedrock. Require ReifyExpr.  *)
(* Goal True.  *)
(* reify_expr (forall (x : bool), x = x).  *)
(* reify_expr (1). *)
(* reify_expr (fun (x : nat )=> x).  *)
(* reify_expr (1 + 3).  *)
(* reify_expr (1 + 3 = 2 + 2).  *)
(* reify_expr (not (1 + 3 = 2 + 2)).  *)
(* reify_expr (not (1 + 3 = 2 + 2)).  *)
(* reify_expr ((1 + 3 = 2 + 2) -> False).  *)
(* (* Time reify_expr ((1 + 1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 + 3 = 2 + 2) -> False).  *) *)
(* reify_expr (fun n => n + n = n + n).  *)
(* reify_expr (fun x => negb (negb x) = x). *)
(* Abort.  *)
(* Require Import Bedrock.SepIL. Import SEP.  *)
(* Locate SEP.Emp.  *)
(* Axiom types : list Type.  *)
(* Axiom pc : Type.  *)
(* Notation "a * b" := (@star pc pc types  a b) (only parsing).  *)
(* Notation "0" := (@emp pc pc types ) (only parsing).  *)
(* Notation "'Ex' x , p" := (@ex pc pc types _ (fun x => p)). *)
(* Notation "'Ex' x : T , p" := (@ex pc pc types T (fun x => p)) . *)
(* Notation "[| P |]" := (@inj pc pc types (@PropX.Inj pc pc types  P )).  *)
(* Require Import IL.  *)
(* Variable st : state.  *)
(* Goal True.  *)
(* reify_expr (Regs st Rp). *)
(* reify_sexpr (0 ).  *)
(* reify_sexpr (0 * 0 * 0).  *)
(* reify_sexpr ( [| 1 + 1 = 2 |] * 0 * [| 12 = 6 + 6 |] ). *)
(* reify_sexpr ( [| 1 + 1 = 2 |] * 0 * [| 12 = 6 + 6 |] ).  *)
(* reify_sexpr ( Ex x, [| x = 1|]).  *)
(* reify_sexpr ( Ex x, Ex y, Ex z, [| x = y + z|]).  *)
(* reify_sexpr ( Ex x, [| x = 1|]).  *)
(* reify_sexpr ( Ex x : bool, Ex y, Ex z, [| (if x then 1 else 2) = y + z|]).  *)
(* reify_sexpr ( Ex x: bool, [| (if x then true else false) = x|]).  *)
(* reify_sexpr ( Ex x:bool, Ex y : bool, [| (if x then y else false) = andb x y|]).  *)
(* reify_sexpr ( Ex x:bool, Ex y : nat, [| (if x then y else y) = y|]).  *)
(* Fail reify_sexpr (Ex x : (bool -> bool), [| x true = false |]).  *)
(* evar (x : nat); let s := eval simpl in (Ex y : nat, [|x = y|] * [| S x = S y|]) in reify_sexpr s ; clear x.   *)
(* Abort.  *)

(* Goal forall P,    *)
(*        P( Ex x : bool, [|negb (negb x) = false |]). *)
(* intros.   *)
(* assert (forall x, false = (x && negb x)%bool). admit.  *)
(* Require Import Setoid. erewrite H.  *)
(* match goal with  *)
(*     |- P ?l =>  *)
(*       reify_sexpr l *)
(* end.  *)
(* Abort.  *)

(* Goal True.  *)
(* Ltac t f := *)
(* match f with  *)
(*   | (fun x => @?B x) => idtac 1 B;  *)
(*       refl_app ltac:(fun x y z => idtac x y z) B *)
(*   | (fun x => _) => idtac 2 *)
(* end.  *)

(* t ((fun x => (if (x : bool) then true else false))).  *)
(* Abort.  *)
*)


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.

Theorem make_unification : forall (sub : Sub) (env__in : Env) (ty1 ty2 : Ty) (denv : DEnv),
    Sub_app_t ty1 sub = Sub_app_t ty2 sub
  -> FullEInst env__in denv
  -> exists env__out,
      U env__in [(ty1, ty2)] env__out
    /\ FullEInst env__out denv.
Admitted.


Load fml.

Goal forall v: fml, fml_not v = v ==> fml_bot.
reflexivity.
Qed.

Goal forall a b: fml, fml_and a b = a and b.
reflexivity.
Qed.

Goal forall a b: fml, fml_or a b = a or b.
reflexivity.
Qed.


Require Import cprogs.sgn_prog.
Require Import cprogs.sgn_annot.
Require Import AClight.proofauto.
Require Import AClight.advanced_forward.

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

Lemma body_sgn : semax_body Vprog Gprog f_sgn sgn_spec.
Proof.
start_function f_sgn_hint.
verify.
all: entailer!; do 2 f_equal; destruct x; simpl;
  try match goal with
  | H : context [Z.pos ?p] |- _ => pose proof (Pos2Z.pos_is_pos p)
  | H : context [Z.neg ?p] |- _ => pose proof (Pos2Z.neg_is_neg p)
  end;
  omega.
Qed.

(*
Lemma body_sgn : semax_body Vprog Gprog f_sgn sgn_spec.
Proof.
start_function f_sgn_hint.
forwardD.
forwardD.
forwardD.
forwardD.
forwardD.
forwardD.
forwardD.
all: entailer!; do 2 f_equal; destruct x; simpl;
  try match goal with
  | H : context [Z.pos ?p] |- _ => pose proof (Pos2Z.pos_is_pos p)
  | H : context [Z.neg ?p] |- _ => pose proof (Pos2Z.neg_is_neg p)
  end;
  omega.
Qed.
*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.

Goal True -> True -> True.
move=> H1 H2.
move H1 after H2.
Admitted.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal29.

From lfind Require Import LFind.
Lemma lfind_state  (x:lst):@eq lst (rev (rev x)) x.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal29_theorem0_98_rev_involutive/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (x:lst) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


(* File: Forces_NGamma.v  (last edited on 27/10/2000) (c) Klaus Weich  *)

From IPC Require Export Le_Ks.

Definition forces_ngamma (work : nf_list) (ds : disjs)
  (ni : nested_imps) (ai : atomic_imps) (a : atoms)
  (k : kripke_tree) :=
  forall c : normal_form,
  in_ngamma work ds ni ai a c -> forces_t k (nf2form c).

(********************************************************************)

Lemma forces_ngamma_cons_work :
 forall (c : normal_form) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_t k (nf2form c) ->
 forces_ngamma work ds ni ai a k -> forces_ngamma (c :: work) ds ni ai a k.
intros c work ds ni ai a k forces_a forces_ngamma0.
unfold forces_ngamma in |- *.
intros c0 in_ngamma.
elim (in_ngamma_cons_work_rev c work ds ni ai a c0 in_ngamma);
 clear in_ngamma.
intros in_ngamma.
apply forces_ngamma0; assumption.
intros eq_c0_c;  rewrite eq_c0_c; assumption.
Qed.

Lemma forces_ngamma_cons_work_tail :
 forall (c : normal_form) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_ngamma (c :: work) ds ni ai a k -> forces_ngamma work ds ni ai a k.
intros c work ds ni ai a k forces.
unfold forces_ngamma in |- *.
intros c0 in_ngamma.
apply forces.
apply in_ngamma_cons_work_tail; assumption.
Qed.

Remark forces_ngamma_app_work :
 forall (bs work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (k : kripke_tree),
 (forall (n : nat) (b : normal_form),
  my_nth normal_form n bs b -> forces_t k (nf2form b)) ->
 forces_ngamma work ds ni ai a k -> forces_ngamma (bs ++ work) ds ni ai a k.
intros bs work ds ni ai a k forces_bs forces_ngamma0.
unfold forces_ngamma in |- *.
intros c in_ngamma.
elim (in_ngamma_work_app_rev bs work ds ni ai a c in_ngamma); clear in_ngamma.
intros in_ngamma.
apply forces_ngamma0; assumption.
intros nth; elim nth; clear nth.
intros n nth.
apply forces_bs with n; assumption.
Qed.

Lemma forces_ngamma_app_work_tail :
 forall (bs work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (k : kripke_tree),
 forces_ngamma (bs ++ work) ds ni ai a k -> forces_ngamma work ds ni ai a k.
intros bs work ds ni ai a k forces.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply forces.
apply in_ngamma_work_app1; assumption.
Qed.

Lemma forces_ngamma_cons_ds_tail :
 forall (work : nf_list) (i j : Int) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (k : kripke_tree),
 forces_ngamma work ((i, j) :: ds) ni ai a k ->
 forces_ngamma work ds ni ai a k.
intros work i j ds ni ai a k forces.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply forces.
apply in_ngamma_cons_ds_tail; assumption.
Qed.

Lemma forces_ngamma_cons_ni_tail :
 forall (work : nf_list) (ds : disjs) (x : nested_imp)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_ngamma work ds (x :: ni) ai a k -> forces_ngamma work ds ni ai a k.
intros work ds x ni ai a k forces.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply forces.
apply in_ngamma_cons_ni_tail; assumption.
Qed.

Remark forces_ngamma_del_ai :
 forall (i : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai ai' : atomic_imps) (a : atoms) (k : kripke_tree),
 EQUIV_DEL nf_list i ai ai' ->
 forces_ngamma work ds ni ai a k -> forces_ngamma work ds ni ai' a k.
intros i work ds ni ai ai' a k equiv_del k_forces_ngamma.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply k_forces_ngamma.
apply in_ngamma_del_ai_tail with i ai'; assumption.
Qed.

Lemma forces_ngamma_del_ai_rev :
 forall (i : Int) (bs work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai ai' : atomic_imps) (a : atoms)
   (k : kripke_tree),
 LOOKUP nf_list i ai bs ->
 (forall (n : nat) (b : normal_form),
  my_nth normal_form n bs b -> forces_t k (nf2form (AImp i b))) ->
 EQUIV_DEL nf_list i ai ai' ->
 forces_ngamma work ds ni ai' a k -> forces_ngamma work ds ni ai a k.
intros i bs work ds ni ai ai' a k lookup forces_bs equiv_del k_forces_ngamma.
unfold forces_ngamma in |- *.
intros c in_ngamma.
elim (in_ngamma_del_ai_rev work ds ni i bs ai' ai a c); try assumption;
 clear in_ngamma.
intros in_ngamma.
apply k_forces_ngamma; assumption.
intros in_bs; elim in_bs; clear in_bs.
intros b n nth eq_a.
 rewrite eq_a.
apply forces_bs with n; assumption.
Qed.

(***********************************************************************)

Lemma forces_ngamma_eqv :
 forall (ni1 ni2 : nested_imps) (work : nf_list) (ds : disjs)
   (ai : atomic_imps) (a : atoms) (k : kripke_tree),
 eqv_ni ni1 ni2 ->
 forces_ngamma work ds ni2 ai a k -> forces_ngamma work ds ni1 ai a k.
intros ni1 ni2 work ds ai a k eqv12 forces2.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply forces2.
apply in_ngamma_eqv with ni1; assumption.
Qed.

(***********************************************************************)

Lemma forces_ngamma_shift_ds_work :
 forall (i j : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (k : kripke_tree),
 forces_ngamma work ((i, j) :: ds) ni ai a k ->
 forces_ngamma (NDisj i j :: work) ds ni ai a k.
intros i j work ds ni ai a k k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_work_ds; assumption.
Qed.

Lemma forces_ngamma_shift_work_ds :
 forall (i j : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (k : kripke_tree),
 forces_ngamma (NDisj i j :: work) ds ni ai a k ->
 forces_ngamma work ((i, j) :: ds) ni ai a k.
intros i j work ds ni ai a k k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_ds_work; assumption.
Qed.

Lemma forces_ngamma_shift_ni_work :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_ngamma work ds (x :: ni) ai a k ->
 forces_ngamma (NImp_NF (nested_imp2nimp x) :: work) ds ni ai a k.
intros x work ds ni ai a k k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_work_ni; assumption.
Qed.

Lemma forces_ngamma_shift_work_ni :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_ngamma (NImp_NF (nested_imp2nimp x) :: work) ds ni ai a k ->
 forces_ngamma work ds (x :: ni) ai a k.
intros x work ds ni ai a k k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_ni_work; assumption.
Qed.

Lemma forces_ngamma_shift_ai_work_new :
 forall (i : Int) (b : normal_form) (work : nf_list)
   (ds : disjs) (ni : nested_imps) (ai ai' : atomic_imps)
   (a : atoms) (k : kripke_tree),
 (forall bs : nf_list, LOOKUP nf_list i ai bs -> False) ->
 EQUIV_INS nf_list i (cons b) nf_nil ai ai' ->
 forces_ngamma work ds ni ai' a k ->
 forces_ngamma (AImp i b :: work) ds ni ai a k.
intros i b work ds ni ai ai' a k notlookup equiv_ins k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_work_ai_new with i b ai; assumption.
Qed.

Lemma forces_ngamma_shift_ai_work_old :
 forall (i : Int) (b : normal_form) (work : nf_list)
   (ds : disjs) (ni : nested_imps) (bs : nf_list) (ai ai' : atomic_imps)
   (a : atoms) (k : kripke_tree),
 LOOKUP nf_list i ai bs ->
 EQUIV_INS nf_list i (cons b) nf_nil ai ai' ->
 forces_ngamma work ds ni ai' a k ->
 forces_ngamma (AImp i b :: work) ds ni ai a k.
intros i b work ds ni bs ai ai' a k lookup equiv_ins k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_work_ai_old with i b bs ai; assumption.
Qed.

Lemma forces_ngamma_shift_work_ai :
 forall (i : Int) (b : normal_form) (work : nf_list)
   (ds : disjs) (ni : nested_imps) (ai ai' : atomic_imps)
   (a : atoms) (k : kripke_tree),
 EQUIV_INS nf_list i (cons b) nf_nil ai ai' ->
 forces_ngamma (AImp i b :: work) ds ni ai a k ->
 forces_ngamma work ds ni ai' a k.
intros i b work ds ni ai ai' a k equiv_ins k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_ai_work with ai'; assumption.
Qed.

Lemma forces_ngamma_shift_a_work :
 forall (i : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a a' : atoms) (k : kripke_tree),
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 forces_ngamma work ds ni ai a' k ->
 forces_ngamma (NAtom i :: work) ds ni ai a k.
intros i work ds ni ai a a' k equiv_ins k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_work_a with i a; assumption.
Qed.

Lemma forces_ngamma_shift_work_a :
 forall (i : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a a' : atoms) (k : kripke_tree),
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 forces_ngamma (NAtom i :: work) ds ni ai a k ->
 forces_ngamma work ds ni ai a' k.
intros i work ds ni ai a a' k equiv_ins k_forces_ngamma.
unfold forces_ngamma in |- *.
intros d in_gamma.
apply k_forces_ngamma.
apply in_ngamma_shift_a_work with a'; assumption.
Qed.

Lemma forces_ngamma_shift_work_ni_x_ni :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni1 ni2 : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_ngamma (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a k ->
 forces_ngamma work ds (ni1 ++ x :: ni2) ai a k.
intros x work ds ni1 ni2 ai a k forces.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply forces.
apply in_ngamma_shift_ni_x_ni_work; assumption.
Qed.

Lemma forces_ngamma_shift_ni_x_ni_work :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni1 ni2 : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 forces_ngamma work ds (ni1 ++ x :: ni2) ai a k ->
 forces_ngamma (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a k.
intros x work ds ni1 ni2 ai a k forces.
unfold forces_ngamma in |- *.
intros c in_ngamma.
apply forces.
apply in_ngamma_shift_work_ni_x_ni; assumption.
Qed.

(********************************************************************)

Lemma forces_ngamma_cons_work_weak :
 forall (b c : normal_form) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 Is_Monotone_kripke_tree k ->
 (forces_t k (nf2form b) -> forces_t k (nf2form c)) ->
 forces_ngamma (b :: work) ds ni ai a k ->
 forces_ngamma (c :: work) ds ni ai a k.
intros b c work ds ni ai a k k_is_mon forces_bc k_forces_ngamma.
apply forces_ngamma_cons_work.
apply forces_bc.
apply k_forces_ngamma.
apply in_ngamma_cons_work_head.
apply forces_ngamma_cons_work_tail with b; assumption.
Qed.

Lemma forces_ngamma_cons_work_weak2 :
 forall (b c d : normal_form) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (k : kripke_tree),
 Is_Monotone_kripke_tree k ->
 (forces_t k (nf2form b) -> forces_t k (nf2form c) -> forces_t k (nf2form d)) ->
 forces_ngamma (b :: c :: work) ds ni ai a k ->
 forces_ngamma (d :: work) ds ni ai a k.
intros b c d work ds ni ai a k k_is_mon forces_bcd k_forces_ngamma.
apply forces_ngamma_cons_work.
apply forces_bcd.
apply k_forces_ngamma.
apply in_ngamma_cons_work_head.
apply k_forces_ngamma.
apply in_ngamma_cons_work_tail.
apply in_ngamma_cons_work_head.
apply forces_ngamma_cons_work_tail with c.
apply forces_ngamma_cons_work_tail with b; assumption.
Qed.

Lemma forces_ngamma_shift_work_ai_weak :
 forall (i : Int) (bs work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai ai' : atomic_imps) (a : atoms)
   (k : kripke_tree),
 Is_Monotone_kripke_tree k ->
 LOOKUP nf_list i ai bs ->
 EQUIV_DEL nf_list i ai ai' ->
 forces_ngamma (bs ++ work) ds ni ai' a k -> forces_ngamma work ds ni ai a k.
intros i bs work ds ni ai ai' a k k_is_mon lookup equiv_del k_forces_ngamma.
apply forces_ngamma_del_ai_rev with i bs ai'; try assumption.
intros n b nth.
simpl in |- *; apply forces_b__forces_a_imp_b_t.
assumption.
apply k_forces_ngamma.
apply In_Work with n.
apply nth_app0; assumption.
apply forces_ngamma_app_work_tail with bs; assumption.
Qed.

Lemma forces_ngamma_shift_work_ai_strength :
 forall (i : Int) (bs work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai ai' : atomic_imps) (a a' : atoms)
   (k : kripke_tree),
 Is_Monotone_kripke_tree k ->
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 LOOKUP nf_list i ai bs ->
 EQUIV_DEL nf_list i ai ai' ->
 forces_ngamma work ds ni ai a' k ->
 forces_ngamma (bs ++ work) ds ni ai' a' k.
intros i bs work ds ni ai ai' a a' k k_is_mon equiv_ins lookup equiv_del
 forces.
apply forces_ngamma_app_work.
intros n b nth.
apply forces_a_a_imp_b__forces_b_t with (Atom i); try assumption.
apply forces with (c := NAtom i).
apply in_ngamma_ins_a_head with a; assumption.
apply forces with (c := AImp i b).
apply In_Atomic_Imps with (i := i) (b := b) (n := n) (bs := bs); assumption.
apply forces_ngamma_del_ai with i ai; assumption.
Qed.


Require Import AAI.Classes.MonadEnvState.
Require Import AAI.Classes.MonadStoreState.
Require Import AAI.Classes.MonadTimeState.
Require Import AAI.Classes.Addressable.
Require Import AAI.Classes.Transition.
Require Import FP.Core.
Require Import FP.Data.String.
Require Import FP.Data.List.
Require Import FP.Data.Option.
Require Import FP.Data.Product.
Require Import FP.Classes.Monad.
Require Import FP.Classes.Traversable.
Require Import FP.Classes.Peano.

Inductive Op := Add1 | Sub1.

Inductive Call :=
  | IfZC (a:Atom) (tc:Call) (fc:Call)
  | LamAppC (f:Atom) (x:Atom) (k:Atom)
  | KonAppC (k:Atom) (x:Atom)
  | HaltC (a:Atom)
with Atom :=
  | LitA (n:nat)
  | VarA (x:dom string)
  | LamA (x:dom string) (k:dom string) (c:Call)
  | KonA (x:dom string) (c:Call)
  | PrimA (o:Op) (args:vlist Atom).

Inductive Val L :=
  | NumV (n:nat)
  | NatV
  | LamCloV (x:dom string) (k:dom string) (c:dom (lib Call)) (env:dom (env string L))
  | KonCloV (x:dom string) (c:dom (lib Call)) (env:dom (env string L)).
Arguments NumV {L} n.
Arguments NatV {L}.
Arguments LamCloV {L} x k c env.
Arguments KonCloV {L} x c env.

(* Variable names and their meanings:
   - m : the interpretation monad
   - d : the domain of the state space
   - L : location
   - T : time
*)
Class Analysis (d:qtype -> qtype) (L:qtype) (T:qtype) (m:qtype -> qtype) :=
  { Analysis_d_Monad           :> Monad d
  ; Analysis_d_Traversable     :> Traversable d
  ; Analysis_L_DecEq           :> DecEqv (dom L)
  ; Analysis_T_Peano           :> Peano T
  ; Analysis_T_Addressable     :> Addressable string T L
  ; Analysis_m_Monad           :> Monad m
  ; Analysis_m_MonadPlus       :> MonadPlus m
  ; Analysis_m_MonadMorphism   :> MonadMorphism d m
  ; Analysis_m_MonadEnvState   :> MonadEnvState string L m
  ; Analysis_m_MonadStoreState :> MonadStoreState d L (lib (Val L)) m
  ; Analysis_m_MonadTimeState  :> MonadTimeState T m
  }.

Section S.
  Context {d L T m} `{! Analysis d L T m }.
  Context (delt:dom (lib Op ⇒ list (lib (Val L)) ⇒ qoption (lib (Val L)))).

  Definition coerceLamCloV : dom (lib (Val L) ⇒ m (string × string × lib Call × env string L)) :=
    λ (x : dom (lib (Val L))) →
      match x with
      | LamCloV x k c ρ => ret ∙ (x ,, k ,, c ,, ρ)
      | _ => mzero
      end.

  Definition coerceKonCloV : dom (lib (Val L) ⇒ m (string × lib Call × env string L)) :=
    λ (x : dom (lib (Val L))) →
      match x with
      | KonCloV x c ρ => ret ∙ (x ,, c ,, ρ)
      | _ => mzero
      end.

  Fixpoint _atomic (a:Atom) : dom (m (d (lib (Val L)))) :=
    match a with
    | LitA n => ret (m:=m) $ ret (m:=d) $ (NumV n : dom (lib (Val L)))
    | VarA x =>
        a ← lookupEnv ∙ x ;;
        lookupStore ∙ a
    | LamA x k c =>
        env ← getEnv ;;
        ret (m:=m) $ ret (m:=d) $ (LamCloV x k c env : dom (lib (Val L)))
    | KonA x c =>
        env ← getEnv ;;
        ret (m:=m) $ ret (m:=d) $ (KonCloV x c env : dom (lib (Val L)))
    | PrimA o args =>
        let vDMs : dom (list (m (d (lib (Val L))))) := vlmap _atomic args in
        vDs ← sequence ∙ vDMs ;;
        let vsD : dom (d (list (lib (Val L)))) := sequence (t:=list) (m:=d) ∙ vDs in
        let vMD : dom (d (qoption (lib (Val L)))) := mmap (m:=d) ∙ (delt ∙ o) ∙ vsD in
        liftOption $ sequence ∙ vMD
    end.
  Definition atomic : dom (lib Atom ⇒ m (d (lib (Val L)))) := λ (a:dom (lib Atom)) → _atomic a.

  Definition stepApply : dom (lib Call ⇒ list (string × lib Atom) ⇒ env string L ⇒ m (lib Call)) :=
    λ (c:dom (lib Call)) (xs_args:dom (list (string × lib Atom))) (env:dom (env string L)) →
      let UZ := unzip ∙ xs_args in
      let xs := first ∙ UZ in
      let args := second ∙ UZ in
      ls ← traverse ∙ new (L:=L) ∙ xs ;;
      vDs ← traverse ∙ atomic ∙ args ;;
      putEnv (m:=m) ∙ env ;;
      traverse (t:=list) (m:=m) ∙ (modifyEnv (m:=m) ⊙ uncurry ∙ linsert) $ zip ∙ xs ∙ ls ;;
      traverse (t:=list) (m:=m) ∙ (modifyStore (m:=m) ⊙ uncurry ∙ linsert) $ zip ∙ ls ∙ vDs ;;
      ret (m:=m) ∙ c.

  Definition step : dom (lib Call ⇒ m (lib Call)) := λ (c:dom (lib Call)) →
    match c with
    | IfZC a tc fc =>
        vD ← atomic ∙ a ;;
        v ← promote (m₂:=m) ∙ (vD:dom (d (lib (Val L)))) ;;
        match (v:dom (lib (Val L))) with
        | NumV 0 => ret (m:=m) ∙ (tc:dom (lib Call))
        | NumV _ => ret (m:=m) ∙ (fc:dom (lib Call))
        | NatV => (ret (m:=m) ∙ (tc:dom (lib Call)) m+ ret (m:=m) ∙ (fc:dom (lib Call))) : dom (m (lib Call))
        | _ => mzero
        end
    | LamAppC f a ka =>
        vD ← atomic ∙ f ;;
        v ← promote ∙ vD ;;
        r ← coerceLamCloV ∙ v ;;
        prod_elim4 ∙ r $ λ x k c env →
          stepApply ∙ c ∙ ((x ,, (a:dom (lib Atom))) ∷ (k ,, (ka:dom (lib Atom))) ∷ nil) ∙ env
    | KonAppC k a =>
        vD ← atomic ∙ k ;;
        v ← promote ∙ vD ;;
        r ← coerceKonCloV ∙ v ;;
        prod_elim3 ∙ r $ λ x c env →
          stepApply ∙ c ∙ ((x ,, (a:dom (lib Atom))) ∷ nil) ∙ env
    | HaltC a => ret (m:=m) $ (HaltC a:dom (lib (Call)))
    end.

End S.


Require Import SpecCert.Formalism.
Require Import SpecCert.Smm.Delta.Invariant.
Require Import SpecCert.x86.

Lemma lock_smramc_inv:
  preserve_inv LockSmramc.
Proof.
  unfold preserve_inv.
  unfold inv.
  unfold smramc_inv, smram_code_inv.
  intros a a' Hinv Hpre Hpost.
  unfold lock_smramc_pre in Hpre.
  unfold smramc_is_locked in Hinv.
  unfold smramc_is_unlocked in Hpre.
  destruct Hinv as [Hsmramc Hsmm].
  unfold smramc_is_ro in Hsmramc.
  unfold smramc_is_rw in Hpre.
  rewrite Hpre in Hsmramc; discriminate Hsmramc.
Qed.


(*

Author:  Adam Petz, ampetz@ku.edu
*)

Require Import List.
Import ListNotations.

Check fold_left.

Definition f : list nat -> nat -> list nat :=
  fun l (n:nat) => (l ++ [n]).

Lemma fold_monotonic : forall prefix ns tr,
  fold_left f ns [] = tr ->
  fold_left f ns prefix = (prefix ++ tr).
Proof.

  (*
  intros.
  generalize dependent tr.
  generalize dependent prefix.
  induction ns; intros; simpl in *.
  - inversion H; subst. rewrite app_nil_r. trivial.
  -
    rewrite <- IHns.
    unfold f. simpl. fold f.*)
Abort.