Require Import Raft.
Require Import RaftRefinementInterface.

Section VotedForMoreUpToDate.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votedFor_moreUpToDate (net : network) : Prop :=
    forall t h h',
      currentTerm (snd (nwState net h)) = t ->
      type (snd (nwState net h)) = Candidate ->
      votedFor (snd (nwState net h')) = Some h ->
      currentTerm (snd (nwState net h')) = t ->
      exists vl,
        moreUpToDate (maxTerm (log (snd (nwState net h)))) (maxIndex (log (snd (nwState net h))))
                     (maxTerm vl) (maxIndex vl) = true /\
        In (t, h, vl) (votesWithLog (fst (nwState net h'))).

  Class votedFor_moreUpToDate_interface : Prop :=
    {
      votedFor_moreUpToDate_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votedFor_moreUpToDate net
    }.
End VotedForMoreUpToDate.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C T P0 P X Y : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ T B /\ (wd_ A C /\ (wd_ P0 B /\ (wd_ P0 T /\ (wd_ P0 A /\ (wd_ T P /\ (wd_ P B /\ (wd_ Y B /\ (wd_ X B /\ (col_ B P0 P /\ (col_ T P X /\ (col_ T P Y /\ (col_ B C Y /\ col_ B A X))))))))))))))) -> col_ X T Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Definitions from Section 3.5.1 *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_LN_Types_In_Terms Cyclone_Dynamic_Semantics_Heap_Objects.
Require List.
Close Scope list_scope.
Import LibEnvNotations.

(* Question: is abstract heap overloading OK?
   Adding to the left as the get takes the first one, will it break induction? *)

Inductive S : Heap -> St -> Heap -> St -> Prop :=
 | S_let_3_1 : forall (x : var) (v : E) (h : Heap) (s: St),
                 Value v ->
                 get x h = None ->
                 S h (letx v s) ((single x v) & h) (TM.open_rec_st 0 x s)

 | S_seq_3_2 : forall (v : E) (h : Heap) (s: St),
                  Value v ->
                  S h (seqx (e_s v) s) h s

 | S_return_3_3: forall (v : E) (h : Heap) (s: St),
                    Value v ->
                    S h (seqx (retn v) s) h (retn v)

 | S_if0_3_4: forall (h : Heap) (s1 s2: St),
                 S h (if_s (i_e (i_i 0)) s1 s2)
                   h s1

 | S_if_ne_0_3_5: forall (h : Heap) (z : nat) (s1 s2: St),
                     z <> 0 ->
                     S h (if_s (i_e (i_i z)) s1 s2)
                       h s2

 | S_while_3_6: forall (h : Heap) (e : E) (s : St),
                     S h (while e s)
                       h (if_s e (seqx s (while e s)) (e_s (i_e (i_i 0))))

 | S_open_3_7:  forall (tau tau' : Tau) (v : E) (p : Phi) (k : Kappa)
                       (h : Heap) (s : St),
                  Value v ->
                  S h (openx (pack tau' v (etype p k tau)) s)
                    h (letx v (TTM.open_rec_st 0 tau' s))

 | S_openstar_3_8: forall (tau tau' : Tau) (v v' : E) (x : var) (q : Phi) (k : Kappa)
                          (h : Heap) (s : St) (p : Path),
                    Value v ->
                    get x h = Some v' ->
                    get' v' p (pack tau' v (etype q k tau)) ->
                    (* S is part of the context not the heap, overloading ; in DS3.8 *)
                    (* x' is right, openstar uses *x' but I am eliding it in the syntax. *)
                    S h (openstar (p_e (fevar x) p) s)
                      h (letx  (amp (p_e (fevar x) (app p (cons u_pe nil))))
                                     (TTM.open_rec_st 0 tau s))

| S_exp_3_9_1: forall (h h' : Heap) (e e' : E),
                   R h (e_s e) h' (e_s e') ->
                   S h (e_s e) h' (e_s e')

| S_ret_3_9_2: forall (h h' : Heap) (e e' : E),
                   R h (e_s e) h' (e_s e') ->
                   S h (retn e) h' (retn e')

| S_if_3_9_3: forall (h h' : Heap) (e e' : E) (s1 s2 : St),
                   R h (e_s e) h' (e_s e') ->
                   S h (if_s e s1 s2) h' (if_s e' s1 s2)

| S_letx_3_9_4: forall (h h' : Heap) (e e' : E) (s : St),
                   R h (e_s e) h' (e_s e') ->
                   S h (letx e s) h' (letx e' s)

| S_open_3_9_5: forall (h h' : Heap) (e e' : E) (s : St),
                   R h (e_s e) h' (e_s e') ->
                   S h  (openx e  s)
                     h' (openx e' s)

| S_seq_3_10:  forall (h h' : Heap) (s s' s2: St),
                    S h s h' s' ->
                    S h (seqx s  s2) h' (seqx s' s2)

| S_openstar_3_11: forall (h h' : Heap) (e e' : E) (s : St),
                        L h  (e_s e) h' (e_s e') ->
                        S h  (openstar e  s)
                          h' (openstar e' s)
