Require Import Crypto.Util.Notations.
Local Set Universe Polymorphism.

(** [x <- f ; C] encodes a call to function [f] with [C] as the
  continuation. In [C], [x] refers to the output of [f]. *)

Declare Scope cps_scope.
Delimit Scope cps_scope with cps.

(* [cpscall] is a marker to get Coq to print code using this notation only when it was actually used *)
Definition cpscall {R} (f:forall{T}(continuation:R->T),T) {T} (continuation:R->T)
:= @f T continuation.
Notation "x' <- v ; C" := (cpscall v%cps (fun x' => C%cps)) : cps_scope.

(** A value of type [~>R] accepts a continuation that takes an
     argument of type [R].  It is meant to be used in [Definition] and
     such; for example:
<<
     Definition add_cps (a b:nat) : ~> nat.
>>
     The return type of the continuation is not yet specified; every
     [~> R] is universally quantified over the possible return types
     of the continuations that it can be applied to.
 *)
Notation "~> R" := (forall T (_:R->T), T) : type_scope.

(** The type [A ~> R] contains functions that takes an argument of
  type [A] and pass a value of type [R] to the continuation. Functions
  that take multiple arguments can be encoded as [A -> B ~> C] or [A
  ~> B ~>C] -- the first form requires both arguments to be specified
  before its output can be CPS-bound, the latter must be bound once it
  is partially applied to one argument. *)
Notation "A ~> R" := (A -> ~>R) : type_scope.

(* [cpsreturn] is a marker to get Coq to print loop notations before a [return] *)
Definition cpsreturn {T} (x:T) := x.
(** [return x] passes [x] to the continuation implicit in the previous notations. *)
Notation "'return' x" := (cpsreturn (fun T (continuation:_->T) => continuation x)) : cps_scope.

Definition cpsbind {A B} (v:~> A) (f:A ~> B) : ~> B
  := fun T k => (a <- v; fa <- f a; k fa)%cps.
Notation "x' <--- v ; C" := (cpsbind v%cps (fun x' => C%cps)) : cps_scope.

Definition cps_option_bind {A B} (v:~> option A) (f:A ~> option B) : ~> option B
  := cpsbind v (fun x' T k => match x' with Some x' => f x' T k | None => k None end).
Notation "x' <-- v ; C" := (cps_option_bind v%cps (fun x' => C%cps)) : cps_scope.

Module CPSBindNotations.
  Notation "x' <- v ; C" := (cpsbind v%cps (fun x' => C%cps)) : cps_scope.
End CPSBindNotations.


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 F D G E : Universe, ((wd_ A B /\ (wd_ B F /\ (wd_ A F /\ (wd_ B D /\ (wd_ A D /\ (wd_ F D /\ (wd_ G E /\ (wd_ G F /\ (wd_ E F /\ (wd_ G F /\ (wd_ F A /\ (wd_ G A /\ (col_ A B F /\ (col_ G E F /\ col_ G F A)))))))))))))) -> col_ A G E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Verdi.Verdi.
Require Import Verdi.HandlerMonad.
Require Import Verdi.NameOverlay.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import AggregationDefinitions.
Require Import AggregationAux.

Require Import Orders.
Require Import MSetFacts.
Require Import MSetProperties.
Require Import Sumbool.
Require String.

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.fintype.
Require Import mathcomp.ssreflect.finset.
Require Import mathcomp.fingroup.fingroup.

Require Import commfingroup.

Require Import AAC_tactics.AAC.

(* FIXME: ANT not needed *)
Module SingleAggregator (Import NT : NameType)
 (NOT : NameOrderedType NT) (NSet : MSetInterface.S with Module E := NOT)
 (NOTC : NameOrderedTypeCompat NT) (NMap : FMapInterface.S with Module E := NOTC)
 (Import CFG : CommutativeFinGroup)
 (Import ANT : AdjacentNameType NT)
 (Import AD : ADefs NT NOT NSet NOTC NMap CFG).

Module AX := AAux NT NOT NSet NOTC NMap CFG ANT AD.
Import AX.

Import GroupScope.

Module ADCFGAACInstances := CFGAACInstances CFG.
Import ADCFGAACInstances.

Module NSetFacts := Facts NSet.
Module NSetProps := Properties NSet.
Module NSetOrdProps := OrdProperties NSet.

Require Import FMapFacts.
Module NMapFacts := Facts NMap.

Inductive Input : Type :=
| Aggregate : name -> m -> Input
| Fail : name -> Input
| New : name -> Input
| Local : m -> Input
| SendAggregate : name -> Input
| AggregateRequest : String.string -> Input.

Definition Input_eq_dec : forall x y : Input, {x = y} + {x <> y}.
decide equality.
- exact: m_eq_dec.
- exact: name_eq_dec.
- exact: name_eq_dec.
- exact: name_eq_dec.
- exact: m_eq_dec.
- exact: name_eq_dec.
- exact: String.string_dec.
Defined.

Inductive Output : Type :=
| AggregateResponse : String.string -> m -> Output.

Definition Output_eq_dec : forall x y : Output, {x = y} + {x <> y}.
decide equality; auto using String.string_dec, m_eq_dec.
Defined.

Record Data := mkData {
  local : m ;
  aggregate : m ;
  adjacent : NS ;
  balance : NM
}.

Definition InitData :=
  {| local := 1 ;
     aggregate := 1 ;
     adjacent := NSet.empty ;
     balance := NMap.empty m |}.

Definition Handler (S : Type) := GenHandler unit S Output unit.

Definition IOHandler (i : Input) : Handler Data :=
st <- get ;;
match i with
| Aggregate src m_inp =>
  when (NSet.mem src st.(adjacent))
  (match NMap.find src st.(balance) with
  | None => nop
  | Some m_src =>
    put {| local := st.(local) ;
           aggregate := st.(aggregate) * m_inp ;
           adjacent := st.(adjacent) ;
           balance := NMap.add src (m_src * (m_inp)^-1) st.(balance) |}
  end)
| Fail src =>
  when (NSet.mem src st.(adjacent))
  (match NMap.find src st.(balance) with
  | Some m_bal =>
    put {| local := st.(local) ;
           aggregate := st.(aggregate) * m_bal ;
           adjacent := NSet.remove src st.(adjacent) ;
           balance := NMap.remove src st.(balance) |}
  | None => nop
  end)
| New src =>
  when (~~ NSet.mem src st.(adjacent))
  (put {| local := st.(local) ;
         aggregate := st.(aggregate) ;
         adjacent := NSet.add src st.(adjacent) ;
         balance := NMap.add src 1 st.(balance) |})
| Local m_inp =>
  put {| local := m_inp ;
         aggregate := st.(aggregate) * m_inp * st.(local)^-1 ;
         adjacent := st.(adjacent) ;
         balance := st.(balance) |}
| AggregateRequest client_id =>
  write_output (AggregateResponse client_id st.(aggregate))
| SendAggregate dst =>
  when (NSet.mem dst st.(adjacent) && sumbool_not _ _ (m_eq_dec st.(aggregate) 1))
  (match NMap.find dst st.(balance) with
   | Some m_dst =>
     put {| local := st.(local) ;
            aggregate := 1 ;
            adjacent := st.(adjacent) ;
            balance := NMap.add dst (m_dst * st.(aggregate)) st.(balance) |}
   | None => nop
   end)
end.

Instance Aggregator_BaseParams : BaseParams :=
  {
    data := Data ;
    input := Input ;
    output := Output
  }.

Instance Aggregator_SingleParams : SingleParams Aggregator_BaseParams :=
  {
    init_handler := InitData ;
    input_handler := fun i d => runGenHandler1_ignore (IOHandler i) d
  }.

Lemma IOHandler_cases :
  forall i st u out st' ms,
      IOHandler i st = (u, out, st', ms) ->
      (exists m_inp m_src src, i = Aggregate src m_inp /\ NSet.In src st.(adjacent) /\ NMap.find src st.(balance) = Some m_src /\
       st'.(local) = st.(local) /\
       st'.(aggregate) = st.(aggregate) * m_inp /\
       st'.(adjacent) = st.(adjacent) /\
       st'.(balance) = NMap.add src (m_src * (m_inp)^-1) st.(balance) /\
       out = []) \/
      (exists m_inp src, i = Aggregate src m_inp /\ NSet.In src st.(adjacent) /\ NMap.find src st.(balance) = None /\
       st' = st /\ out = []) \/
      (exists m_inp src, i = Aggregate src m_inp /\ ~ NSet.In src st.(adjacent) /\
       st' = st /\ out = []) \/
      (exists m_bal src, i = Fail src /\ NSet.In src st.(adjacent) /\ NMap.find src st.(balance) = Some m_bal /\
       st'.(local) = st.(local) /\
       st'.(aggregate) = st.(aggregate) * m_bal /\
       st'.(adjacent) = NSet.remove src st.(adjacent) /\
       st'.(balance) = NMap.remove src st.(balance) /\
       out = []) \/
      (exists src, i = Fail src /\ NSet.In src st.(adjacent) /\ NMap.find src st.(balance) = None /\
       st' = st /\ out = []) \/
      (exists src, i = Fail src /\ ~ NSet.In src st.(adjacent) /\
       st' = st /\ out = []) \/
      (exists src, i = New src /\ ~ NSet.In src st.(adjacent) /\
       st'.(local) = st.(local) /\
       st'.(aggregate) = st.(aggregate) /\
       st'.(adjacent) = NSet.add src st.(adjacent) /\
       st'.(balance) = NMap.add src 1 st.(balance) /\
       out = []) \/
      (exists src, i = New src /\ NSet.In src st.(adjacent) /\
       st' = st /\ out = []) \/
      (exists m_inp, i = Local m_inp /\
       st'.(local) = m_inp /\
       st'.(aggregate) = st.(aggregate) * m_inp * st.(local)^-1 /\
       st'.(adjacent) = st.(adjacent) /\
       st'.(balance) = st.(balance) /\
       out = []) \/
      (exists dst m_bal, i = SendAggregate dst /\ NSet.In dst st.(adjacent) /\ st.(aggregate) <> 1 /\ NMap.find dst st.(balance) = Some m_bal /\
         st'.(local) = st.(local) /\
         st'.(aggregate) = 1 /\
         st'.(adjacent) = st.(adjacent) /\
         st'.(balance) = NMap.add dst (m_bal * st.(aggregate)) st.(balance) /\
         out = []) \/
      (exists dst, i = SendAggregate dst /\ NSet.In dst st.(adjacent) /\ st.(aggregate) <> 1 /\ NMap.find dst st.(balance) = None /\
         st' = st /\
         out = []) \/
      (exists dst, i = SendAggregate dst /\ ~ NSet.In dst st.(adjacent) /\
         st' = st /\
         out = []) \/
      (exists dst, i = SendAggregate dst /\ st.(aggregate) = 1 /\
         st' = st /\
         out = []) \/
      (exists client_id, i = AggregateRequest client_id /\ st' = st /\ out = [AggregateResponse client_id (aggregate st)]).
Proof.
move => i st u out st' ms.
rewrite /IOHandler.
case: i => [src m_inp|src|src|m_inp|dst|]; monad_unfold.
- move => H_eq.
  repeat break_match; repeat tuple_inversion.
  * find_apply_lem_hyp NSetFacts.mem_2.
    left => /=.
    by exists m_inp; exists a; exists src.
  * find_apply_lem_hyp NSetFacts.mem_2.
    right; left => /=.
    by exists m_inp; exists src.
  * have H_ins: ~ NSet.In src st'.(adjacent) by move => H_ins; find_apply_lem_hyp NSetFacts.mem_1; eauto.
    right; right; left.
    by exists m_inp; exists src.
- move => H_eq.
  repeat break_match; repeat tuple_inversion.
  * find_apply_lem_hyp NSetFacts.mem_2.
    right; right; right; left => /=.
    by exists a; exists src.
  * find_apply_lem_hyp NSetFacts.mem_2.
    right; right; right; right; left => /=.
    by exists src.
  * have H_ins: ~ NSet.In src st'.(adjacent) by move => H_ins; find_apply_lem_hyp NSetFacts.mem_1; eauto.
    right; right; right; right; right; left => /=.
    by exists src.
- move => H_eq.
  repeat break_let; break_match; repeat tuple_inversion.
  * have H_ins: ~ NSet.In src st.(adjacent) by move => H_ins; find_apply_lem_hyp NSetFacts.mem_1; rewrite H_ins in Heqb.
    right; right; right; right; right; right; left => /=.
    by exists src.
  * move/negP/negP: Heqb => Heqb.
    find_apply_lem_hyp NSetFacts.mem_2.
    right; right; right; right; right; right; right; left => /=.
    by exists src.
- move => H_eq.
  repeat tuple_inversion.
  right; right; right; right; right; right; right; right; left => /=.
  by exists m_inp.
- move => H_eq.
  repeat break_let; break_if; first (repeat break_let; break_match).
  * move/andP: Heqb => /= [H_mem H_neq].
    repeat tuple_inversion.
    rewrite /sumbool_not in H_neq.
    break_match => //.
    find_apply_lem_hyp NSetFacts.mem_2.
    right; right; right; right; right; right; right; right; right; left => /=.
    by exists dst; exists a.
  * move/andP: Heqb => /= [H_mem H_neq].
    repeat tuple_inversion.
    rewrite /sumbool_not in H_neq.
    break_match => //.
    find_apply_lem_hyp NSetFacts.mem_2.
    right; right; right; right; right; right; right; right; right; right; left => /=.
    by exists dst.
  * move/nandP: Heqb => /= Heqb.
    repeat tuple_inversion.
    break_or_hyp.
      move/negP: H => H.
      have H_ins: ~ NSet.In dst st'.(adjacent) by move => H_ins; find_apply_lem_hyp NSetFacts.mem_1.
      right; right; right; right; right; right; right; right; right; right; right; left => /=.
      by exists dst.
    unfold sumbool_not in *.
    break_match => //.
    right; right; right; right; right; right; right; right; right; right; right; right; left => /=.
    by exists dst.
- move => client_id H_eq.
  tuple_inversion.
  right; right; right; right; right; right; right; right; right; right; right; right; right.
  by exists client_id.
Qed.

Ltac io_handler_cases :=
  find_apply_lem_hyp IOHandler_cases;
  intuition idtac; try break_exists;
  intuition idtac; subst;
  repeat find_rewrite.

Definition conserves_node_mass (d : data) : Prop :=
d.(local) = d.(aggregate) * sumM d.(adjacent) d.(balance).

Lemma Aggregator_conserves_node_mass :
 forall st tr, step_s_star init_handler st tr ->
  conserves_node_mass st.
Proof.
move => st tr H_st.
remember init_handler as y in *.
move: Heqy.
induction H_st using refl_trans_1n_trace_n1_ind => H_init.
  rewrite H_init /conserves_node_mass /InitData /init_handler /=.
  rewrite sumM_empty; first by gsimpl.
  exact NSetFacts.empty_1.
concludes.
match goal with
| [ H : step_s _ _ _ |- _ ] => invc H
end; simpl.
rewrite /handler /= /runGenHandler1_ignore /= in H0.
repeat break_let.
repeat tuple_inversion.
io_handler_cases; unfold conserves_node_mass in *; simpl in * => //.
- repeat find_rewrite.
  rewrite sumM_add_map //; gsimpl.
  set m1 := aggregate _.
  set m2 := sumM _ _.
  set rhs := _ * _ * _.
  suff H_suff: rhs = m1 * m2 * (x * x^-1) by rewrite H_suff; gsimpl.
  rewrite /rhs.
  by aac_reflexivity.
- repeat find_rewrite.
  rewrite (sumM_remove_remove H H1); gsimpl.
  set m1 := aggregate _.
  set m2 := sumM _ _.
  set rhs := _ * _ * _.
  suff H_suff: rhs = m1 * m2 * (x * x^-1) by rewrite H_suff; gsimpl.
  rewrite /rhs.
  by aac_reflexivity.
- repeat find_rewrite.
  rewrite sumM_add_add //.
  by gsimpl.
- repeat find_rewrite.
  gsimpl.
  set m0 := local _.
  set m1 := aggregate _.
  set m2 := sumM _ _.
  set rhs := _ * _.
  suff H_suff: rhs = m0 * (m1 * m1^-1) * (m2 * m2^-1) by rewrite H_suff; gsimpl.
  rewrite /rhs.
  by aac_reflexivity.
- repeat find_rewrite.
  rewrite sumM_add_map //.
  gsimpl.
  by aac_reflexivity.
Qed.

End SingleAggregator.


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 Bprime Cprime : Universe, ((wd_ A Bprime /\ (wd_ A Cprime /\ (wd_ B Bprime /\ (wd_ A C /\ (wd_ C Cprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A B /\ (wd_ B Cprime /\ (wd_ Bprime C /\ (col_ A Bprime Cprime /\ (col_ A B C /\ col_ C B Bprime)))))))))))) -> col_ A Cprime C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From stdpp Require Export set.
From iris.algebra Require Export cmra.
From iris.algebra Require Import dra.
Set Default Proof Using "Type".
Local Arguments valid _ _ !_ /.
Local Arguments op _ _ !_ !_ /.
Local Arguments core _ _ !_ /.

(** * Definition of STSs *)
Module sts.
Structure stsT := Sts {
  state : Type;
  token : Type;
  prim_step : relation state;
  tok : state → set token;
}.
Arguments Sts {_ _} _ _.
Arguments prim_step {_} _ _.
Arguments tok {_} _.
Notation states sts := (set (state sts)).
Notation tokens sts := (set (token sts)).

(** * Theory and definitions *)
Section sts.
Context {sts : stsT}.

(** ** Step relations *)
Inductive step : relation (state sts * tokens sts) :=
  | Step s1 s2 T1 T2 :
     prim_step s1 s2 → tok s1 ## T1 → tok s2 ## T2 →
     tok s1 ∪ T1 ≡ tok s2 ∪ T2 → step (s1,T1) (s2,T2).
Notation steps := (rtc step).
Inductive frame_step (T : tokens sts) (s1 s2 : state sts) : Prop :=
  (* Possible alternative definition: (tok s2) ## T) ∧ s \rightarrow s'.
     This is not equivalent, but it might be good enough? *)
  | Frame_step T1 T2 :
     T1 ## tok s1 ∪ T → step (s1,T1) (s2,T2) → frame_step T s1 s2.
Notation frame_steps T := (rtc (frame_step T)).

(** ** Closure under frame steps *)
Record closed (S : states sts) (T : tokens sts) : Prop := Closed {
  closed_disjoint s : s ∈ S → tok s ## T;
  closed_step s1 s2 : s1 ∈ S → frame_step T s1 s2 → s2 ∈ S
}.
Definition up (s : state sts) (T : tokens sts) : states sts :=
  {[ s' | frame_steps T s s' ]}.
Definition up_set (S : states sts) (T : tokens sts) : states sts :=
  S ≫= λ s, up s T.

(** Tactic setup *)
Hint Resolve Step.
Hint Extern 50 (equiv (A:=set _) _ _) => set_solver : sts.
Hint Extern 50 (¬equiv (A:=set _) _ _) => set_solver : sts.
Hint Extern 50 (_ ∈ _) => set_solver : sts.
Hint Extern 50 (_ ⊆ _) => set_solver : sts.
Hint Extern 50 (_ ## _) => set_solver : sts.

(** ** Setoids *)
Instance frame_step_mono : Proper (flip (⊆) ==> (=) ==> (=) ==> impl) frame_step.
Proof.
  intros ?? HT ?? <- ?? <-; destruct 1; econstructor;
    eauto with sts; set_solver.
Qed.
Global Instance frame_step_proper : Proper ((≡) ==> (=) ==> (=) ==> iff) frame_step.
Proof. move=> ?? /collection_equiv_spec [??]; split; by apply frame_step_mono. Qed.
Instance closed_proper' : Proper ((≡) ==> (≡) ==> impl) closed.
Proof. destruct 3; constructor; intros until 0; setoid_subst; eauto. Qed.
Global Instance closed_proper : Proper ((≡) ==> (≡) ==> iff) closed.
Proof. by split; apply closed_proper'. Qed.
Global Instance up_preserving : Proper ((=) ==> flip (⊆) ==> (⊆)) up.
Proof.
  intros s ? <- T T' HT ; apply elem_of_subseteq.
  induction 1 as [|s1 s2 s3 [T1 T2]]; [constructor|].
  eapply elem_of_mkSet, rtc_l; [eapply Frame_step with T1 T2|]; eauto with sts.
Qed.
Global Instance up_proper : Proper ((=) ==> (≡) ==> (≡)) up.
Proof.
  by move=> ??? ?? /collection_equiv_spec [??]; split; apply up_preserving.
Qed.
Global Instance up_set_preserving : Proper ((⊆) ==> flip (⊆) ==> (⊆)) up_set.
Proof.
  intros S1 S2 HS T1 T2 HT. rewrite /up_set.
  f_equiv=> // s1 s2. by apply up_preserving.
Qed.
Global Instance up_set_proper : Proper ((≡) ==> (≡) ==> (≡)) up_set.
Proof.
  move=> S1 S2 /collection_equiv_spec [??] T1 T2 /collection_equiv_spec [??];
    split; by apply up_set_preserving.
Qed.

(** ** Properties of closure under frame steps *)
Lemma closed_steps S T s1 s2 :
  closed S T → s1 ∈ S → frame_steps T s1 s2 → s2 ∈ S.
Proof. induction 3; eauto using closed_step. Qed.
Lemma closed_op T1 T2 S1 S2 :
  closed S1 T1 → closed S2 T2 → closed (S1 ∩ S2) (T1 ∪ T2).
Proof.
  intros [? Hstep1] [? Hstep2]; split; [set_solver|].
  intros s3 s4; rewrite !elem_of_intersection; intros [??] [T3 T4 ?]; split.
  - apply Hstep1 with s3, Frame_step with T3 T4; auto with sts.
  - apply Hstep2 with s3, Frame_step with T3 T4; auto with sts.
Qed.
Lemma step_closed s1 s2 T1 T2 S Tf :
  step (s1,T1) (s2,T2) → closed S Tf → s1 ∈ S → T1 ## Tf →
  s2 ∈ S ∧ T2 ## Tf ∧ tok s2 ## T2.
Proof.
  inversion_clear 1 as [???? HR Hs1 Hs2]; intros [? Hstep]??; split_and?; auto.
  - eapply Hstep with s1, Frame_step with T1 T2; auto with sts.
  - set_solver -Hstep Hs1 Hs2.
Qed.
Lemma steps_closed s1 s2 T1 T2 S Tf :
  steps (s1,T1) (s2,T2) → closed S Tf → s1 ∈ S → T1 ## Tf →
  tok s1 ## T1 → s2 ∈ S ∧ T2 ## Tf ∧ tok s2 ## T2.
Proof.
  remember (s1,T1) as sT1 eqn:HsT1; remember (s2,T2) as sT2 eqn:HsT2.
  intros Hsteps; revert s1 T1 HsT1 s2 T2 HsT2.
  induction Hsteps as [?|? [s2 T2] ? Hstep Hsteps IH];
     intros s1 T1 HsT1 s2' T2' ?????; simplify_eq; first done.
  destruct (step_closed s1 s2 T1 T2 S Tf) as (?&?&?); eauto.
Qed.

(** ** Properties of the closure operators *)
Lemma elem_of_up s T : s ∈ up s T.
Proof. constructor. Qed.
Lemma subseteq_up_set S T : S ⊆ up_set S T.
Proof. intros s ?; apply elem_of_bind; eauto using elem_of_up. Qed.
Lemma elem_of_up_set S T s : s ∈ S → s ∈ up_set S T.
Proof. apply subseteq_up_set. Qed.
Lemma up_up_set s T : up s T ≡ up_set {[ s ]} T.
Proof. by rewrite /up_set collection_bind_singleton. Qed.
Lemma closed_up_set S T : (∀ s, s ∈ S → tok s ## T) → closed (up_set S T) T.
Proof.
  intros HS; unfold up_set; split.
  - intros s; rewrite !elem_of_bind; intros (s'&Hstep&Hs').
    specialize (HS s' Hs'); clear Hs' S.
    induction Hstep as [s|s1 s2 s3 [T1 T2 ? Hstep] ? IH]; first done.
    inversion_clear Hstep; apply IH; clear IH; auto with sts.
  - intros s1 s2; rewrite /up; set_unfold; intros (s&?&?) ?; exists s.
    split; [eapply rtc_r|]; eauto.
Qed.
Lemma closed_up s T : tok s ## T → closed (up s T) T.
Proof.
  intros; rewrite -(collection_bind_singleton (λ s, up s T) s).
  apply closed_up_set; set_solver.
Qed.
Lemma closed_up_set_empty S : closed (up_set S ∅) ∅.
Proof. eauto using closed_up_set with sts. Qed.
Lemma closed_up_empty s : closed (up s ∅) ∅.
Proof. eauto using closed_up with sts. Qed.
Lemma up_closed S T : closed S T → up_set S T ≡ S.
Proof.
  intros ?; apply collection_equiv_spec; split; auto using subseteq_up_set.
  intros s; unfold up_set; rewrite elem_of_bind; intros (s'&Hstep&?).
  induction Hstep; eauto using closed_step.
Qed.
Lemma up_subseteq s T S : closed S T → s ∈ S → sts.up s T ⊆ S.
Proof. move=> ?? s' ?. eauto using closed_steps. Qed.
Lemma up_set_subseteq S1 T S2 : closed S2 T → S1 ⊆ S2 → sts.up_set S1 T ⊆ S2.
Proof. move=> ?? s [s' [? ?]]. eauto using closed_steps. Qed.
Lemma up_op s T1 T2 : up s (T1 ∪ T2) ⊆ up s T1 ∩ up s T2.
Proof. (* Notice that the other direction does not hold. *)
  intros x Hx. split; eapply elem_of_mkSet, rtc_subrel; try exact Hx.
  - intros; eapply frame_step_mono; last first; try done. set_solver+.
  - intros; eapply frame_step_mono; last first; try done. set_solver+.
Qed.
End sts.

Notation steps := (rtc step).
Notation frame_steps T := (rtc (frame_step T)).

(* The type of bounds we can give to the state of an STS. This is the type
   that we equip with an RA structure. *)
Inductive car (sts : stsT) :=
  | auth : state sts → set (token sts) → car sts
  | frag : set (state sts) → set (token sts ) → car sts.
Arguments auth {_} _ _.
Arguments frag {_} _ _.
End sts.

Notation stsT := sts.stsT.
Notation Sts := sts.Sts.

(** * STSs form a disjoint RA *)
Section sts_dra.
Context (sts : stsT).
Import sts.
Implicit Types S : states sts.
Implicit Types T : tokens sts.

Inductive sts_equiv : Equiv (car sts) :=
  | auth_equiv s T1 T2 : T1 ≡ T2 → auth s T1 ≡ auth s T2
  | frag_equiv S1 S2 T1 T2 : T1 ≡ T2 → S1 ≡ S2 → frag S1 T1 ≡ frag S2 T2.
Existing Instance sts_equiv.
Instance sts_valid : Valid (car sts) := λ x,
  match x with
  | auth s T => tok s ## T
  | frag S' T => closed S' T ∧ ∃ s, s ∈ S'
  end.
Instance sts_core : Core (car sts) := λ x,
  match x with
  | frag S' _ => frag (up_set S' ∅ ) ∅
  | auth s _  => frag (up s ∅) ∅
  end.
Inductive sts_disjoint : Disjoint (car sts) :=
  | frag_frag_disjoint S1 S2 T1 T2 :
     (∃ s, s ∈ S1 ∩ S2) → T1 ## T2 → frag S1 T1 ## frag S2 T2
  | auth_frag_disjoint s S T1 T2 : s ∈ S → T1 ## T2 → auth s T1 ## frag S T2
  | frag_auth_disjoint s S T1 T2 : s ∈ S → T1 ## T2 → frag S T1 ## auth s T2.
Existing Instance sts_disjoint.
Instance sts_op : Op (car sts) := λ x1 x2,
  match x1, x2 with
  | frag S1 T1, frag S2 T2 => frag (S1 ∩ S2) (T1 ∪ T2)
  | auth s T1, frag _ T2 => auth s (T1 ∪ T2)
  | frag _ T1, auth s T2 => auth s (T1 ∪ T2)
  | auth s T1, auth _ T2 => auth s (T1 ∪ T2)(* never happens *)
  end.

Hint Extern 50 (equiv (A:=set _) _ _) => set_solver : sts.
Hint Extern 50 (∃ s : state sts, _) => set_solver : sts.
Hint Extern 50 (_ ∈ _) => set_solver : sts.
Hint Extern 50 (_ ⊆ _) => set_solver : sts.
Hint Extern 50 (_ ## _) => set_solver : sts.

Global Instance auth_proper s : Proper ((≡) ==> (≡)) (@auth sts s).
Proof. by constructor. Qed.
Global Instance frag_proper : Proper ((≡) ==> (≡) ==> (≡)) (@frag sts).
Proof. by constructor. Qed.

Instance sts_equivalence: Equivalence ((≡) : relation (car sts)).
Proof.
  split.
  - by intros []; constructor.
  - by destruct 1; constructor.
  - destruct 1; inversion_clear 1; constructor; etrans; eauto.
Qed.
Lemma sts_dra_mixin : DraMixin (car sts).
Proof.
  split.
  - apply _.
  - by do 2 destruct 1; constructor; setoid_subst.
  - by destruct 1; constructor; setoid_subst.
  - by destruct 1; simpl; intros ?; setoid_subst.
  - by intros ? [|]; destruct 1; inversion_clear 1; econstructor; setoid_subst.
  - destruct 3; simpl in *; destruct_and?; eauto using closed_op;
      match goal with H : closed _ _ |- _ => destruct H end; set_solver.
  - intros []; naive_solver eauto using closed_up, closed_up_set,
      elem_of_up, elem_of_up_set with sts.
  - intros [] [] [] _ _ _ _ _; constructor; rewrite ?assoc; auto with sts.
  - destruct 4; inversion_clear 1; constructor; auto with sts.
  - destruct 4; inversion_clear 1; constructor; auto with sts.
  - destruct 1; constructor; auto with sts.
  - destruct 3; constructor; auto with sts.
  - intros []; constructor; eauto with sts.
  - intros []; constructor; auto with sts.
  - intros [s T|S T]; constructor; auto with sts.
    + rewrite (up_closed (up _ _)); auto using closed_up with sts.
    + rewrite (up_closed (up_set _ _)); eauto using closed_up_set with sts.
  - intros x y. exists (core (x ⋅ y))=> ?? Hxy; split_and?.
    + destruct Hxy; constructor; unfold up_set; set_solver.
    + destruct Hxy; simpl;
        eauto using closed_up_set_empty, closed_up_empty with sts.
    + destruct Hxy; econstructor;
        repeat match goal with
        | |- context [ up_set ?S ?T ] =>
           unless (S ⊆ up_set S T) by done; pose proof (subseteq_up_set S T)
        | |- context [ up ?s ?T ] =>
           unless (s ∈ up s T) by done; pose proof (elem_of_up s T)
        end; auto with sts.
Qed.
Canonical Structure stsDR : draT := DraT (car sts) sts_dra_mixin.
End sts_dra.

(** * The STS Resource Algebra *)
(** Finally, the general theory of STS that should be used by users *)
Notation stsC sts := (validityC (stsDR sts)).
Notation stsR sts := (validityR (stsDR sts)).

Section sts_definitions.
  Context {sts : stsT}.
  Definition sts_auth (s : sts.state sts) (T : sts.tokens sts) : stsR sts :=
    to_validity (sts.auth s T).
  Definition sts_frag (S : sts.states sts) (T : sts.tokens sts) : stsR sts :=
    to_validity (sts.frag S T).
  Definition sts_frag_up (s : sts.state sts) (T : sts.tokens sts) : stsR sts :=
    sts_frag (sts.up s T) T.
End sts_definitions.
Instance: Params (@sts_auth) 2.
Instance: Params (@sts_frag) 1.
Instance: Params (@sts_frag_up) 2.

Section stsRA.
Import sts.
Context {sts : stsT}.
Implicit Types s : state sts.
Implicit Types S : states sts.
Implicit Types T : tokens sts.
Arguments dra_valid _ !_/.

(** Setoids *)
Global Instance sts_auth_proper s : Proper ((≡) ==> (≡)) (sts_auth s).
Proof. solve_proper. Qed.
Global Instance sts_frag_proper : Proper ((≡) ==> (≡) ==> (≡)) (@sts_frag sts).
Proof. solve_proper. Qed.
Global Instance sts_frag_up_proper s : Proper ((≡) ==> (≡)) (sts_frag_up s).
Proof. solve_proper. Qed.

(** Validity *)
Lemma sts_auth_valid s T : ✓ sts_auth s T ↔ tok s ## T.
Proof. done. Qed.
Lemma sts_frag_valid S T : ✓ sts_frag S T ↔ closed S T ∧ ∃ s, s ∈ S.
Proof. done. Qed.
Lemma sts_frag_up_valid s T : ✓ sts_frag_up s T ↔ tok s ## T.
Proof.
  split.
  - move=>/sts_frag_valid [H _]. apply H, elem_of_up.
  - intros. apply sts_frag_valid; split. by apply closed_up. set_solver.
Qed.

Lemma sts_auth_frag_valid_inv s S T1 T2 :
  ✓ (sts_auth s T1 ⋅ sts_frag S T2) → s ∈ S.
Proof. by intros (?&?&Hdisj); inversion Hdisj. Qed.

(** Op *)
Lemma sts_op_auth_frag s S T :
  s ∈ S → closed S T → sts_auth s ∅ ⋅ sts_frag S T ≡ sts_auth s T.
Proof.
  intros; split; [split|constructor; set_solver]; simpl.
  - intros (?&?&?); by apply closed_disjoint with S.
  - intros; split_and?; last constructor; set_solver.
Qed.
Lemma sts_op_auth_frag_up s T :
  sts_auth s ∅ ⋅ sts_frag_up s T ≡ sts_auth s T.
Proof.
  intros; split; [split|constructor; set_solver]; simpl.
  - intros (?&[??]&?). by apply closed_disjoint with (up s T), elem_of_up.
  - intros; split_and?.
    + set_solver+.
    + by apply closed_up.
    + exists s. set_solver.
    + constructor; last set_solver. apply elem_of_up.
Qed.

Lemma sts_op_frag S1 S2 T1 T2 :
  T1 ## T2 → sts.closed S1 T1 → sts.closed S2 T2 →
  sts_frag (S1 ∩ S2) (T1 ∪ T2) ≡ sts_frag S1 T1 ⋅ sts_frag S2 T2.
Proof.
  intros HT HS1 HS2. rewrite /sts_frag -to_validity_op //.
  move=>/=[?[? ?]]. split_and!; [set_solver..|constructor; set_solver].
Qed.

(* Notice that the following does *not* hold -- the composition of the
   two closures is weaker than the closure with the itnersected token
   set.  Also see up_op.
Lemma sts_op_frag_up s T1 T2 :
  T1 ## T2 → sts_frag_up s (T1 ∪ T2) ≡ sts_frag_up s T1 ⋅ sts_frag_up s T2.
*)

(** Frame preserving updates *)
Lemma sts_update_auth s1 s2 T1 T2 :
  steps (s1,T1) (s2,T2) → sts_auth s1 T1 ~~> sts_auth s2 T2.
Proof.
  intros ?; apply validity_update.
  inversion 3 as [|? S ? Tf|]; simplify_eq/=; destruct_and?.
  destruct (steps_closed s1 s2 T1 T2 S Tf) as (?&?&?); auto; [].
  repeat (done || constructor).
Qed.

Lemma sts_update_frag S1 S2 T1 T2 :
  (closed S1 T1 → closed S2 T2 ∧ S1 ⊆ S2 ∧ T2 ⊆ T1) → sts_frag S1 T1 ~~> sts_frag S2 T2.
Proof.
  rewrite /sts_frag=> HC HS HT. apply validity_update.
  inversion 3 as [|? S ? Tf|]; simplify_eq/=;
    (destruct HC as (? & ? & ?); first by destruct_and?).
  - split_and!. done. set_solver. constructor; set_solver.
  - split_and!. done. set_solver. constructor; set_solver.
Qed.

Lemma sts_update_frag_up s1 S2 T1 T2 :
  (tok s1 ## T1 → closed S2 T2) → s1 ∈ S2 → T2 ⊆ T1 → sts_frag_up s1 T1 ~~> sts_frag S2 T2.
Proof.
  intros HC ? HT; apply sts_update_frag. intros HC1; split; last split; eauto using closed_steps.
  - eapply HC, HC1, elem_of_up.
  - rewrite <-HT. eapply up_subseteq; last done. apply HC, HC1, elem_of_up.
Qed.

Lemma sts_up_set_intersection S1 Sf Tf :
  closed Sf Tf → S1 ∩ Sf ≡ S1 ∩ up_set (S1 ∩ Sf) Tf.
Proof.
  intros Hclf. apply (anti_symm (⊆)).
  - move=>s [HS1 HSf]. split. by apply HS1. by apply subseteq_up_set.
  - move=>s [HS1 [s' [/elem_of_mkSet Hsup Hs']]]. split; first done.
    eapply closed_steps, Hsup; first done. set_solver +Hs'.
Qed.

Global Instance sts_frag_core_id S : CoreId (sts_frag S ∅).
Proof.
  constructor; split=> //= [[??]]. by rewrite /dra.dra_core /= sts.up_closed.
Qed.

(** Inclusion *)
(* This is surprisingly different from to_validity_included. I am not sure
   whether this is because to_validity_included is non-canonical, or this
   one here is non-canonical - but I suspect both. *)
(* TODO: These have to be proven again. *)
(*
Lemma sts_frag_included S1 S2 T1 T2 :
  closed S2 T2 → S2 ≢ ∅ →
  (sts_frag S1 T1 ≼ sts_frag S2 T2) ↔
  (closed S1 T1 ∧ S1 ≢ ∅ ∧ ∃ Tf, T2 ≡ T1 ∪ Tf ∧ T1 ## Tf ∧
                                 S2 ≡ S1 ∩ up_set S2 Tf).
Proof.
  intros ??; split.
  - intros [[???] ?].
  destruct (to_validity_included (sts_dra.car sts) (sts_dra.frag S1 T1) (sts_dra.frag S2 T2)) as [Hfincl Htoincl].
  intros Hcl2 HS2ne. split.
  - intros Hincl. destruct Hfincl as ((Hcl1 & ?) & (z & EQ & Hval & Hdisj)).
    { split; last done. split; done. }
    clear Htoincl. split_and!; try done; [].
    destruct z as [sf Tf|Sf Tf].
    { exfalso. inversion_clear EQ. }
    exists Tf. inversion_clear EQ as [|? ? ? ? HT2 HS2].
    inversion_clear Hdisj as [? ? ? ? _ HTdisj | |]. split_and!; [done..|].
    rewrite HS2. apply up_set_intersection. apply Hval.
  - intros (Hcl & Hne & (Tf & HT & HTdisj & HS)). destruct Htoincl as ((Hcl' & ?) & (z & EQ)); last first.
    { exists z. exact EQ. } clear Hfincl.
    split; first (split; done). exists (sts_dra.frag (up_set S2 Tf) Tf). split_and!.
    + constructor; done.
    + simpl. split.
      * apply closed_up_set. move=>s Hs2. move:(closed_disjoint _ _ Hcl2 _ Hs2).
        set_solver +HT.
      * by apply up_set_non_empty.
    + constructor; last done. by rewrite -HS.
Qed.

Lemma sts_frag_included' S1 S2 T :
  closed S2 T → closed S1 T → S2 ≢ ∅ → S1 ≢ ∅ → S2 ≡ S1 ∩ up_set S2 ∅ →
  sts_frag S1 T ≼ sts_frag S2 T.
Proof.
  intros. apply sts_frag_included; split_and?; auto.
  exists ∅; split_and?; done || set_solver+.
Qed. *)
End stsRA.

(** STSs without tokens: Some stuff is simpler *)
Module sts_notok.
Structure stsT := Sts {
  state : Type;
  prim_step : relation state;
}.
Arguments Sts {_} _.
Arguments prim_step {_} _ _.
Notation states sts := (set (state sts)).

Definition stsT_token := Empty_set.
Definition stsT_tok {sts : stsT} (_ : state sts) : set stsT_token := ∅.

Canonical Structure sts_notok (sts : stsT) : sts.stsT :=
  sts.Sts (@prim_step sts) stsT_tok.
Coercion sts_notok.sts_notok : sts_notok.stsT >-> sts.stsT.

Section sts.
  Context {sts : stsT}.
  Implicit Types s : state sts.
  Implicit Types S : states sts.

  Notation prim_steps := (rtc prim_step).

  Lemma sts_step s1 s2 : prim_step s1 s2 → sts.step (s1, ∅) (s2, ∅).
  Proof. intros. split; set_solver. Qed.

  Lemma sts_steps s1 s2 : prim_steps s1 s2 → sts.steps (s1, ∅) (s2, ∅).
  Proof. induction 1; eauto using sts_step, rtc_refl, rtc_l. Qed.

  Lemma frame_prim_step T s1 s2 : sts.frame_step T s1 s2 → prim_step s1 s2.
  Proof. inversion 1 as [??? Hstep]. by inversion_clear Hstep. Qed.

  Lemma prim_frame_step T s1 s2 : prim_step s1 s2 → sts.frame_step T s1 s2.
  Proof.
    intros Hstep. apply sts.Frame_step with ∅ ∅; first set_solver.
    by apply sts_step.
  Qed.

  Lemma mk_closed S :
    (∀ s1 s2, s1 ∈ S → prim_step s1 s2 → s2 ∈ S) → sts.closed S ∅.
  Proof. intros ?. constructor; [by set_solver|eauto using frame_prim_step]. Qed.
End sts.
End sts_notok.

Notation sts_notokT := sts_notok.stsT.
Notation Sts_NoTok := sts_notok.Sts.

Section sts_notokRA.
  Context {sts : sts_notokT}.
  Import sts_notok.
  Implicit Types s : state sts.
  Implicit Types S : states sts.

  Lemma sts_notok_update_auth s1 s2 :
    rtc prim_step s1 s2 → sts_auth s1 ∅ ~~> sts_auth s2 ∅.
  Proof. intros. by apply sts_update_auth, sts_steps. Qed.
End sts_notokRA.


From Undecidability.FOL.Syntax Require Import Core Facts.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors.
Require Import Coq.Setoids.Setoid.
Import ListAutomationNotations ListAutomationHints.
Require Import Arith Lia List.

#[global]
Create HintDb contains_theory.

Declare Scope theory.
Open Scope theory.

Section Theory.
  (* **** Theories *)
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.
  Context {ff : falsity_flag}.

  Definition theory := form -> Prop.
  Definition contains phi (T : theory) := T phi.
  Definition contains_L (A : list form) (T : theory) := forall f, f el A -> contains f T.
  Definition subset_T (T1 T2 : theory) := forall (phi : form), contains phi T1 -> contains phi T2.
  Definition list_T A : theory := fun phi => phi el A.

  Infix "⊏" := contains_L (at level 20) : theory.
  Infix "⊑" := subset_T (at level 20) : theory.
  Infix "∈" := contains (at level 70) : theory.

  Hint Unfold contains : contains_theory.
  Hint Unfold contains_L : contains_theory.
  Hint Unfold subset_T : contains_theory.

  Global Instance subset_T_trans : Transitive subset_T.
  Proof.
    auto with contains_theory.
  Qed.

  Definition extend T (phi : form) := fun psi => T psi \/ psi = phi.
  Infix "⋄" := extend (at level 20).

  Definition closed_T (T : theory) := forall phi, contains phi T -> bounded 0 phi.
  Lemma closed_T_extend T phi :
    closed_T T -> closed phi -> closed_T (T ⋄ phi).
  Proof.
    intros ? ? ? [|]; subst; auto with contains_theory.
  Qed.

  Section ContainsAutomation.
    Lemma contains_nil T :
      List.nil ⊏ T.
    Proof. auto with contains_theory. Qed.

    Lemma contains_cons a A T :
      a ∈ T -> A ⊏ T -> (a :: A) ⊏ T.
    Proof. intros ? ? ? []; subst; auto with contains_theory. Qed.

    Lemma contains_cons2 a A T :
      (a :: A) ⊏ T -> A ⊏ T.
    Proof. auto with contains_theory. Qed.

    Lemma contains_app A B T :
      A ⊏ T -> B ⊏ T -> (A ++ B) ⊏ T.
    Proof. intros ? ? ? [] % in_app_or; auto with contains_theory. Qed.

    Lemma contains_extend1 phi T :
      phi ∈ (T ⋄ phi).
    Proof. now right. Qed.

    Lemma contains_extend2 phi psi T :
      phi ∈ T -> phi ∈ (T ⋄ psi).
    Proof. intros ?. now left. Qed.

    Lemma contains_extend3 A T phi :
      A ⊏ T -> A ⊏ (T ⋄ phi).
    Proof.
      intros ? ? ?. left. now apply H.
    Qed.
  End ContainsAutomation.
End Theory.

Section TheoryMap.
  Context {Σ_funcs1 Σ_funcs2 : funcs_signature}.
  Context {Σ_preds1 Σ_preds2 : preds_signature}.
  Context {ops1 ops2 : operators}.
  Context {ff1 ff2 : falsity_flag}.

  Definition tmap (f : @form Σ_funcs1 Σ_preds1 ops1 ff1 -> @form Σ_funcs2 Σ_preds2 ops2 ff2) (T : @theory Σ_funcs1 Σ_preds1 ops1 ff1) : @theory Σ_funcs2 Σ_preds2 ops2 ff2 :=
    fun phi => exists psi, T psi /\ f psi = phi.

  Lemma enum_tmap' (f : @form Σ_funcs1 Σ_preds1 ops1 ff1 -> @form Σ_funcs2 Σ_preds2 ops2 ff2) (T : @theory Σ_funcs1 Σ_preds1 ops1 ff1) L :
    cumulative L -> list_enumerator L T -> cumulative (L >> List.map f) /\ list_enumerator (L >> List.map f) (tmap f T).
  Proof.
    intros H H0. split; unfold ">>".
    - intros n. destruct (H n) as [A ->]. exists (List.map f A). apply map_app.
    - intros x; split.
      + intros (phi & [m Hin] % H0 & <-). exists m. apply in_map_iff. firstorder.
      + intros (m & (phi & <- & Hphi) % in_map_iff). firstorder.
  Qed.

  Lemma enum_tmap (f : @form Σ_funcs1 Σ_preds1 ops1 ff1 -> @form Σ_funcs2 Σ_preds2 ops2 ff2) (T : @theory Σ_funcs1 Σ_preds1 ops1 ff1) :
    enumerable T -> enumerable (tmap f T).
  Proof.
    intros (L & HL).
    exists (fun n => match (L n) with Some k => Some (f k) | None => None end).
    split.
    - intros (y & Hy & <-). destruct (HL y) as [HL1 HL2].
      destruct (HL1 Hy) as [n Hn]. exists n. rewrite Hn. easy.
    - intros (n & Hn). destruct (L n) as [f0|] eqn:Heq; try congruence.
      exists f0. split; try congruence. destruct (HL f0) as [HL1 HL2].
      apply HL2. exists n. easy.
  Qed.

  Lemma tmap_contains_L (f : @form Σ_funcs1 Σ_preds1 ops1 ff1 -> @form Σ_funcs2 Σ_preds2 ops2 ff2) T A :
    contains_L A (tmap f T) -> exists B, A = List.map f B /\ contains_L B T.
  Proof.
    induction A.
    - intros. now exists List.nil.
    - intros H. destruct IHA as (B & -> & HB). 1: firstorder.
      destruct (H a (or_introl eq_refl)) as (b & Hb & <-).
      exists (b :: B). split. 1: auto. intros ? []; subst; auto.
  Qed.

  Lemma tmap_closed (f : @form Σ_funcs1 Σ_preds1 ops1 ff1 -> @form Σ_funcs2 Σ_preds2 ops2 ff2) T :
    (forall x, closed x -> closed (f x)) ->
    closed_T T -> closed_T (tmap f T).
  Proof.
    intros Hf Hclosed ? (y & Hy & <-).
    apply Hf, Hclosed, Hy.
  Qed.

End TheoryMap.
#[global] Hint Constructors sum : contains_theory.
#[global] Hint Constructors prod : contains_theory.

Infix "⊏" := contains_L (at level 20) : theory.
Infix "⊑" := subset_T (at level 20) : theory.
Infix "∈" := contains (at level 70) : theory.
Infix "⋄" := extend (at level 20) : theory.

#[global] Hint Resolve contains_nil contains_cons contains_cons2 contains_app : contains_theory.
#[global] Hint Resolve contains_extend1 contains_extend2 contains_extend3 : contains_theory.
#[global] Ltac use_theory A := exists A; split; [eauto 15 with contains_theory|].


(* Utility *)

From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
From Equations Require Import Equations.
Import List.ListNotations.
Set Primitive Projections.
Open Scope type_scope.

Definition compute_eq {n m : nat} : n = m -> n = m :=
  match Nat.eq_dec n m with
  | left p => fun _ => p
  | right nh => fun h => False_rect _ (nh h)
  end.

Definition compute_neq {n m : nat} : n <> m -> n <> m :=
  match Nat.eq_dec n m with
  | right p => fun _ => p
  | left h => fun nh => False_rect _ (nh h)
  end.

Definition compute_le {n m} : n <= m -> n <= m :=
  match le_dec n m with
  | left p => fun _ => p
  | right nh => fun h => False_rect _ (nh h)
  end.

Definition compute_lt {n m} : n < m -> n < m :=
  match lt_dec n m with
  | left p => fun _ => p
  | right nh => fun h => False_rect _ (nh h)
  end.

Definition compute_ge {n m} : n >= m -> n >= m :=
  match ge_dec n m with
  | left p => fun _ => p
  | right nh => fun h => False_rect _ (nh h)
  end.

Definition compute_gt {n m} : n > m -> n > m :=
  match gt_dec n m with
  | left p => fun _ => p
  | right nh => fun h => False_rect _ (nh h)
  end.

Ltac mylia :=
  match goal with
  | |- @eq nat _ _ => eapply compute_eq ; abstract lia
  | |- _ <= _ => eapply compute_le ; abstract lia
  | |- _ < _ => eapply compute_lt ; abstract lia
  | |- _ >= _ => eapply compute_ge ; abstract lia
  | |- _ > _ => eapply compute_gt ; abstract lia
  | _ => abstract lia
  end.

Record pp_sigT {A : Type} (P : A -> Type) : Type :=
  {
    pi1 : A;
    pi2 : P pi1
  }.

Arguments pi1 {_ _} _.
Arguments pi2 {_ _} _.

(* Preamble *)
Notation "'∑'  x .. y , P" := (pp_sigT (fun x => .. (pp_sigT (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity) : type_scope.

Arguments Build_pp_sigT {_ _} _ _.

Notation "( x ; .. ; y ; z )" :=
  (Build_pp_sigT x (.. (Build_pp_sigT y z) ..)) : type_scope.

Record pp_prod (A B : Type) : Type := mk_pp_prod
  {
    pi1_ : A;
    pi2_ : B
  }.

Arguments mk_pp_prod {_ _} _ _.
Arguments pi1_ {_ _} _.
Arguments pi2_ {_ _} _.

Notation "x * y" := (pp_prod x y) : type_scope.

Definition fst {A B} (p : A * B) := pi1_ p.
Definition snd {A B} (p : A * B) := pi2_ p.

Notation "( x , y , .. , z )" :=
  (mk_pp_prod .. (mk_pp_prod x y) .. z) : type_scope.

Ltac splits n :=
  match n with
  | S ?n => split ; [ splits n |]
  | _ => idtac
  end.

Ltac split_hyp :=
  match goal with
  | H : _ * _ |- _ => destruct H
  end.

Ltac split_hyps :=
  repeat split_hyp.

Ltac splits_one h :=
  match type of h with
  | _ * _ => let h1 := fresh "h" in
            let h2 := fresh "h" in
            destruct h as [h1 h2] ;
            splits_one h1 ;
            splits_one h2
  | _ /\ _ => let h1 := fresh "h" in
            let h2 := fresh "h" in
            destruct h as [h1 h2] ;
            splits_one h1 ;
            splits_one h2
  | _ => idtac
  end.

Ltac bprop' H H' :=
  match type of H with
  | (?n <=? ?m) = true => pose proof (compute_le (leb_complete _ _ H)) as H'
  | (?n <=? ?m) = false => pose proof (compute_lt (leb_complete_conv _ _ H)) as H'
  | (?n <? ?m) = true => pose proof (compute_lt (proj1 (Nat.ltb_lt n m) H)) as H'
  | (?n <? ?m) = false => pose proof (compute_le (proj1 (Nat.ltb_ge n m) H)) as H'
  | (?x ?= ?y) = Gt => pose proof (compute_gt (nat_compare_Gt_gt _ _ H)) as H'
  | (?x ?= ?y) = Eq => pose proof (compute_eq (Nat.compare_eq _ _ H)) as H'
  | (?x ?= ?y) = Lt => pose proof (compute_lt (nat_compare_Lt_lt _ _ H)) as H'
  | (?x =? ?y) = true => pose proof (compute_eq (beq_nat_true x y H)) as H'
  | (?x =? ?y) = false => pose proof (compute_neq (beq_nat_false x y H)) as H'
  end.

(* Doesn't work. :( *)
Tactic Notation "brop" constr(H) "as" constr(H') := bprop' H H'.

Tactic Notation "bprop" constr(H) := let H' := fresh H in bprop' H  H'.

Definition compute_leb_true {n m} : n <=? m = true -> n <=? m = true :=
  match n <=? m with
  | true => fun _ => eq_refl
  | false => fun h => h
  end.

Definition compute_leb_false {n m} : n <=? m = false -> n <=? m = false :=
  match n <=? m with
  | false => fun _ => eq_refl
  | true => fun h => h
  end.

Definition compute_ltb_true {n m} : n <? m = true -> n <? m = true :=
  match n <? m with
  | true => fun _ => eq_refl
  | false => fun h => h
  end.

Definition compute_ltb_false {n m} : n <? m = false -> n <? m = false :=
  match n <? m with
  | false => fun _ => eq_refl
  | true => fun h => h
  end.

Definition compute_eqb_true {n m} : n =? m = true -> n =? m = true :=
  match n =? m with
  | true => fun _ => eq_refl
  | false => fun h => h
  end.

Definition compute_eqb_false {n m} : n =? m = false -> n =? m = false :=
  match n =? m with
  | false => fun _ => eq_refl
  | true => fun h => h
  end.

Definition compute_compare_Lt {n m} : n ?= m = Lt -> n ?= m = Lt :=
  match n ?= m with
  | Lt => fun _ => eq_refl
  | Eq => fun h => h
  | Gt => fun h => h
  end.

Definition compute_compare_Eq {n m} : n ?= m = Eq -> n ?= m = Eq :=
  match n ?= m with
  | Eq => fun _ => eq_refl
  | Lt => fun h => h
  | Gt => fun h => h
  end.

Definition compute_compare_Gt {n m} : n ?= m = Gt -> n ?= m = Gt :=
  match n ?= m with
  | Gt => fun _ => eq_refl
  | Lt => fun h => h
  | Eq => fun h => h
  end.

Ltac propb :=
  match goal with
  | |- (_ <=? _) = true => apply compute_leb_true ; apply leb_correct
  | |- (_ <=? _) = false => apply compute_leb_false ; apply leb_correct_conv
  | |- (_ <? _) = true => apply compute_ltb_true ; apply Nat.ltb_lt
  | |- (_ <? _) = false => apply compute_ltb_false ; apply Nat.ltb_ge
  | |- (_ ?= _) = Lt => apply compute_compare_Lt ; apply Nat.compare_lt_iff
  | |- (_ ?= _) = Eq => apply compute_compare_Eq ; apply Nat.compare_eq_iff
  | |- (_ ?= _) = Gt => apply compute_compare_Gt ; apply Nat.compare_gt_iff
  | |- (_ =? _) = true => apply compute_eqb_true ; apply Nat.eqb_eq
  | |- (_ =? _) = false => apply compute_eqb_false ; apply beq_nat_false
  end.

(* Replace the opaque version *)
Fact andb_prop : forall a b, a && b = true -> a = true /\ b = true.
Proof.
  intros [] [] h.
  all: simpl in h.
  all: split ; (reflexivity + assumption).
Defined.

Ltac destruct_andb :=
  match goal with
  | H : _ && _ = true |- _ =>
    destruct (andb_prop _ _ H) ; clear H
  end.

Ltac rewrite_assumption :=
  match goal with
  | H : _, e : _ = _ |- _ => rewrite H
  | H : _ = _ |- _ => rewrite H
  end.

Ltac rewrite_assumptions :=
  repeat rewrite_assumption.

Ltac erewrite_assumption :=
  match goal with
  | H : _, e : _ = _ |- _ => erewrite H
  | H : _ = _ |- _ => erewrite H
  end.

Ltac erewrite_assumptions :=
  erewrite_assumption ; [ try erewrite_assumptions | .. ].

Tactic Notation "erewrite_assumption" "by" tactic(tac) :=
  match goal with
  | H : _, e : _ = _ |- _ => erewrite H by tac
  end.

Ltac ncase exp :=
  let e := fresh "e" in
  case_eq exp ; intro e ; bprop e ; try mylia.

Ltac nat_case :=
  match goal with
  | |- context [ ?n <=? ?m ] => ncase (n <=? m)
  | |- context [ ?n <? ?m ] => ncase (n <? m)
  | |- context [ ?n =? ?m ] => ncase (n =? m)
  | |- context [ ?n ?= ?m ] => ncase (n ?= m)
  end.

Tactic Notation "hyp" "rewrite" :=
  match goal with
  | H : _ |- _ => rewrite H by mylia
  end.

Definition rev {A} (l : list A) : list A :=
  let fix aux (l : list A) (acc : list A) : list A :=
    match l with
    | [] => acc
    | x :: l => aux l (x :: acc)
    end
  in aux l [].

Definition rev_map {A B} (f : A -> B) (l : list A) : list B :=
  let fix aux (l : list A) (acc : list B) : list B :=
    match l with
    | [] => acc
    | x :: l => aux l (f x :: acc)
    end
  in aux l [].

Notation "#| Γ |" := (List.length Γ) (at level 0, Γ at level 99, format "#| Γ |").

Fact skipn_all :
  forall {A} {l : list A},
    skipn #|l| l = [].
Proof.
  intros A l. induction l.
  - cbn. reflexivity.
  - cbn. assumption.
Defined.

Fact skipn_length :
  forall {A} {l : list A} {n},
    #|skipn n l| = #|l| - n.
Proof.
  intros A. induction l ; intro n.
  - cbn. destruct n ; reflexivity.
  - destruct n.
    + cbn. reflexivity.
    + cbn. apply IHl.
Defined.

Fact skipn_reconstruct :
  forall {A} {l : list A} {n a},
    nth_error l n = Some a ->
    skipn n l = a :: skipn (S n) l.
Proof.
  intros A l.
  induction l ; intros n x hn.
  - destruct n ; cbn in hn ; inversion hn.
  - cbn. destruct n.
    + cbn. cbn in hn. inversion hn. reflexivity.
    + apply IHl. now inversion hn.
Defined.

Fact firstn_reconstruct :
  forall {A} {l : list A} {n a},
    nth_error l n = Some a ->
    firstn (S n) l = (firstn n l ++ [a])%list.
Proof.
  intros A l.
  induction l ; intros n x hn.
  - destruct n ; cbn in hn ; inversion hn.
  - cbn. destruct n.
    + cbn. cbn in hn. inversion hn. reflexivity.
    + inversion hn as [e].
      erewrite IHl by exact e. cbn. reflexivity.
Defined.

Definition lastn n {A} (l : list A) :=
  skipn (#|l| - n) l.

Fact lastn_O :
  forall {A} {l : list A}, lastn 0 l = [].
Proof.
  intros A l. unfold lastn.
  replace (#|l| - 0) with #|l| by mylia.
  apply skipn_all.
Defined.

Fact lastn_all :
  forall {A} {l : list A},
    lastn #|l| l = l.
Proof.
  intros A l. unfold lastn.
  replace (#|l| - #|l|) with 0 by mylia.
  reflexivity.
Defined.

Fact lastn_all2 :
  forall {A} {n} {l : list A},
    #|l| <= n ->
    lastn n l = l.
Proof.
  intros A n l h.
  unfold lastn.
  replace (#|l| - n) with 0 by mylia.
  reflexivity.
Defined.

Fact lastn_reconstruct :
  forall {A} {l : list A} {n a},
    nth_error l (#|l| - S n) = Some a ->
    n < #|l| ->
    lastn (S n) l = a :: lastn n l.
Proof.
  intros A l n a hn h.
  unfold lastn.
  erewrite skipn_reconstruct.
  - f_equal. f_equal. mylia.
  - assumption.
Defined.

Fact map_firstn :
  forall {A} {l1 l2 : list A} {B} {f : A -> B} {n},
    map f l1 = map f l2 ->
    map f (firstn n l1) = map f (firstn n l2).
Proof.
  intros A l1 l2 B f n h. revert l2 n h.
  induction l1 ; intros l2 n h ; destruct l2 ; cbn in h ; try discriminate h.
  - reflexivity.
  - destruct n.
    + cbn. reflexivity.
    + inversion h.
      cbn. f_equal ; try assumption.
      apply IHl1. assumption.
Defined.

Fact map_skipn :
  forall {A} {l1 l2 : list A} {B} {f : A -> B} {n},
    map f l1 = map f l2 ->
    map f (skipn n l1) = map f (skipn n l2).
Proof.
  intros A l1 l2 B f n h. revert l2 n h.
  induction l1 ; intros l2 n h ; destruct l2 ; cbn in h ; try discriminate h.
  - reflexivity.
  - inversion h.
    destruct n.
    + cbn. f_equal ; assumption.
    + cbn. eapply IHl1. assumption.
Defined.

Definition dec (A : Type) := A + { A -> False }.

(* Associative table indexed by strings *)
Inductive assoc (A : Type) :=
| empty
| acons (key : string) (data : A) (t : assoc A).

Arguments empty {_}.
Arguments acons {_} _ _.

Fixpoint assoc_at {A} (key : string) (t : assoc A) {struct t} : option A :=
  match t with
  | empty => None
  | acons k a r => if string_dec key k then Some a else assoc_at key r
  end.

Definition ident := string.

Inductive name : Set :=
| nAnon
| nNamed (_ : ident).

Definition ident_eq (x y : ident) :=
  match string_dec x y with
  | left _ => true
  | right _ => false
  end.

Lemma nth_error_isdecl {A} {l : list A} {n c} :
  forall e : nth_error l n = Some c, n < #|l|.
Proof.
  revert l. induction n.
  destruct l; cbn. discriminate. intro; lia.
  destruct l; cbn. discriminate. intro H; apply IHn in H; lia.
Defined.

Lemma nth_error_Some_length :
  forall A (l : list A) n x,
    nth_error l n = Some x ->
    n < #|l|.
Proof.
  intros A l n x e.
  apply nth_error_Some.
  rewrite e. discriminate.
Qed.

Ltac easy := Coq.Init.Tactics.easy || solve [eauto 4 with core arith].
Tactic Notation "now" tactic(t) := t; easy.