with R : Heap -> St -> Heap -> St -> Prop :=
 | R_get_3_1 : forall (h  : Heap) (x : var) (p : Path) (v v' : E),
                    get x h = Some v' ->
                    get' v' p v ->
                    Value v ->
                    Value v' ->
                    R h (e_s (p_e (fevar x) p))
                      h (e_s v)
 | R_assign_3_2:
     forall (h : Heap) (v v' v'' : E) (x : var) (p : Path),
       get x h = Some v' ->
       set' v' p v v'' ->
       Value v   ->
       Value v'  ->
       Value v'' ->
       R h  (e_s (assign (p_e (fevar x) p) v))
         (h & (single x v'')) (e_s v)

 | R_initial_assign_3_2:
     forall (h : Heap) (v : E) (x : var),
       get x h = None ->
       Value v   ->
       R h  (e_s (assign (p_e (fevar x) nil) v))
         (h & (single x v)) (e_s v)

 | R_star_amp_3_3:
                 forall (h : Heap) (v : var) (p : Path),
                   R h (e_s (star (amp (p_e (fevar v)  p))))
                     h (e_s (p_e (fevar v) p))

 (* Split on 0 or 1. *)
 | R_dot_3_4_0:  forall (h : Heap) (v0 v1 : E),
                    R h (e_s (dot (cpair v0 v1) zero_pe))
                      h (e_s v0)

 | R_dot_3_4_1:  forall (h : Heap) (v0 v1 : E),
                    R h (e_s (dot (cpair v0 v1) one_pe))
                      h (e_s v1)

 | R_appl_3_5:   forall (h : Heap) (tau tau' : Tau) (v : E) (s : St),
                    Value v ->
                    R h (e_s (appl (f_e (dfun tau tau' s)) v))
                      h (e_s (call (letx v s)))

 | R_call_3_6:    forall (h : Heap) (v : E),
                    Value v ->
                    R h (e_s (call (retn v)))
                      h (e_s v)

 | R_inst_3_7:  forall (h : Heap) (k : Kappa) (f : F) (tau : Tau),
                  R h (e_s (inst (f_e (ufun k f)) tau))
                    h (e_s (f_e (TTM.open_rec_f 0 tau f)))

 | R_call_3_8:  forall (h h': Heap) (s s': St),
                  S h s h' s' ->
                  R h (e_s (call s)) h' (e_s (call s'))

 | R_amp_3_9_1: forall (h h' : Heap) (e e' : E),
                   L h (e_s e)       h' (e_s e') ->
                   R h (e_s (amp e)) h' (e_s (amp e'))

 | R_assign_3_9_2: forall (h h' : Heap) (e e' e2: E),
                   L h (e_s e)             h' (e_s e') ->
                   R h (e_s (assign e e2)) h' (e_s (assign e' e2))

 | R_star_3_10_1: forall (h h' : Heap) (e e' : E),
                    R h (e_s e)        h' (e_s e') ->
                    R h (e_s (star e)) h' (e_s (star e'))

 | R_dot_3_10_2: forall (h h' : Heap) (e e' : E) (ipe : IPE),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (dot e  ipe))
                      h' (e_s (dot e' ipe))

 | R_assign_3_10_3: forall (h h' : Heap) (e e' : E) (x : V) (p : Path),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (assign (p_e x p) e))
                      h' (e_s (assign (p_e x p) e'))

 | R_inst_3_10_4:  forall (h h' : Heap) (e e' : E) (tau : Tau),
                 R h (e_s e) h' (e_s e') ->
                 R h  (e_s (inst e tau))
                   h' (e_s (inst e' tau))

 | R_pack_3_10_5:  forall (h h' : Heap) (e e' : E) (tau tau' : Tau) (p : Phi) (k : Kappa),
                    R h (e_s e)        h' (e_s e') ->
                    R h  (e_s (pack tau' e  (etype p k tau)))
                      h' (e_s (pack tau' e' (etype p k tau)))

 | R_cpair_3_10_6:  forall (h h' : Heap) (e e' e2 : E),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair e e2))
                      h' (e_s (cpair e' e2))

 | R_cpair_3_10_7:  forall (h h' : Heap) (e e' v : E),
                    Value v ->
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair v e))
                      h' (e_s (cpair v e'))

 | R_cpair_3_10_8:  forall (h h' : Heap) (e e' e2 : E),
                    R h (e_s e) h' (e_s e') ->
                    R h  (e_s (cpair e e2))
                      h' (e_s (cpair e' e2))

 | R_appl_3_10_9:  forall (h h' : Heap) (e e' e2 : E),
                    R h  (e_s e) h' (e_s e') ->
                    R h  (e_s (appl e e2))
                      h' (e_s (appl e' e2))

 | R_appl_3_10_10: forall (h h' : Heap) (v e e': E),
                     Value v ->
                     R h  (e_s e) h' (e_s e') ->
                     R h  (e_s (appl v e))
                       h' (e_s (appl v e'))

with L : Heap -> St -> Heap -> St -> Prop :=
 | L_xpi_3_1: forall (h : Heap) (x : var) (p : Path) (ipe : IPE),
                L h (e_s (dot (p_e (fevar x) p) ipe))
                  h (e_s (p_e (fevar x) (app p (cons (i_pe ipe) nil))))

 | L_staramp_3_2: forall (h : Heap) (x : V) (p : Path),
                    L h (e_s (star (amp (p_e x p))))
                      h (e_s (p_e x p))

 | L_star_3_3: forall (h h' : Heap) (e e': E),
                 R h (e_s e)        h' (e_s e') ->
                 L h (e_s (star e)) h' (e_s (star e'))

 | L_ei_3_4: forall (h h' : Heap) (e e': E) (ipe : IPE),
               L h (e_s e)                h' (e_s e') ->
               L h (e_s (dot e ipe))  h' (e_s (dot e' ipe)).

Scheme S_ind_mutual := Induction for S Sort Prop
with   R_ind_mutual := Induction for R Sort Prop
with   L_ind_mutual := Induction for L Sort Prop.

Combined Scheme SRL_ind_mutual
         from S_ind_mutual, R_ind_mutual, L_ind_mutual.
(* Auto is not applying some of the rules. *)
Hint Constructors S.
Hint Constructors R.
Hint Constructors L.

Hint Extern 4 (S _ _ _ _) => idtac "(S _ _ _ _)"; trace_goal; constructors~.
Hint Extern 4 (R _ _ _ _) => idtac "(R _ _ _ _)"; trace_goal; constructors~.
Hint Extern 4 (L _ _ _ _) => idtac "(L _ _ _ _)"; trace_goal; constructors~.
Hint Extern 4 (R _ (e_s (p_e (fevar _) _)) _ (e_s _)) => idtac "(R _ (e_s (p_e (fevar _) _)) _ (e_s _))"; trace_goal; applys~ R_get_3_1.


Require Import Primitives Simulation Layer2.Definitions.

Lemma layer2_exec_finished_deterministic:
  forall T (p: prog T) o1 o2 o3 o4 s s1 s2 r1 r2,
      exec o1 s p (Finished s1 r1) ->
      exec o2 s p (Finished s2 r2) ->
      o1 ++ o3 = o2 ++ o4 ->
      o1 = o2 /\ s1 = s2 /\ r1 = r2.
Proof.
  induction p; simpl; intros;
    repeat match goal with
           | [H: exec _ _ _ _ |- _] =>
             inversion H; sigT_eq; simpl in *; cleanup; clear H
           end; simpl; eauto; try solve [intuition].
  repeat rewrite <- app_assoc in H2.
  specialize IHp with (1:= H7)(2:= H8)(3:=H2); cleanup.
  apply app_inv_head in H2.
  specialize H with (1:= H12)(2:= H11)(3:=H2); cleanup; eauto.
Qed.

Lemma layer2_finished_not_crashed_oracle_app:
  forall T (p: prog T) o1 o2 s s1 s2 r1,
    exec o1 s p (Finished s1 r1) ->
    ~exec (o1++o2) s p (Crashed s2).
Proof.
  unfold not; induction p; simpl; intros;
    repeat match goal with
           | [H: exec _ _ _ _ |- _] =>
             inversion H; sigT_eq; simpl in *; cleanup; clear H
           end; simpl; eauto.
  -
    rewrite <- app_assoc in H2.
    eapply layer2_exec_finished_deterministic in H7; eauto; cleanup; eauto.
    apply app_inv_head in H2; cleanup; eauto.

  -
    rewrite <- app_assoc in H6; eauto.
Qed.

Lemma layer2_exec_deterministic:
  forall T (p: prog T) o s r1 r2,
      exec o s p r1 ->
      exec o s p r2 ->
      r1 = r2.
Proof.
  induction p; simpl; intros;
    repeat match goal with
           | [H: exec _ _ _ _ |- _] =>
             inversion H; sigT_eq; simpl in *; cleanup; clear H
           end; simpl; eauto; try solve [intuition].
  eapply layer2_exec_finished_deterministic in H7; eauto; cleanup; eauto.
  apply app_inv_head in H1; cleanup; eauto.
  exfalso; eapply layer2_finished_not_crashed_oracle_app; eauto.
  exfalso; eapply layer2_finished_not_crashed_oracle_app; eauto.
  specialize IHp with (1:= H5)(2:= H6); cleanup; eauto.
Qed.


Require Import RelationClasses Setoid.
From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import edone set_tac finite_quotient preliminaries.
From GraphTheory Require Import digraph sgraph treewidth minor equiv setoid_bigop.
From GraphTheory Require Import structures mgraph pttdom ptt mgraph2 skeleton.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Section Subalgebra.
Variable (Lv : comMonoid) (Le : elabelType).
Notation graph := (graph Lv Le).
Notation graph2 := (graph2 Lv Le).

Implicit Types (G H : graph) (U : sgraph) (T : forest).

Open Scope implicit_scope.

(** * Subalgebra of Tree-Width 2 Graphs *)

Arguments sdecomp T G B : clear implicits.

Definition compatible (T : forest) (G : graph2) (B : T -> {set G}) :=
  exists t, (input \in B t) && (output \in B t).

Lemma sdecomp_sskel (T : forest) (G : graph2) (B : T -> {set G}) :
  sdecomp T (sskeleton G) B <-> (sdecomp T G B /\ compatible B).
Proof.
  split.
  - case => [D1 D2 D3]. split. split => //.
    + move => x y /= xy. apply: D2. by rewrite /edge_rel/= xy.
    + case: (altP (input =P output :> skeleton G)) => E.
      * case: (D1 input) => t Ht. exists t. by rewrite -E !Ht.
      * suff: (input : sskeleton G) -- output by apply: D2. by rewrite /edge_rel/= E !eqxx.
  - move => [[D1 D2 D3] C]. split => //= x y. case/or3P; first exact: D2.
    + case/and3P => ? /eqP E1 /eqP E2. by subst.
    + case/and3P => ? /eqP E1 /eqP E2. subst.
      case: C => t. rewrite andbC. by exists t.
Qed.

Lemma hom_eqL (V : finType) (e1 e2 : rel V) (G : sgraph) (h : V -> G)
      (e1_sym : symmetric e1) (e1_irrefl : irreflexive e1)
      (e2_sym : symmetric e2) (e2_irrefl : irreflexive e2):
  e1 =2 e2 ->
  @hom_s (SGraph e1_sym e1_irrefl) G h ->
  @hom_s (SGraph e2_sym e2_irrefl) G h.
Proof. move => E hom_h x y. rewrite /edge_rel/= -E. exact: hom_h. Qed.

Lemma skel_union_join (G1 G2 : graph) : @sk_rel _ _ (union G1 G2) =2 @join_rel G1 G2.
Proof.
  move => [x|x] [y|y] /=.
  - rewrite /edge_rel/=/sk_rel sum_eqE.
    case: (boolP (x == y)) => //= E. apply/existsP/existsP.
    + move => [[e|e]]; rewrite !inE //= !sum_eqE. by exists e; rewrite !inE.
    + move => [e] H. exists (inl e). by rewrite !inE /= !sum_eqE in H *.
  - apply: contraTF isT => /existsP [[e|e]]; by rewrite !inE //= andbC.
  - apply: contraTF isT => /existsP [[e|e]]; by rewrite !inE //= andbC.
  - rewrite /edge_rel/=/sk_rel sum_eqE.
    case: (boolP (x == y)) => //= E. apply/existsP/existsP.
    + move => [[e|e]]; rewrite !inE //= !sum_eqE. by exists e; rewrite !inE.
    + move => [e] H. exists (inr e). by rewrite !inE /= !sum_eqE in H *.
Qed.

Section Quotients.
  Variables (G1 G2 : graph2).

  Let P : {set union G1 G2} := [set unl input; unl output; unr input; unr output].

  Definition admissible (eqv : rel (union G1 G2)) :=
    forall x y, eqv x y -> x = y \/ [set x;y] \subset P.

  Lemma admissible_eqv_clot (l: pairs (union G1 G2)):
    (forall p, p \in l -> p.1 \in P /\ p.2 \in P) -> admissible (eqv_clot l).
  Proof.
    move => H x y. rewrite eqv_clotE. case/connectP => p.
    have relE u v : rel_of_pairs l u v -> ((u \in P) * (v \in P)) %type.
    { by move /H => /= [-> ->]. }
    elim: p x => /= [x _ -> //|z p IH x /andP [E pth_p] lst_p]; first by left.
    right. rewrite subUset !sub1set. case: (IH _ pth_p lst_p) => [Z|S]; subst.
    - rewrite -Z. case/orP : E => E; by rewrite !(relE _ _ E).
    - case/orP: E => E; rewrite (relE _ _ E) /=; by abstract (set_tac).
  Qed.

  Lemma decomp_quot (T1 T2 : forest) D1 D2 (e : equiv_rel (union G1 G2)):
    sdecomp T1 (sskeleton G1) D1 -> sdecomp T2 (sskeleton G2) D2 ->
    width D1 <= 3 -> width D2 <= 3 ->
    admissible e -> #|[set pi e x | x in P]| <= 3 ->
    exists T D, [/\ sdecomp T (skeleton (merge _ e)) D,
              width D <= 3 & exists t,
              D t = [set \pi x | x in P]].
  Proof using.
    move => /sdecomp_sskel [dec1 comp1] /sdecomp_sskel [dec2 comp2] W1 W2 adm_e collapse_P.
    move: comp1 comp2 => [t1 /andP[t1_in t1_out]] [t2 /andP[t2_in t2_out]].
    pose T := tjoin T1 T2.
    pose D : tjoin T1 T2 -> {set sjoin G1 G2}:= decompU D1 D2.
    have dec_D: sdecomp T (sjoin G1 G2) D by exact: join_decomp.
    have dis_t1_t2 : ~~ connect (@sedge T)(inl t1) (inr t2) by rewrite join_disc.
    have dis_T12 : {in [set inl t1;inr t2] &, forall x y, x != y -> ~~ connect (@sedge T) x y}.
    { move => [?|?] [?|?] /setUP[] /set1P-> /setUP[]/set1P ->.
      all: by rewrite ?eqxx // => _; rewrite sconnect_sym. }
    pose T' := @tlink T _ dis_T12.
    pose D' := decompL D P : _ -> {set sjoin G1 G2}.
    have dec_D' : sdecomp T' (sjoin G1 G2) D'.
    { apply: decomp_link => //.
      apply/subsetP => x.
      rewrite !inE -!orbA => /or4P [] /eqP->.
      all: apply/bigcupP; solve
        [ by exists (inl t1) => //; rewrite ?inE ?imset_f ?eqxx
        | by exists (inr t2) => //; rewrite ?inE ?imset_f ?eqxx]. }
    pose h := pi e : skeleton (union G1 G2) -> skeleton (merge _ e).
    exists T'. exists (rename D' h); split; last by exists None.
    - apply: rename_decomp => //.
      + apply: hom_eqL (pi_hom (e := e)). exact: skel_union_join.
      + exact: pi_surj.
      + move => x y. move/sk_rel_mergeE => [? [x0] [y0] /= [? ? ?]].
        exists x0;exists y0. split => //. by rewrite /edge_rel/= -skel_union_join.
      + move => x y. move/eqquotP => /=. case/adm_e => [<-|A].
        * case: (sbag_cover dec_D' x) => t Ht. left. exists t. by rewrite Ht.
        * left. exists None. by rewrite /= -!sub1set -subUset.
    - rewrite /width (bigop.bigID (pred1 None)).
      rewrite bigop.big_pred1_eq. rewrite geq_max. apply/andP;split => //.
      + rewrite (bigop.reindex Some) /=.
        * apply: (@leq_trans (maxn (width D1) (width D2))); last by rewrite geq_max W1 W2.
          apply: leq_trans (join_width _ _).
          apply: bigmax_leq_pointwise => t _. exact: leq_imset_card.
        * apply: subon_bij; last by (apply bij_on_codom => //; exact: (inl t1)).
          by move => [x|]; rewrite !in_simpl // codom_f.
  Qed.

  Lemma decomp_par2 (T1 T2 : forest) D1 D2 :
    sdecomp T1 (sskeleton G1) D1 -> sdecomp T2 (sskeleton G2) D2 ->
    width D1 <= 3 -> width D2 <= 3 ->
    exists T D, [/\ sdecomp T (sskeleton (G1 ∥ G2)) D & width D <= 3].
  Proof using.
    move => dec1 dec2 W1 W2.
    case: (decomp_quot (e:=eqv_clot [:: (unl input, unr input); (unl output, unr output)])
                       dec1 dec2 W1 W2 _ _).
    - apply admissible_eqv_clot. case => u v.
      rewrite !inE /= !xpair_eqE => /orP [] /andP [/eqP -> /eqP->]; by rewrite !eqxx.
    - pose P' : {set union G1 G2} := [set unl input; unl output].
      apply: (@leq_trans #|P'|); last by rewrite cards2; by case (_ != _).
      apply: (@leq_trans #|[set (\pi x : G1 ∥ G2) | x in P']|); last exact: leq_imset_card.
      apply: subset_leq_card.
      apply/subsetP => ? /imsetP [x H1 ->]. case/setUP : H1 => H1; first case/setUP : H1 => H1.
      * by rewrite imset_f.
      * move/set1P : H1 => ->. apply/imsetP. exists (unl input); first by rewrite !inE eqxx ?orbT.
        apply/eqquotP. eqv.
      * move/set1P : H1 => ->. apply/imsetP. exists (unl output); first by rewrite !inE eqxx ?orbT.
        apply/eqquotP. eqv.
    - move => T [D] [A B [t C]]. exists T. exists D. split => //.
      apply/sdecomp_sskel. split => //.
      exists t. by rewrite C !imset_f // !inE ?eqxx ?orbT.
  Qed.

  Lemma decomp_dot2 (T1 T2 : forest) D1 D2 :
    sdecomp T1 (sskeleton G1) D1 -> sdecomp T2 (sskeleton G2) D2 ->
    width D1 <= 3 -> width D2 <= 3 ->
    exists T D, [/\ sdecomp T (sskeleton (G1 · G2)) D & width D <= 3].
  Proof using.
    move => dec1 dec2 W1 W2.
    case: (decomp_quot (e:=eqv_clot [:: (unl output, unr input)]) dec1 dec2 W1 W2 _ _).
    - apply admissible_eqv_clot. case => u v.
      rewrite !inE /= !xpair_eqE => /andP [/eqP -> /eqP->]; by rewrite !eqxx.
    - pose P' : {set union G1 G2} := [set unl input; unl output; unr output].
      apply: (@leq_trans #|P'|); last apply cards3.
      apply: (@leq_trans #|[set (\pi x : G1 · G2) | x in P']|); last exact: leq_imset_card.
      apply: subset_leq_card.
      apply/subsetP => ? /imsetP [x H1 ->]. move: H1.
      rewrite /P -!setUA [[set _;_]]setUC !setUA. case/setUP => H1.
      * by rewrite imset_f.
      * move/set1P : H1 => ->. apply/imsetP. exists (unl output); first by rewrite !inE eqxx ?orbT.
        apply/eqquotP. eqv.
    - move => T [D] [A B [t C]]. exists T. exists D. split => //.
      apply/sdecomp_sskel. split => //.
      exists t. by rewrite C !imset_f // !inE ?eqxx ?orbT.
  Qed.

End Quotients.

Lemma decomp_cnv (G : graph2) T D :
  sdecomp T (sskeleton G) D -> sdecomp T (sskeleton (G°)) D.
Proof.
  move/sdecomp_sskel => [dec cmp]. apply/sdecomp_sskel; split => //.
  move: cmp => [t] H. exists t => /=. by rewrite andbC.
Qed.

Lemma decomp_dom (G : graph2) T D :
  sdecomp T (sskeleton G) D -> sdecomp T (sskeleton (dom G)) D.
Proof.
  move/sdecomp_sskel => [dec cmp]. apply/sdecomp_sskel; split => //.
  move: cmp => [t] /andP [H _]. exists t => /=. by rewrite !H.
Qed.

Theorem eval_TW2 A (f: A -> graph2):
  (forall a, exists T D, [/\ sdecomp T (sskeleton (f a)) D & width D <= 3]) ->
  forall u, exists T D, [/\ sdecomp T (sskeleton (eval f u)) D & width D <= 3].
Proof.
  move => Hf. elim => [u IHu v IHv | u IHu v IHv | u IHu | u IHu | | | a].
  - move: IHu IHv => [T1] [D1] [? ?] [T2] [D2] [? ?].
    exact: (decomp_dot2 (D1 := D1) (D2 := D2)).
  - move: IHu IHv => [T1] [D1] [? ?] [T2] [D2] [? ?].
    exact: (decomp_par2 (D1 := D1) (D2 := D2)).
  - move: IHu => [T] [D] [D1 D2]. exists T. exists D. split => //.
    exact: decomp_cnv.
  - move: IHu => [T] [D] [D1 D2]. exists T. exists D. split => //.
    exact: decomp_dom.
  - apply: decomp_small. by rewrite card_unit.
  - apply: decomp_small. by rewrite card_sum card_unit.
  - apply Hf.
Qed.

End Subalgebra.

Section s.
Variable A: Type.
Let graph_of_term: term A -> graph2 unit (flat A) := eval (fun a : flat A => g2_var _ a).

Theorem graph_of_TW2 (u : term A) :
  exists T D, [/\ @sdecomp T (sskeleton (graph_of_term u)) D & width D <= 3].
Proof.
  apply eval_TW2 => a.
  apply: decomp_small. by rewrite card_sum card_unit.
Qed.

Lemma sskel_K4_free (u : term A) : K4_free (sskeleton (graph_of_term u)).
Proof.
  case: (graph_of_TW2 u) => T [B] [B1 B2].
  exact: TW2_K4_free B1 B2.
Qed.

Lemma skel_K4_free (u : term A) : K4_free (skeleton (graph_of_term u)).
Proof.
  apply: minor_K4_free (@sskel_K4_free u).
  exact: sub_minor (skel_sub _).
Qed.

(* TODO: define the subalgebra as a ptt_algebra? (with sigma types) *)

End s.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Require Import Coq.Strings.Ascii.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Tools.Matches.
Import Core.Notations.

Require Coq.derive.Derive.

Notation named_list := (@named_list string).
Notation named_map := (@named_map string).
Notation term := (@term string).
Notation ctx := (@ctx string).
Notation sort := (@sort string).
Notation subst := (@subst string).
Notation rule := (@rule string).
Notation lang := (@lang string).

(*
  TODO: extend parameterizer to have option to put variable at the end
  - make a no-types subst, selectively parameterize w/ A for val_subst

  For now, just duplicating
 *)

Definition ty_subst_def : lang :=
  {[l
  [s|
      -----------------------------------------------
      #"env" srt
  ];
  [s| "G" : #"env", "G'" : #"env"
      -----------------------------------------------
      #"sub" "G" "G'" srt
  ];
  [:| "G" : #"env"
       -----------------------------------------------
       #"id" : #"sub" "G" "G"
  ];
  [:| "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2",
       "g" : #"sub" "G2" "G3"
       -----------------------------------------------
       #"cmp" "f" "g" : #"sub" "G1" "G3"
  ];
  [:= "G" : #"env", "G'" : #"env", "f" : #"sub" "G" "G'"
      ----------------------------------------------- ("id_right")
      #"cmp" "f" #"id" = "f" : #"sub" "G" "G'"
  ];
  [:= "G" : #"env", "G'" : #"env", "f" : #"sub" "G" "G'"
       ----------------------------------------------- ("id_left")
       #"cmp" #"id" "f" = "f" : #"sub" "G" "G'"
  ];
   [:= "G1" : #"env",
         "G2" : #"env",
         "G3" : #"env",
         "G4" : #"env",
         "f" : #"sub" "G1" "G2",
         "g" : #"sub" "G2" "G3",
         "h" : #"sub" "G3" "G4"
         ----------------------------------------------- ("cmp_assoc")
         #"cmp" "f" (#"cmp" "g" "h") = #"cmp" (#"cmp" "f" "g") "h" : #"sub" "G1" "G4"
  ];
  [s| "G" : #"env"
      -----------------------------------------------
      #"ty" "G" srt
  ];
  [:| "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'",
       "A" : #"ty" "G'"
       -----------------------------------------------
       #"ty_subst" "g" "v" : #"ty" "G"
  ];
  [:= "G" : #"env", "A" : #"ty" "G"
       ----------------------------------------------- ("ty_subst_id")
       #"ty_subst" #"id" "A" = "A" : #"ty" "G"
  ];
  [:= "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2", "g" : #"sub" "G2" "G3",
       "A" : #"ty" "G3"
       ----------------------------------------------- ("ty_subst_cmp")
       #"ty_subst" "f" (#"ty_subst" "g" "A")
       = #"ty_subst" (#"cmp" "f" "g") "A"
       : #"ty" "G1"
  ];
  [:|
      -----------------------------------------------
      #"emp" : #"env"
  ];
  [:| "G" : #"env"
      -----------------------------------------------
      #"forget" : #"sub" "G" #"emp"
  ];
  [:= "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'"
       ----------------------------------------------- ("cmp_forget")
       #"cmp" "g" #"forget" = #"forget" : #"sub" "G" #"emp"
  ];
  [:=
      ----------------------------------------------- ("id_emp_forget")
      #"id" = #"forget" : #"sub" #"emp" #"emp"
  ];
  [:| "G" : #"env"
       -----------------------------------------------
       #"ext" "G" : #"env"
  ];
  [:| "G" : #"env", "G'" : #"env",
      "g" : #"sub" "G" "G'",
      "A" : #"ty" "G"
       -----------------------------------------------
       #"snoc" "g" "A" : #"sub" "G" (#"ext" "G'")
  ];
  [:| "G" : #"env"
       -----------------------------------------------
       #"wkn" : #"sub" (#"ext" "G") "G"
  ];
  [:| "G" : #"env"
       -----------------------------------------------
       #"hd" : #"ty" (#"ext" "G")
  ];
   [:= "G" : #"env", "G'" : #"env",
      "g" : #"sub" "G" "G'",
      "A" : #"ty" "G"
      ----------------------------------------------- ("wkn_snoc")
      #"cmp" (#"snoc" "g" "A") #"wkn" = "g" : #"sub" "G" "G'"
  ];
   [:= "G" : #"env", "G'" : #"env",
       "g" : #"sub" "G" "G'",
       "A" : #"ty" "G"
       ----------------------------------------------- ("snoc_hd")
       #"ty_subst" (#"snoc" "g" "A") #"hd" = "A"
       : #"ty" "G"
  ];
   [:= "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2",
       "g" : #"sub" "G2" "G3",
       "A" : #"ty" "G2"
       ----------------------------------------------- ("cmp_snoc")
       #"cmp" "f" (#"snoc" "g" "A")
       = #"snoc" (#"cmp" "f" "g") (#"ty_subst" "f" "A")
       : #"sub" "G1" (#"ext" "G3")
   ];
      [:= "G" : #"env"
       ----------------------------------------------- ("snoc_wkn_hd")
        #"snoc" #"wkn" #"hd" = #"id" : #"sub" (#"ext" "G") (#"ext" "G")
   ]
  ]}.

Parameterization logic:
  put parameter before first thing that needs it, if none, at the end
Note: for this lang, just the none check should be acceptable (but not ideal)

Definition value_subst_def : lang :=
  {[l
  [s|
      -----------------------------------------------
      #"env" srt
  ];
  [s| "G" : #"env", "G'" : #"env"
      -----------------------------------------------
      #"sub" "G" "G'" srt
  ];
  [:| "G" : #"env"
       -----------------------------------------------
       #"id" : #"sub" "G" "G"
  ];
  [:| "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2",
       "g" : #"sub" "G2" "G3"
       -----------------------------------------------
       #"cmp" "f" "g" : #"sub" "G1" "G3"
  ];
  [:= "G" : #"env", "G'" : #"env", "f" : #"sub" "G" "G'"
      ----------------------------------------------- ("id_right")
      #"cmp" "f" #"id" = "f" : #"sub" "G" "G'"
  ];
  [:= "G" : #"env", "G'" : #"env", "f" : #"sub" "G" "G'"
       ----------------------------------------------- ("id_left")
       #"cmp" #"id" "f" = "f" : #"sub" "G" "G'"
  ];
   [:= "G1" : #"env",
         "G2" : #"env",
         "G3" : #"env",
         "G4" : #"env",
         "f" : #"sub" "G1" "G2",
         "g" : #"sub" "G2" "G3",
         "h" : #"sub" "G3" "G4"
         ----------------------------------------------- ("cmp_assoc")
         #"cmp" "f" (#"cmp" "g" "h") = #"cmp" (#"cmp" "f" "g") "h" : #"sub" "G1" "G4"
  ];
  [s|
      -----------------------------------------------
      #"ty" srt
  ];
  [s| "G" : #"env", "A" : #"ty"
      -----------------------------------------------
      #"val" "G" "A" srt
  ];
  [:| "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'",
       "A" : #"ty", "v" : #"val" "G'" "A"
       -----------------------------------------------
       #"val_subst" "g" "v" : #"val" "G" "A"
  ];
  [:= "G" : #"env", "A" : #"ty", "e" : #"val" "G" "A"
       ----------------------------------------------- ("val_subst_id")
       #"val_subst" #"id" "e" = "e" : #"val" "G" "A"
  ];
  [:= "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2", "g" : #"sub" "G2" "G3",
       "A" : #"ty", "v" : #"val" "G3" "A"
       ----------------------------------------------- ("val_subst_cmp")
       #"val_subst" "f" (#"val_subst" "g" "v")
       = #"val_subst" (#"cmp" "f" "g") "v"
       : #"val" "G1" "A"
  ];
  [:|
      -----------------------------------------------
      #"emp" : #"env"
  ];
  [:| "G" : #"env"
      -----------------------------------------------
      #"forget" : #"sub" "G" #"emp"
  ];
  [:= "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'"
       ----------------------------------------------- ("cmp_forget")
       #"cmp" "g" #"forget" = #"forget" : #"sub" "G" #"emp"
  ];
  [:=
      ----------------------------------------------- ("id_emp_forget")
      #"id" = #"forget" : #"sub" #"emp" #"emp"
  ];
  [:| "G" : #"env", "A": #"ty"
       -----------------------------------------------
       #"ext" "G" "A" : #"env"
  ];
  [:| "G" : #"env", "G'" : #"env", "A" : #"ty",
      "g" : #"sub" "G" "G'",
      "v" : #"val" "G" "A" (*we restrict substitutions to values *)
       -----------------------------------------------
       #"snoc" "g" "v" : #"sub" "G" (#"ext" "G'" "A")
  ];
  [:| "G" : #"env", "A" : #"ty"
       -----------------------------------------------
       #"wkn" : #"sub" (#"ext" "G" "A") "G"
  ];
  [:| "G" : #"env", "A" : #"ty"
       -----------------------------------------------
       #"hd" : #"val" (#"ext" "G" "A") "A"
  ];
   [:= "G" : #"env", "G'" : #"env",
      "g" : #"sub" "G" "G'",
      "A" : #"ty",
      "v" : #"val" "G" "A"
      ----------------------------------------------- ("wkn_snoc")
      #"cmp" (#"snoc" "g" "v") #"wkn" = "g" : #"sub" "G" "G'"
  ];
   [:= "G" : #"env", "G'" : #"env",
       "g" : #"sub" "G" "G'",
       "A" : #"ty",
       "v" : #"val" "G" "A"
       ----------------------------------------------- ("snoc_hd")
       #"val_subst" (#"snoc" "g" "v") #"hd" = "v"
       : #"val" "G" "A"
  ];
   [:= "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2",
       "g" : #"sub" "G2" "G3",
       "A" : #"ty",
       "v" : #"val" "G2" "A"
       ----------------------------------------------- ("cmp_snoc")
       #"cmp" "f" (#"snoc" "g" "v")
       = #"snoc" (#"cmp" "f" "g") (#"val_subst" "f" "v")
       : #"sub" "G1" (#"ext" "G3" "A")
   ];
      [:= "G" : #"env", "A" : #"ty"
       ----------------------------------------------- ("snoc_wkn_hd")
        #"snoc" #"wkn" #"hd" = #"id" : #"sub" (#"ext" "G" "A") (#"ext" "G" "A")
   ]
  ]}.

(*TODO: use elab_lang notation?*)
Derive value_subst
       SuchThat (elab_lang_ext [] value_subst_def value_subst)
       As value_subst_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve value_subst_wf : elab_pfs.

Compute (map fst value_subst).

Definition subst_lang_renaming prefix signature x :=
  match x with
  | "snoc_wkn_hd" =>
; "cmp_snoc"; "snoc_hd"; "wkn_snoc"; "hd"; "wkn";
       "snoc"; "ext"; "id_emp_forget"; "cmp_forget"; "forget"; "emp";
       "val_subst_cmp"; "val_subst_id"; "val_subst"; "val"; "ty";
       "cmp_assoc"; "id_left"; "id_right"; "cmp"; "id"; "sub"; "env"]

Definition exp_subst_def : lang :=
  {[l
      [s| "G" : #"env", "A" : #"ty"
          -----------------------------------------------
          #"exp" "G" "A" srt
      ];
  [:| "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'",
       "A" : #"ty", "e" : #"exp" "G'" "A"
       -----------------------------------------------
       #"exp_subst" "g" "e" : #"exp" "G" "A"
  ];
  [:= "G" : #"env", "A" : #"ty", "e" : #"exp" "G" "A"
       ----------------------------------------------- ("exp_subst_id")
       #"exp_subst" #"id" "e" = "e" : #"exp" "G" "A"
  ];
  [:= "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2", "g" : #"sub" "G2" "G3",
       "A" : #"ty", "e" : #"exp" "G3" "A"
       ----------------------------------------------- ("exp_subst_cmp")
       #"exp_subst" "f" (#"exp_subst" "g" "e")
       = #"exp_subst" (#"cmp" "f" "g") "e"
       : #"exp" "G1" "A"
  ];
  [:| "G" : #"env", "A" : #"ty", "v" : #"val" "G" "A"
       -----------------------------------------------
       #"ret" "v" : #"exp" "G" "A"
  ];
  [:= "G1" : #"env", "G2" : #"env",
       "g" : #"sub" "G1" "G2",
       "A" : #"ty", "v" : #"val" "G2" "A"
       ----------------------------------------------- ("exp_subst_ret")
       #"exp_subst" "g" (#"ret" "v")
       = #"ret" (#"val_subst" "g" "v")
       : #"exp" "G1" "A"
  ]
  ]}.

Derive exp_subst
       SuchThat (elab_lang_ext value_subst exp_subst_def exp_subst)
       As exp_subst_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve exp_subst_wf : elab_pfs.

Definition block_subst_def : lang :=
  {[l
      [s| "G" : #"env"
          -----------------------------------------------
          #"blk" "G" srt
      ];
  [:| "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'",
      "e" : #"blk" "G'"
       -----------------------------------------------
       #"blk_subst" "g" "e" : #"blk" "G"
  ];
  [:= "G" : #"env", "e" : #"blk" "G"
       ----------------------------------------------- ("blk_subst_id")
       #"blk_subst" #"id" "e" = "e" : #"blk" "G"
  ];
  [:= "G1" : #"env", "G2" : #"env", "G3" : #"env",
       "f" : #"sub" "G1" "G2", "g" : #"sub" "G2" "G3",
       "e" : #"blk" "G3"
       ----------------------------------------------- ("blk_subst_cmp")
       #"blk_subst" "f" (#"blk_subst" "g" "e")
       = #"blk_subst" (#"cmp" "f" "g") "e"
       : #"blk" "G1"
  ]
  ]}.

Derive block_subst
       SuchThat (elab_lang_ext value_subst block_subst_def block_subst)
       As block_subst_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve block_subst_wf : elab_pfs.

Fixpoint notinb (s : string) (l : list string) :=
  match l with
  | [] => true
  | s'::l' => if eqb s s' then false else notinb s l'
  end.

Definition definitely_fresh (s : string) (l : list string) :=
  let len := List.fold_left Nat.max (map String.length l) 0 in
  String.append s (string_of_list_ascii (repeat ("'"%char : ascii) len)).

Definition choose_fresh (s : string) (c:ctx) :=
  if notinb s (map fst c) then s else definitely_fresh s (map fst c).

(*TODO: duplicated*)
Definition under s :=
  {{e #"snoc" (#"cmp" #"wkn" {s}) #"hd"}}.

Definition get_subst_constr s :=
  match s with
  | "exp" => Some "exp_subst"
  | "val" => Some "val_subst"
  | "blk" => Some "blk_subst"
  | _ => None
  end.

Section GenRHSSubterms.
  Context (G : string)
          (g : string).

  (*TODO: careful! _ in patterns does bad things (treated as a var)
   document &/or fix *)
  Fixpoint gen_arg_subst s :=
    match s with
    | {{e#"emp"}} => {{e#"forget"}}
    | var G' => if G =? G' then var g else {{e#"ERR1"}}
    | {{e#"ext" {s'} {_} }} => under (gen_arg_subst s')
    | _ => {{e#"ERR2" {s} }}
    end.

  Fixpoint gen_rhs_subterms c args {struct c} :=
    match c, args with
    | (n1,t)::c', n2::args' =>
      if n1 =? n2
      then
        match t with
        | scon name [G']
        | scon name [_;G'] =>
          match get_subst_constr name with
          | Some subst_constr =>
            let s := gen_arg_subst G' in
            let e := {{e #subst_constr {s} n1 }} in
            e::(gen_rhs_subterms c' args')
          | _ => (var n1)::(gen_rhs_subterms c' args')
          end
        | _ => (var n1)::(gen_rhs_subterms c' args')
        end
      else gen_rhs_subterms c' args
    | _, _ => []
    end.
End GenRHSSubterms.

Definition substable_constr name c args t : option lang :=
  match t with
  (*TODO: assumes arbitrary G below the line. Is that the behavior I want or can I generalize?*)
  | scon s [A; var G] =>
    match get_subst_constr s with
    | Some subst_constr =>
      let constr_rule := term_rule c args t in
      let G' := choose_fresh "G'" c in
      let g := choose_fresh "g" c in
      let c' := (g,{{s#"sub" G' G }})
                  ::(G', {{s#"env"}})
                  ::c in
      let blank_term := con name (map var args) in
      let lhs := {{e #subst_constr g {blank_term} }} in
      let rhs := con name (gen_rhs_subterms G g c args) in
      let t' := scon s [A; var G'] in
      let subst_rule :=
          term_eq_rule c' lhs rhs t' in
      Some [(append name "-subst",subst_rule);(name, constr_rule)]
    | None => None
    end
  (*TODO: duplicated work for blocks since there is no A*)
  | scon s [var G] =>
    match get_subst_constr s with
    | Some subst_constr =>
      let constr_rule := term_rule c args t in
      let G' := choose_fresh "G'" c in
      let g := choose_fresh "g" c in
      let c' := (g,{{s#"sub" G' G }})
                  ::(G', {{s#"env"}})
                  ::c in
      let blank_term := con name (map var args) in
      let lhs := {{e #subst_constr g {blank_term} }} in
      let rhs := con name (gen_rhs_subterms G g c args) in
      let t' := scon s [var G'] in
      let subst_rule :=
          term_eq_rule c' lhs rhs t' in
      Some [(append name "-subst",subst_rule);(name, constr_rule)]
    | None => None
    end
  | _ => None
  end.

Definition sc '(n,r) :=
  match r with
  |term_rule c args t =>
   match substable_constr n c args t with
   | Some l => l
   | None => [(n,r)]
   end
  | r => [(n,r)]
  end.

Notation "'{[l/subst' r1 ; .. ; r2 ]}" :=
  (List.flat_map sc (cons r2 .. (cons r1 nil) ..))%rule
  (format "'[' {[l/subst '[hv' r1 ; '/' .. ; '/' r2 ']' ]} ']'") : lang_scope.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Export NatLemmas.

Set Implicit Arguments.

Module Type VariablesSig.
  Inductive Var : Set :=
  | var   : nat -> Var.

 Axiom beq_var : Var -> Var -> bool.
 Hint Resolve beq_var.
End VariablesSig.


(* ** Construction of standard models *)
From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts.
From Undecidability.FOL.Sets Require Import ZF binZF.
From Undecidability.FOL Require Import Undecidability.Reductions.PCPb_to_ZF.
From Undecidability.FOL.Sets.Models Require Import Aczel Aczel_CE Aczel_TD.

Set Default Proof Using "Type".

(* *** Extensional model of ZF using CE and TD *)

Section ZFM.

  Context { Delta : extensional_normaliser }.

  Instance SET_interp : interp SET.
  Proof.
    split; intros [].
    - intros _. exact Sempty.
    - intros v. exact (Supair (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Sunion (Vector.hd v)).
    - intros v. exact (Spower (Vector.hd v)).
    - intros _. exact Som.
    - intros v. exact (IN (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Vector.hd v = Vector.hd (Vector.tl v)).
  Defined.

  Lemma SET_ext :
    extensional SET_interp.
  Proof.
    intros x y. reflexivity.
  Qed.

  Lemma Anumeral_numeral n :
    NS (Anumeral n) = numeral n.
  Proof.
    induction n; trivial.
    cbn [numeral]. rewrite <- IHn.
    apply Aeq_NS_eq. cbn -[Anumeral].
    now rewrite <- !CR1.
  Qed.

  Lemma SET_standard :
    standard SET_interp.
  Proof.
    intros x. cbn. destruct x. unfold Som, NS, IN. cbn.
    rewrite <- (CR1 Aom). intros [n Hn]. exists n.
    rewrite <- Anumeral_numeral. now apply Aeq_p1_NS_eq.
  Qed.

  Lemma SET_ZF' rho :
    rho ⊫ ZF'.
  Proof.
    intros phi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; cbn.
    - intros X Y H1 H2. now apply set_ext.
    - apply emptyE.
    - intros X Y Z. split; apply upairAx.
    - intros X Y. split; apply unionAx.
    - intros X Y. split; apply powerAx.
    - apply omAx1.
    - apply omAx2.
  Qed.

  Lemma SET_sep phi rho :
    rho ⊨ ax_sep phi.
  Proof.
    intros x. cbn.
    exists (Ssep (fun y => (y .: rho) ⊨ phi) x).
    intros y. rewrite sepAx.
    split; intros [H1 H2]; split; trivial.
    - setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [].
    - setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [].
  Qed.

  Lemma SET_rep phi rho :
    rho ⊨ ax_rep phi.
  Proof.
    intros H x. cbn.
    exists (Srep (fun u v => (u .: (v .: rho)) ⊨ phi) x).
    intros y. rewrite repAx.
    - split; intros [z[H1 H2]]; exists z; split; trivial.
      + setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [|[]].
      + setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [|[]].
    - intros a b b' H1 H2. apply (H a b b'); fold sat; eapply sat_comp, sat_ext.
      2: apply H1. 3: apply H2. all: intros [|[]]; reflexivity.
  Qed.

End ZFM.

Definition TD :=
  exists delta : (Acz -> Prop) -> Acz, forall P, (exists s : Acz, forall t : Acz, P t <-> Aeq t s) -> P (delta P).

Lemma TD_CE_normaliser :
  CE -> TD -> inhabited extensional_normaliser.
Proof.
  intros ce [delta H]. split. unshelve econstructor.
  - exact delta.
  - exact H.
  - intros P P' HP. now rewrite (ce _ _ HP).
  - intros s H1 H2. apply Aczel_CE.PI, ce.
Qed.

Lemma normaliser_model :
  CE -> TD -> exists V (M : interp V), extensional M /\ standard M /\ forall rho psi, ZF psi -> rho ⊨ psi.
Proof.
  intros H1 H2. assert (inhabited extensional_normaliser) as [H] by now apply TD_CE_normaliser.
  exists SET, SET_interp. split; try apply SET_ext.
  split; try apply SET_standard. intros rho psi [].
  - now apply SET_ZF'.
  - apply SET_sep.
  - apply SET_rep.
Qed.

Lemma normaliser_model_eq :
  CE -> TD -> exists V (M : interp V), extensional M /\ standard M /\ forall rho psi, ZFeq psi -> rho ⊨ psi.
Proof.
  intros H1 H2. assert (inhabited extensional_normaliser) as [H] by now apply TD_CE_normaliser.
  exists SET, SET_interp. split; try apply SET_ext.
  split; try apply SET_standard. intros rho psi [].
  - destruct H0 as [<-|[<-|[<-|[<-|H0]]]]; cbn; try congruence. now apply SET_ZF'.
  - apply SET_sep.
  - apply SET_rep.
Qed.

(* *** Extensional model of Z using CE *)

Section ZM.

  Hypothesis ce : CE.

  Instance SET_interp' : interp SET'.
  Proof using ce.
    split; intros [].
    - intros _. exact empty.
    - intros v. exact (upair ce (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (union ce (Vector.hd v)).
    - intros v. exact (power ce (Vector.hd v)).
    - intros _. exact om.
    - intros v. exact (ele (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Vector.hd v = Vector.hd (Vector.tl v)).
  Defined.

  Lemma SET_ext' :
    extensional SET_interp'.
  Proof.
    intros x y. reflexivity.
  Qed.

  Lemma Anumeral_numeral' n :
    classof (Anumeral n) = numeral n.
  Proof.
    induction n.
    - reflexivity.
    - cbn [Anumeral]. rewrite <- (succ_eq ce).
      rewrite IHn. reflexivity.
  Qed.

  Lemma SET_standard' :
    standard SET_interp'.
  Proof.
    intros x. cbn. destruct (classof_ex ce x) as [s ->].
    intros [n Hn] % classof_ele. exists n.
    rewrite <- Anumeral_numeral'. now apply classof_eq.
  Qed.

  Lemma SET'_ZF' rho :
    rho ⊫ ZF'.
  Proof.
    intros phi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; cbn.
    - intros X Y H1 H2. now apply Aczel_CE.set_ext.
    - now apply Aczel_CE.emptyE.
    - intros X Y Z. split; apply Aczel_CE.upairAx.
    - intros X Y. split; apply Aczel_CE.unionAx.
    - intros X Y. split; apply Aczel_CE.powerAx.
    - apply om_Ax1.
    - apply om_Ax2.
  Qed.

  Lemma SET_sep' phi rho :
    rho ⊨ ax_sep phi.
  Proof.
    intros x. cbn.
    exists (sep ce (fun y => (y .: rho) ⊨ phi) x).
    intros y. rewrite Aczel_CE.sepAx.
    split; intros [H1 H2]; split; trivial.
    - setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [].
    - setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [].
  Qed.

End ZM.

Lemma extensionality_model :
  CE -> exists V (M : interp V), extensional M /\ standard M /\ forall rho phi, Z phi -> rho ⊨ phi.
Proof.
  intros ce. exists SET', (SET_interp' ce). split; try apply SET_ext'.
  split; try apply SET_standard'. intros rho phi [].
  - now apply SET'_ZF'.
  - apply SET_sep'.
Qed.

Lemma extensionality_model_eq :
  CE -> exists V (M : interp V), extensional M /\ standard M /\ forall rho phi, Zeq phi -> rho ⊨ phi.
Proof.
  intros ce. exists SET', (SET_interp' ce). split; try apply SET_ext'.
  split; try apply SET_standard'. intros rho phi [].
  - destruct H as [<-|[<-|[<-|[<-|H0]]]]; cbn; try congruence.
    now intros x x' y y' -> ->. now apply SET'_ZF'.
  - apply SET_sep'.
Qed.

(* *** Intensional model of Z' without assumptions *)

Section IM.

  Instance Acz_interp : interp Acz.
  Proof.
    split; intros [].
    - intros _. exact AEmpty.
    - intros v. exact (Aupair (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Aunion (Vector.hd v)).
    - intros v. exact (Apower (Vector.hd v)).
    - intros _. exact Aom.
    - intros v. exact (Ain (Vector.hd v) (Vector.hd (Vector.tl v))).
    - intros v. exact (Aeq (Vector.hd v) (Vector.hd (Vector.tl v))).
  Defined.

  Lemma Acz_standard :
    standard Acz_interp.
  Proof.
    intros s [n Hn]. cbn in Hn. exists n. apply Hn.
  Qed.

  Lemma Acz_ZFeq' rho :
    rho ⊫ ZFeq'.
  Proof.
    intros phi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]]]]]; cbn.
    - apply Aeq_ref.
    - apply Aeq_sym.
    - apply Aeq_tra.
    - intros s t s' t' -> ->. tauto.
    - apply Aeq_ext.
    - apply AEmptyAx.
    - intros X Y Z. apply AupairAx.
    - intros X Y. apply AunionAx.
    - intros X Y. apply ApowerAx.
    - apply AomAx1.
    - apply AomAx2.
  Qed.

  (*
  Lemma Acz_sep phi rho :
    rho ⊨ ax_sep phi.
  Proof.
    intros x. cbn.
    exists (Asep (fun y => (y .: rho) ⊨ phi) x).
    intros y. rewrite AsepAx.
    split; intros [H1 H2]; split; trivial.
    - setoid_rewrite sat_comp. eapply sat_ext; try apply H2. now intros [].
    - setoid_rewrite sat_comp in H2. eapply sat_ext; try apply H2. now intros [].
    - intros s t. admit.
  Admitted.
  *)

End IM.

Lemma intensional_model :
  exists V (M : interp V), standard M /\ forall rho, rho ⊫ ZFeq'.
Proof.
  exists Acz, Acz_interp. split; try apply Acz_standard. apply Acz_ZFeq'.
Qed.