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

Require Import Orders.
Require Import MSetFacts.
Require Import MSetProperties.
Require Import FMapInterface.

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrfun.
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.

Set Implicit Arguments.

Module Type CommutativeFinGroup.
  Parameter gT : commFinGroupType.
End CommutativeFinGroup.

Module CFGAACInstances (Import CFG : CommutativeFinGroup).
  Import GroupScope.

  Instance aac_mulg_Assoc : Associative eq (@mulg gT) := @mulgA gT.

  Instance aac_mulg_Comm : Commutative eq (@mulg gT) := @mulgC gT.

  Instance aac_mulg_unit : Unit eq (@mulg gT) 1 :=
    {
      law_neutral_left := @mul1g gT;
      law_neutral_right := @mulg1 gT
    }.
End CFGAACInstances.

Module Type ADefs (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 GroupScope.

Definition m := gT.

Parameter m_eq_dec : forall (a b : m), {a = b} + {a <> b}.

Definition NS := NSet.t.
Definition NM := NMap.t m.

Definition init_map_t (fins : NS) : Type :=
  { map : NM | forall n, NSet.In n fins <-> NMap.find n map = Some 1 }.

Parameter init_map_str : forall (fins : NS), init_map_t fins.

Definition init_map (fins : NS) : NM :=
match init_map_str fins with
| exist map _ => map
end.

Definition sum_fold (fm : NM) (n : name) (partial : m) : m :=
match NMap.find n fm with
| Some m' => partial * m'
| None => partial
end.

Definition sumM (fs : NS) (fm : NM) : m :=
NSet.fold (sum_fold fm) fs 1.

Definition sum_active_fold (adj : NS) (map : NM) (n : name) (partial : m) : m :=
if NSet.mem n adj
then sum_fold map n partial
else partial.

Definition sumM_active (adj : NS) (map : NM) (ns : list name) : m :=
fold_right (sum_active_fold adj map) 1 ns.

Parameter fold_left_right : forall (fm : NM) (l : list name),
  fold_left (fun partial n => (sum_fold fm) n partial) l 1 = fold_right (sum_fold fm) 1 l.

Parameter sumM_fold_right : forall (fs : NS) (fm : NM),
  NSet.fold (sum_fold fm) fs 1 = fold_right (sum_fold fm) 1 (NSet.elements fs).

Parameter not_in_add_eq : forall (l : list name) (n : name) (fm : NM) (m5 : m),
  ~ InA eq n l -> fold_right (sum_fold (NMap.add n m5 fm)) 1 l = fold_right (sum_fold fm) 1 l.

Parameter sumM_add_map : forall (n : name) (fs : NS) (fm : NM) (m5 m' : m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM fs (NMap.add n (m5 * m') fm) = sumM fs fm * m'.

Parameter eqlistA_eq : forall (l l' : list name), eqlistA eq l l' -> l = l'.

Parameter sumM_remove : forall (fs : NS) (n : name) (fm : NM) (m5: m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.remove n fs) fm = sumM fs fm * m5^-1.

Parameter sumM_notins_remove_map : forall (fs : NS) (n : name) (fm : NM),
  ~ NSet.In n fs ->
  sumM fs (NMap.remove n fm) = sumM fs fm.

Parameter sumM_remove_remove : forall (fs : NS) (n : name) (fm : NM) (m5: m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.remove n fs) (NMap.remove n fm) = sumM fs fm * m5^-1.

Parameter sumM_empty : forall (fs : NS) (fm : NM), NSet.Empty fs -> sumM fs fm = 1.

Parameter sumM_eq : forall (fs : NS) (fm' : NS) (fm : NM), NSet.Equal fs fm' -> sumM fs fm = sumM fm' fm.

Parameter sumM_add : forall (fs : NS) (fm : NM) (m5 : m) (n : name),
  ~ NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.add n fs) fm = sumM fs fm * m5.

Parameter sumM_add_add : forall (fs : NS) (M5 : NM) (m5 : m) (n : name),
  ~ NSet.In n fs ->
  sumM (NSet.add n fs) (NMap.add n m5 M5) = sumM fs M5 * m5.

Parameter sumM_init_map_1 : forall fm, sumM fm (init_map fm) = 1.

Parameter sumM_active_remove_eq :
  forall ns n adj map,
  ~ In n ns ->
  sumM_active adj map ns = sumM_active (NSet.remove n adj) map ns.

Parameter sumM_active_app_distr :
  forall ns0 ns1 adj map,
    sumM_active adj map (ns0 ++ ns1) = sumM_active adj map ns0 * sumM_active adj map ns1.

Parameter sumM_active_eq_sym :
  forall ns ns' adj map,
  Permutation ns ns' ->
  sumM_active adj map ns = sumM_active adj map ns'.

Class AggregationData (data : Type) :=
  {
    aggr_local : data -> m ;
    aggr_aggregate : data -> m ;
    aggr_adjacent : data -> NS ;
    aggr_balance : data -> NM
  }.

Section AggregationData.

Context {data} {ad : AggregationData data}.

Definition conserves_node_mass (d : data) : Prop :=
d.(aggr_local) = d.(aggr_aggregate) * sumM d.(aggr_adjacent) d.(aggr_balance).

Definition sum_local (l : list data) : m :=
fold_right (fun (d : data) (partial : m) => partial * d.(aggr_local)) 1 l.

Definition sum_aggregate (l : list data) : m :=
fold_right (fun (d : data) (partial : m) => partial * d.(aggr_aggregate)) 1 l.

Definition sum_balance (l : list data) : m :=
fold_right (fun (d : data) (partial : m) => partial * sumM d.(aggr_adjacent) d.(aggr_balance)) 1 l.

Definition conserves_mass_globally (l : list data) : Prop :=
sum_local l = sum_aggregate l * sum_balance l.

Definition conserves_node_mass_all (l : list data) : Prop :=
forall d, In d l -> conserves_node_mass d.

Definition Nodes_data (ns : list name) (state : name -> data) : list data :=
fold_right (fun (n : name) (l' : list data) => n.(state) :: l') [] ns.

Definition Nodes_data_opt (ns : list name) (state : name -> option data) : list data :=
fold_right (fun (n : name) (l' : list data) =>
              match state n with
              | Some d => d :: l'
              | None => l'
              end) [] ns.

Parameter global_conservation :
  forall (l : list data),
    conserves_node_mass_all l ->
    conserves_mass_globally l.

Parameter sum_local_split :
  forall ns0 ns1 state n,
    sum_local (Nodes_data (ns0 ++ n :: ns1) state) =
    n.(state).(aggr_local) * sum_local (Nodes_data (ns0 ++ ns1) state).

Parameter sum_local_opt_app :
  forall ns0 ns1 state n d,
    state n = Some d ->
    sum_local (Nodes_data_opt (ns0 ++ n :: ns1) state) =
    d.(aggr_local) * sum_local (Nodes_data_opt (ns0 ++ ns1) state).

Parameter sum_aggregate_split :
  forall ns0 ns1 state n,
    sum_aggregate (Nodes_data (ns0 ++ n :: ns1) state) =
    n.(state).(aggr_aggregate) * sum_aggregate (Nodes_data (ns0 ++ ns1) state).

Parameter sum_aggregate_opt_app :
  forall ns0 ns1 state n d,
    state n = Some d ->
    sum_aggregate (Nodes_data_opt (ns0 ++ n :: ns1) state) =
    d.(aggr_aggregate) * sum_aggregate (Nodes_data_opt (ns0 ++ ns1) state).

Parameter Nodes_data_not_in :
forall n' d state ns,
~ In n' ns ->
fold_right
  (fun (n : name) (l : list data) =>
     (match name_eq_dec n n' with
      | left _ => d
      | right _ => n.(state)
      end) :: l) [] ns = Nodes_data ns state.

Parameter Nodes_data_split :
  forall ns0 ns1 (state : name -> data),
    Nodes_data (ns0 ++ ns1) state =
    Nodes_data ns0 state ++ Nodes_data ns1 state.

Parameter Nodes_data_opt_split :
  forall ns0 ns1 (state : name -> option data),
    Nodes_data_opt (ns0 ++ ns1) state =
    Nodes_data_opt ns0 state ++ Nodes_data_opt ns1 state.

Parameter sum_balance_distr :
  forall dl dl',
    sum_balance (dl ++ dl') = sum_balance dl * sum_balance dl'.

Parameter sum_balance_Nodes_data_distr :
  forall ns0 ns1 state,
    sum_balance (Nodes_data ns0 state) * sum_balance (Nodes_data ns1 state) =
    sum_balance (Nodes_data (ns0 ++ ns1) state).

Parameter sum_balance_Nodes_data_opt_distr :
  forall ns0 ns1 state,
    sum_balance (Nodes_data_opt ns0 state) * sum_balance (Nodes_data_opt ns1 state) =
    sum_balance (Nodes_data_opt (ns0 ++ ns1) state).

End AggregationData.

Class AggregationMsg :=
  {
    aggr_msg : Type ;
    aggr_msg_eq_dec : forall x y : aggr_msg, {x = y} + {x <> y} ;
    aggr_fail : aggr_msg ;
    aggr_of : aggr_msg -> m ;
  }.

Section AggregationMsg.

Context {am : AggregationMsg}.

Context {data} {ad : AggregationData data}.

Definition aggregate_sum_fold (mg : aggr_msg) (partial : m) : m :=
partial * aggr_of mg.

Definition sum_aggregate_msg := fold_right aggregate_sum_fold 1.

(* given n, sum aggregate messages for all its incoming channels *)
Definition sum_aggregate_msg_incoming (ns : list name) (packets : name -> name -> list aggr_msg) (n : name) : m :=
fold_right (fun (n' : name) (partial : m) =>
  partial * if In_dec aggr_msg_eq_dec aggr_fail (packets n' n) then 1 else sum_aggregate_msg (packets n' n)) 1 ns.

(* given list of active names and all names, sum all incoming channels for all active *)
Definition sum_aggregate_msg_incoming_active (allns : list name) (actns : list name)  (packets : name -> name -> list aggr_msg) : m :=
fold_right (fun (n : name) (partial : m) => partial * sum_aggregate_msg_incoming allns packets n) 1 actns.

Definition sum_fail_map (l : list aggr_msg) (from : name) (adj : NS) (map : NM) : m :=
if In_dec aggr_msg_eq_dec aggr_fail l && NSet.mem from adj then sum_fold map from 1 else 1.

Definition sum_fail_map_incoming (ns : list name) (packets : name -> name -> list aggr_msg) (n : name) (adj : NS) (map : NM) : m :=
fold_right (fun (n' : name) (partial : m) => partial * sum_fail_map (packets n' n) n' adj map) 1 ns.

Definition sum_fail_balance_incoming_active (allns : list name) (actns : list name) (packets : name -> name -> list aggr_msg) (state : name -> data) : m :=
fold_right (fun (n : name) (partial : m) =>
  partial * sum_fail_map_incoming allns packets n n.(state).(aggr_adjacent) n.(state).(aggr_balance)) 1 actns.

Definition sum_fail_balance_incoming_active_opt (allns : list name) (actns : list name) (packets : name -> name -> list aggr_msg) (state : name -> option data) : m :=
fold_right (fun (n : name) (partial : m) =>
              match state n with
              | Some d => partial * sum_fail_map_incoming allns packets n d.(aggr_adjacent) d.(aggr_balance)
              | None => partial
              end) 1 actns.

Definition conserves_network_mass (actns : list name) (allns : list name) (packets : name -> name -> list aggr_msg) (state : name -> data) : Prop :=
sum_local (Nodes_data actns state) =
  sum_aggregate (Nodes_data actns state) *
  sum_aggregate_msg_incoming_active allns actns packets *
  sum_fail_balance_incoming_active allns actns packets state.

Definition conserves_network_mass_opt (actns : list name) (allns : list name) (packets : name -> name -> list aggr_msg) (state : name -> option data) : Prop :=
sum_local (Nodes_data_opt actns state) =
  sum_aggregate (Nodes_data_opt actns state) *
  sum_aggregate_msg_incoming_active allns actns packets *
  sum_fail_balance_incoming_active_opt allns actns packets state.

End AggregationMsg.

Class AggregationMsgMap (P1 : AggregationMsg) (P2 : AggregationMsg) :=
  {
    map_msgs : list (@aggr_msg P1) -> list (@aggr_msg P2) ;
    sum_aggregate_msg_map_msgs_eq : forall ms, sum_aggregate_msg ms = sum_aggregate_msg (map_msgs ms) ;
    aggr_fail_in_in : forall ms, In aggr_fail ms <-> In aggr_fail (map_msgs ms)
  }.

Section AggregationMsgMap.

Context {data_fst} {ad_fst : AggregationData data_fst}.
Context {data_snd} {ad_snd : AggregationData data_snd}.

Parameter sum_local_aggr_local_eq :
  forall (state : name -> data_fst) (state' : name -> data_snd) ns,
   (forall n, In n ns -> n.(state).(aggr_local) = n.(state').(aggr_local)) ->
    sum_local (Nodes_data ns state) = sum_local (Nodes_data ns state').

Parameter sum_local_opt_aggr_local_eq :
  forall (state : name -> option data_fst) (state' : name -> option data_snd) ns,
   (forall n, In n ns -> state n = None <-> state' n = None) ->
   (forall n, In n ns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_local) = d1.(aggr_local)) ->
    sum_local (Nodes_data_opt ns state) = sum_local (Nodes_data_opt ns state').

Parameter sum_aggregate_aggr_aggregate_eq :
  forall (state : name -> data_fst) (state' : name -> data_snd) ns,
   (forall n, In n ns -> n.(state).(aggr_aggregate) = n.(state').(aggr_aggregate)) ->
    sum_aggregate (Nodes_data ns state) = sum_aggregate (Nodes_data ns state').

Parameter sum_aggregate_opt_aggr_aggregate_eq :
  forall (state : name -> option data_fst) (state' : name -> option data_snd) ns,
    (forall n, In n ns -> state n = None <-> state' n = None) ->
   (forall n, In n ns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_aggregate) = d1.(aggr_aggregate)) ->
    sum_aggregate (Nodes_data_opt ns state) = sum_aggregate (Nodes_data_opt ns state').

Context {am_fst : AggregationMsg}.
Context {am_snd : AggregationMsg}.
Context {amm : AggregationMsgMap am_fst am_snd}.

Parameter sum_aggregate_msg_incoming_map_msgs_eq :
  forall (ns : list name) (packets : name -> name -> list (@aggr_msg am_fst)) (n : name),
  sum_aggregate_msg_incoming ns packets n = sum_aggregate_msg_incoming ns (fun src dst => map_msgs (packets src dst)) n.

Parameter sum_aggregate_msg_incoming_active_map_msgs_eq :
  forall (actns allns : list name) (packets : name -> name -> list (@aggr_msg am_fst)),
  sum_aggregate_msg_incoming_active allns actns packets = sum_aggregate_msg_incoming_active allns actns (fun src dst => map_msgs (packets src dst)).

Parameter sum_fail_map_map_msgs_eq :
  forall (packets : name -> name -> list (@aggr_msg am_fst)) src dst from adj map,
    sum_fail_map (packets src dst) from adj map = sum_fail_map (map_msgs (packets src dst)) from adj map.

Parameter sum_fail_map_incoming_map_msgs_eq :
  forall ns (packets : name -> name -> list (@aggr_msg am_fst)) n adj map,
     sum_fail_map_incoming ns packets n adj map = sum_fail_map_incoming ns (fun src dst => map_msgs (packets src dst)) n adj map.

(* FIXME: equivalence for balance instead of Leibniz equality *)
Parameter sum_fail_balance_incoming_active_map_msgs_eq :
  forall (state : name -> data_fst) (state' : name -> data_snd) (packets : name -> name -> list (@aggr_msg am_fst)) allns actns,
    (forall n, In n actns -> n.(state).(aggr_adjacent) = n.(state').(aggr_adjacent)) ->
    (forall n, In n actns -> n.(state).(aggr_balance) = n.(state').(aggr_balance)) ->
    sum_fail_balance_incoming_active allns actns packets state =
    sum_fail_balance_incoming_active allns actns (fun src dst => map_msgs (packets src dst)) state'.

Parameter sum_fail_balance_incoming_active_opt_map_msgs_eq :
  forall (state : name -> option data_fst) (state' : name -> option data_snd) (packets : name -> name -> list (@aggr_msg am_fst)) allns actns,
    (forall n, In n actns -> state n = None <-> state' n = None) ->
    (forall n, In n actns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_adjacent) = d1.(aggr_adjacent)) ->
    (forall n, In n actns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_balance) = d1.(aggr_balance)) ->
    sum_fail_balance_incoming_active_opt allns actns packets state =
    sum_fail_balance_incoming_active_opt allns actns (fun src dst => map_msgs (packets src dst)) state'.

End AggregationMsgMap.

End ADefs.

Module NameTypeADefs (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) <:
 ADefs NT NOT NSet NOTC NMap CFG.

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.

Definition m := gT.

Definition m_eq_dec : forall (a b : m), {a = b} + {a <> b}.
move => a b.
case H_dec: (a == b); move: H_dec; first by case/eqP; left.
move => H_eq; right.
case/eqP => H_neq.
by rewrite H_eq in H_neq.
Defined.

Definition NS := NSet.t.
Definition NM := NMap.t m.

Definition fins_lt (fins fins' : NS) : Prop :=
NSet.cardinal fins < NSet.cardinal fins'.

Lemma fins_lt_well_founded : well_founded fins_lt.
Proof.
apply (well_founded_lt_compat _ (fun fins => NSet.cardinal fins)).
by move => x y; rewrite /fins_lt => H.
Qed.

Definition init_map_t (fins : NS) : Type :=
{ map : NM | forall n, NSet.In n fins <-> NMap.find n map = Some 1 }.

Definition init_map_F : forall fins : NS,
  (forall fins' : NS, fins_lt fins' fins -> init_map_t fins') ->
  init_map_t fins.
rewrite /init_map_t.
refine
  (fun (fins : NS) init_map_rec =>
   match NSet.choose fins as finsopt return (_ = finsopt -> _) with
   | None => fun (H_eq : _) => exist _ (NMap.empty m) _
   | Some n => fun (H_eq : _) =>
     match init_map_rec (NSet.remove n fins) _ with
     | exist fins' H_fins' => exist _ (NMap.add n 1 fins') _
     end
   end (refl_equal _)).
- rewrite /fins_lt /=.
  apply NSet.choose_spec1 in H_eq.
  set fn := NSet.remove _ _.
  have H_notin: ~ NSet.In n fn by move => H_in; apply NSetFacts.remove_1 in H_in.
  have H_add: NSetProps.Add n fn fins.
    rewrite /NSetProps.Add.
    move => k.
    split => H_in.
      case (name_eq_dec n k) => H_eq'; first by left.
      by right; apply NSetFacts.remove_2.
    case: H_in => H_in; first by rewrite -H_in.
    by apply NSetFacts.remove_3 in H_in.
  have H_card := NSetProps.cardinal_2 H_notin H_add.
  rewrite H_card {H_notin H_add H_card}.
  by auto with arith.
- move => n'.
  apply NSet.choose_spec1 in H_eq.
  case (name_eq_dec n n') => H_eq_n.
    rewrite -H_eq_n.
    split => //.
    move => H_ins.
    apply NMapFacts.find_mapsto_iff.
    exact: NMap.add_1.
  split => H_fins.
    apply NMapFacts.find_mapsto_iff.
    apply NMapFacts.add_neq_mapsto_iff => //.
    apply NMapFacts.find_mapsto_iff.
    apply H_fins'.
    exact: NSetFacts.remove_2.
  apply NMapFacts.find_mapsto_iff in H_fins.
  apply NMapFacts.add_neq_mapsto_iff in H_fins => //.
  apply NMapFacts.find_mapsto_iff in H_fins.
  apply H_fins' in H_fins.
  by apply NSetFacts.remove_3 in H_fins.
- move => n.
  apply NSet.choose_spec2 in H_eq.
  split => H_fin; first by contradict H_fin; auto with set.
  apply NMap.find_2 in H_fin.
  contradict H_fin.
  exact: NMap.empty_1.
Defined.

Definition init_map_str : forall (fins : NS), init_map_t fins :=
  @well_founded_induction_type
  NSet.t
  fins_lt
  fins_lt_well_founded
  init_map_t
  init_map_F.

Definition init_map (fins : NS) : NM :=
match init_map_str fins with
| exist map _ => map
end.

Definition sum_fold (fm : NM) (n : name) (partial : m) : m :=
match NMap.find n fm with
| Some m' => partial * m'
| None => partial
end.

Definition sumM (fs : NS) (fm : NM) : m :=
NSet.fold (sum_fold fm) fs 1.

Definition sum_active_fold (adj : NS) (map : NM) (n : name) (partial : m) : m :=
if NSet.mem n adj
then sum_fold map n partial
else partial.

Definition sumM_active (adj : NS) (map : NM) (ns : list name) : m :=
fold_right (sum_active_fold adj map) 1 ns.

Lemma fold_left_right : forall (fm : NM) (l : list name),
  fold_left (fun partial n => (sum_fold fm) n partial) l 1 = fold_right (sum_fold fm) 1 l.
Proof.
move => fm; elim => [|a l IH] //.
rewrite /= -IH /sum_fold {IH}.
case (NMap.find _ _) => [m6|] // {a}; gsimpl.
move: m6; elim: l => [m6|a l IH m6] => /=; first by gsimpl.
case (NMap.find _ _) => [m7|] //.
rewrite mulgC IH; gsimpl.
by rewrite -IH.
Qed.

Corollary sumM_fold_right : forall (fs : NS) (fm : NM),
  NSet.fold (sum_fold fm) fs 1 = fold_right (sum_fold fm) 1 (NSet.elements fs).
Proof. by move => fs fm; rewrite NSet.fold_spec fold_left_right. Qed.

Lemma not_in_add_eq : forall (l : list name) (n : name) (fm : NM) (m5 : m),
  ~ InA eq n l ->
  fold_right (sum_fold (NMap.add n m5 fm)) 1 l = fold_right (sum_fold fm) 1 l.
move => l n fm m5; elim: l => //.
move => a l IH H_in.
have H_in': ~ InA eq n l by move => H_neg; apply: H_in; apply InA_cons; right.
apply IH in H_in'.
rewrite /= H_in' /= /sum_fold.
have H_neq: n <> a by move => H_eq; apply: H_in; apply InA_cons; left.
case H_find: (NMap.find _ _) => [m6|].
  apply NMapFacts.find_mapsto_iff in H_find.
  apply NMapFacts.add_neq_mapsto_iff in H_find => //.
  apply NMapFacts.find_mapsto_iff in H_find.
  case H_find': (NMap.find _ _) => [m7|]; last by rewrite H_find' in H_find.
  rewrite H_find in H_find'.
  injection H_find' => H_eq.
  by rewrite H_eq.
case H_find': (NMap.find _ _) => [m6|] => //.
apply NMapFacts.find_mapsto_iff in H_find'.
apply (NMapFacts.add_neq_mapsto_iff _ m5 _ H_neq) in H_find'.
apply NMapFacts.find_mapsto_iff in H_find'.
by rewrite H_find in H_find'.
Qed.

Lemma sumM_add_map : forall (n : name) (fs : NS) (fm : NM) (m5 m' : m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM fs (NMap.add n (m5 * m') fm) = sumM fs fm * m'.
Proof.
move => n fs fm m5 m' H_in H_find.
have H_in_el: InA eq n (NSet.elements fs) by apply NSetFacts.elements_1.
have H_nodup := NSet.elements_spec2w fs.
move: H_in_el H_nodup {H_in}.
rewrite 2!/sumM 2!sumM_fold_right.
elim (NSet.elements fs) => [|a l IH] H_in H_nodup; first by apply InA_nil in H_in.
case (name_eq_dec n a) => H_dec.
  rewrite H_dec in H_find.
  rewrite H_dec /sum_fold /=.
  have H_find_eq := @NMapFacts.add_eq_o m fm a a (m5 * m') (refl_equal a).
  case H_find': (NMap.find _ _) => [m6|]; last by rewrite H_find_eq in H_find'.
  rewrite H_find_eq in H_find'.
  injection H_find' => H_eq.
  rewrite -H_eq.
  case H_find'': (NMap.find _ _) => [m7|]; last by rewrite H_find in H_find''.
  rewrite H_find'' in H_find.
  injection H_find => H_eq'.
  rewrite H_eq'; gsimpl.
  inversion H_nodup; subst.
  by rewrite not_in_add_eq.
apply InA_cons in H_in.
case: H_in => H_in //.
have H_nodup': NoDupA eq l by inversion H_nodup.
rewrite /= (IH H_in H_nodup') /sum_fold.
case H_find': (NMap.find _ _) => [m6|].
  apply NMapFacts.find_mapsto_iff in H_find'.
  apply NMapFacts.add_neq_mapsto_iff in H_find' => //.
  apply NMapFacts.find_mapsto_iff in H_find'.
  case H_find'': (NMap.find _ _) => [m7|]; last by rewrite H_find'' in H_find'.
  rewrite H_find' in H_find''.
  injection H_find'' => H_eq.
  rewrite H_eq.
  set fr := fold_right _ _ _.
  by aac_reflexivity.
case H_find'': (NMap.find _ _) => [m7|] //.
apply NMapFacts.find_mapsto_iff in H_find''.
apply (NMapFacts.add_neq_mapsto_iff _ (m5 * m') _ H_dec) in H_find''.
apply NMapFacts.find_mapsto_iff in H_find''.
by rewrite H_find' in H_find''.
Qed.

Lemma eqlistA_eq : forall (l l' : list name), eqlistA eq l l' -> l = l'.
Proof.
elim; first by move => l' H_eql; inversion H_eql.
move => a l IH.
case => [|a' l'] H; first by inversion H.
inversion H; subst.
by rewrite (IH l').
Qed.

Lemma sumM_remove : forall (fs : NS) (n : name) (fm : NM) (m5: m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.remove n fs) fm = sumM fs fm * m5^-1.
Proof.
move => I_ind.
pose P_ind (fs : NS) := forall n (fm : NM) (m5: m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.remove n fs) fm = sumM fs fm * m5^-1.
rewrite -/(P_ind I_ind).
apply (NSetOrdProps.set_induction_min); rewrite /P_ind {P_ind I_ind}.
  move => fs H_empty n fm m5 H_in.
  have H_empty' := NSet.empty_spec.
  by contradict H_in; apply H_empty.
rewrite /sumM.
move => fs I' IH a H_below H_add n fm m5 H_in H_map.
have H_eql := NSetOrdProps.elements_Add_Below H_below H_add.
apply eqlistA_eq in H_eql.
rewrite 2!sumM_fold_right.
case (name_eq_dec a n) => H_eq.
  move: H_in H_map; rewrite -H_eq H_eql {H_eq} => H_in H_map.
  rewrite /NSetOrdProps.P.Add in H_add.
  have H_rem := NSet.remove_spec I' a.
  have H_below': NSetOrdProps.Below a (NSet.remove a I').
    rewrite /NSetOrdProps.Below => a' H_in'.
    apply NSet.remove_spec in H_in'.
    case: H_in' => H_in' H_neq.
    apply H_below.
    apply H_add in H_in'.
    by case: H_in' => H_in'; first by case H_neq.
  have H_add' := NSetProps.Add_remove H_in.
  have H_eql' := NSetOrdProps.elements_Add_Below H_below' H_add'.
  apply eqlistA_eq in H_eql'.
  rewrite H_eql {H_eql} in H_eql'.
  set el_rm := NSet.elements _.
  have {H_eql'} ->: el_rm = NSet.elements fs by injection H_eql'.
  rewrite {2}/fold_right {2}/sum_fold {el_rm}.
  case H_find: (NMap.find _ _) => [m6|]; last by rewrite H_map in H_find.
  rewrite H_map in H_find.
  have ->: m6 = m5 by injection H_find.
  by gsimpl.
rewrite H_eql.
have H_in': NSet.In n fs.
  apply H_add in H_in.
  by case: H_in.
have H_below': NSetOrdProps.Below a (NSet.remove n fs).
  rewrite /NSetOrdProps.Below => a' H_inr.
  apply H_below.
  have H_rm := NSet.remove_spec fs n a'.
  apply H_rm in H_inr.
  by case: H_inr.
have H_add': NSetOrdProps.P.Add a (NSet.remove n fs) (NSet.remove n I').
  rewrite /NSetOrdProps.P.Add => a'.
  have H_add_a' := H_add a'.
  case (name_eq_dec a a') => H_eq'.
    split => H_imp; first by left.
    have H_or: a = a' \/ NSet.In a' fs by left.
    apply H_add_a' in H_or.
    apply NSet.remove_spec; split => //.
    by rewrite -H_eq'.
  split => H_imp.
    right.
    apply NSet.remove_spec in H_imp.
    case: H_imp => H_imp H_neq.
    apply NSet.remove_spec; split => //.
    apply H_add_a' in H_imp.
    by case: H_imp.
  case: H_imp => H_imp //.
  apply NSet.remove_spec in H_imp.
  case: H_imp => H_imp H_neq.
  have H_or: a = a' \/ NSet.In a' fs by right.
  apply H_add_a' in H_or.
  by apply NSet.remove_spec; split.
have H_eql' := NSetOrdProps.elements_Add_Below H_below' H_add'.
apply eqlistA_eq in H_eql'.
rewrite H_eql' /fold_right /sum_fold.
case H_find: (NMap.find a fm) => [m6|].
  have H_eq' := IH n fm m5 H_in' H_map.
  rewrite 2!sumM_fold_right /fold_right in H_eq'.
  rewrite H_eq' /sum_fold.
  by aac_reflexivity.
have H_eq' := IH n fm m5 H_in' H_map.
rewrite 2!sumM_fold_right in H_eq'.
rewrite /fold_right in H_eq'.
by rewrite H_eq' /sum_fold.
Qed.

Lemma sumM_notins_remove_map : forall (fs : NS) (n : name) (fm : NM),
  ~ NSet.In n fs ->
  sumM fs (NMap.remove n fm) = sumM fs fm.
Proof.
move => fs n fm H_ins.
have H_notin: ~ InA eq n (NSet.elements fs).
  move => H_ina.
  by apply NSetFacts.elements_2 in H_ina.
rewrite 2!/sumM 2!sumM_fold_right.
move: H_notin.
elim (NSet.elements fs) => [|a l IH] H_in //.
have H_in': ~ InA eq n l.
  move => H_in'.
  contradict H_in.
  by right.
have H_neq: n <> a.
  move => H_eq.
  contradict H_in.
  by left.
have IH' := IH H_in'.
move: IH'.
rewrite /fold_right /sum_fold => IH'.
case H_find: (NMap.find _ _) => [m5|].
  case H_find': (NMap.find _ _) => [m6|]; rewrite NMapFacts.remove_neq_o in H_find => //.
    rewrite H_find in H_find'.
    injection H_find' => H_eq.
    rewrite H_eq.
    by rewrite IH'.
  by rewrite H_find in H_find'.
rewrite NMapFacts.remove_neq_o in H_find => //.
case H_find': (NMap.find _ _) => [m5|] //.
by rewrite H_find in H_find'.
Qed.

Lemma sumM_remove_remove : forall (fs : NS) (n : name) (fm : NM) (m5: m),
  NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.remove n fs) (NMap.remove n fm) = sumM fs fm * m5^-1.
Proof.
move => fs n fm m5 H_ins H_find.
have H_ins': ~ NSet.In n (NSet.remove n fs) by move => H_ins'; apply NSetFacts.remove_1 in H_ins'.
rewrite sumM_notins_remove_map => //.
exact: sumM_remove.
Qed.

Lemma sumM_empty : forall (fs : NS) (fm : NM), NSet.Empty fs -> sumM fs fm = 1.
Proof.
move => fs fm.
rewrite /NSet.Empty => H_empty.
have H_elts: forall n, ~ InA eq n (NSet.elements fs).
  move => n H_notin.
  apply NSetFacts.elements_2 in H_notin.
  by apply (H_empty n).
rewrite /sumM sumM_fold_right.
case H_elt: (NSet.elements fs) => [|a l] //.
have H_in: InA eq a (NSet.elements fs) by rewrite H_elt; apply InA_cons; left.
by contradict H_in; apply (H_elts a).
Qed.

Lemma sumM_eq : forall (fs : NS) (fm' : NS) (fm : NM),
   NSet.Equal fs fm' ->
   sumM fs fm = sumM fm' fm.
Proof.
move => I_ind.
pose P_ind (fs : NS) := forall (fm' : NS) (fm : NM),
   NSet.Equal fs fm' ->
   sumM fs fm = sumM fm' fm.
rewrite -/(P_ind I_ind).
apply (NSetOrdProps.set_induction_min); rewrite /P_ind {P_ind I_ind}.
  move => fs H_empty fm' fm H_eq.
  have H_empty': NSet.Empty fm'.
    rewrite /NSet.Empty => a H_in.
    apply H_eq in H_in.
    by apply H_empty in H_in.
  rewrite sumM_empty //.
  by rewrite sumM_empty.
move => fs fm' IH a H_below H_add fm'' fm H_eq.
have H_eql := NSetOrdProps.elements_Add_Below H_below H_add.
apply eqlistA_eq in H_eql.
rewrite /sumM 2!sumM_fold_right H_eql.
have H_below': NSetOrdProps.Below a (NSet.remove a fm'').
  rewrite /NSetOrdProps.Below => a' H_in.
  apply H_below.
  apply (NSet.remove_spec) in H_in.
  case: H_in => H_in H_neq.
  apply H_eq in H_in.
  apply H_add in H_in.
  by case: H_in => H_in; first by case H_neq.
have H_add': NSetOrdProps.P.Add a (NSet.remove a fm'') fm''.
  rewrite /NSetOrdProps.P.Add => a'.
  case (name_eq_dec a a') => H_eq_a.
    split => H_imp; first by left.
    apply H_eq.
    rewrite -H_eq_a.
    by apply H_add; left.
  split => H_imp; first by right; apply NSet.remove_spec; split; last by contradict H_eq_a.
  case: H_imp => H_imp; first by case H_eq_a.
  by apply NSet.remove_spec in H_imp; case: H_imp.
have H_eq': NSet.Equal fs (NSet.remove a fm'').
   rewrite /NSet.Equal => a'.
   case (name_eq_dec a a') => H_eq_a.
     have H_or: a = a' \/ NSet.In a' fs by left.
     apply H_add in H_or.
     split => H_imp.
       apply NSet.remove_spec.
       rewrite -H_eq_a in H_or H_imp.
       apply H_below in H_imp.
       contradict H_imp.
       by apply NOT.lt_strorder.
     rewrite H_eq_a in H_imp.
     apply NSet.remove_spec in H_imp.
     case: H_imp.
     move => H_in H_eq'.
     by case: H_eq'.
   split => H_imp.
     apply NSet.remove_spec; split; last by contradict H_eq_a.
     apply H_eq.
     by apply H_add; right.
   apply NSet.remove_spec in H_imp.
   case: H_imp => H_imp H_neq.
   apply H_eq in H_imp.
   apply H_add in H_imp.
   by case: H_imp.
have H_eql' := NSetOrdProps.elements_Add_Below H_below' H_add'.
apply eqlistA_eq in H_eql'.
rewrite H_eql' /sum_fold /fold_right.
have IH' := IH (NSet.remove a fm'') fm.
rewrite /sumM 2!sumM_fold_right /fold_right in IH'.
by case H_find: (NMap.find _ _) => [m5|]; rewrite IH'.
Qed.

Corollary sumM_add : forall (fs : NS) (fm : NM) (m5 : m) (n : name),
  ~ NSet.In n fs ->
  NMap.find n fm = Some m5 ->
  sumM (NSet.add n fs) fm = sumM fs fm * m5.
Proof.
move => fs fm m5 n H_notin H_map.
have H_in: NSet.In n (NSet.add n fs) by apply NSet.add_spec; left.
have H_rm := @sumM_remove (NSet.add n fs) _ _ _ H_in H_map.
set srm := sumM _ _ in H_rm.
set sadd := sumM _ _ in H_rm *.
have <-: srm * m5 = sadd by rewrite H_rm; gsimpl.
suff H_eq: srm = sumM fs fm by rewrite H_eq; aac_reflexivity.
apply sumM_eq.
exact: (NSetProps.remove_add H_notin).
Qed.

Lemma sumM_add_add : forall (fs : NS) (M5 : NM) (m5 : m) (n : name),
  ~ NSet.In n fs ->
  sumM (NSet.add n fs) (NMap.add n m5 M5) = sumM fs M5 * m5.
Proof.
move => fs M5 m5 n H_in.
have H_find := @NMapFacts.add_eq_o _ M5 _ _ m5 (refl_equal n).
rewrite (@sumM_add _ _ _ _ H_in H_find) {H_find}.
set sadd := sumM _ _.
suff H_suff: sadd = sumM fs M5 by rewrite H_suff.
rewrite /sadd /sumM 2!sumM_fold_right {sadd}.
have H_in_el: ~ InA eq n (NSet.elements fs) by move => H_neg; apply NSetFacts.elements_2 in H_neg.
by move: H_in_el; apply not_in_add_eq.
Qed.

Lemma sumM_init_map_1 : forall fm, sumM fm (init_map fm) = 1.
Proof.
move => fm.
rewrite /sumM sumM_fold_right.
rewrite /init_map /=.
case (init_map_str _).
move => fm' H_init.
have H_el := NSet.elements_spec1 fm.
have H_in: forall n, In n (NSet.elements fm) -> NMap.find n fm' = Some 1.
  move => n H_in.
  apply H_init.
  have [H_el' H_el''] := H_el n.
  apply: H_el'.
  apply InA_alt.
  by exists n; split.
move {H_init H_el}.
elim: (NSet.elements fm) H_in => //.
move => n l IH H_in.
rewrite /= {1}/sum_fold.
have H_in': In n (n :: l) by left.
have H_find' := H_in n H_in'.
rewrite IH.
  case H_find: (NMap.find _ _) => [n'|] //.
  rewrite H_find in H_find'.
  injection H_find' => H_eq'.
  rewrite H_eq'.
  by gsimpl.
move => n' H_in''.
apply H_in.
by right.
Qed.

Lemma sumM_active_remove_eq :
  forall ns n adj map,
  ~ In n ns ->
  sumM_active adj map ns = sumM_active (NSet.remove n adj) map ns.
Proof.
elim => [|n ns IH] n' adj map H_notin //.
have H_notin': ~ In n' ns by move => H_in; case: H_notin; right.
rewrite /= /sum_active_fold.
case: ifPn => H_mem; case: ifPn => H_mem'.
- by rewrite (IH n').
- apply NSetFacts.mem_2 in H_mem.
  have H_ins: ~ NSet.In n (NSet.remove n' adj).
    move => H_ins.
    move/negP: H_mem' => H_mem'.
    contradict H_mem'.
    by apply NSetFacts.mem_1 in H_ins.
  contradict H_ins.
  apply NSetFacts.remove_2 => //.
  move => H_eq.
  contradict H_notin.
  by left.
- have H_ins: ~ NSet.In n adj by move => H_ins; apply NSetFacts.mem_1 in H_ins; rewrite H_ins in H_mem.
  apply NSetFacts.mem_2 in H_mem'.
  contradict H_ins.
  by apply NSetFacts.remove_3 in H_mem'.
- by rewrite (IH n').
Qed.

Lemma sumM_active_app_distr :
  forall ns0 ns1 adj map,
    sumM_active adj map (ns0 ++ ns1) = sumM_active adj map ns0 * sumM_active adj map ns1.
Proof.
elim => [|n ns0 IH] ns1 adj map /=; first by gsimpl.
rewrite IH.
rewrite /sum_active_fold /sum_fold.
case: ifP => H_mem //.
by case H_find: (NMap.find _ _) => [m0|]; first by aac_reflexivity.
Qed.

Lemma sumM_active_eq_sym :
  forall ns ns' adj map,
  Permutation ns ns' ->
  sumM_active adj map ns = sumM_active adj map ns'.
Proof.
elim => [|n ns IH] ns' adj map H_pm.
  apply Permutation_nil in H_pm.
  by rewrite H_pm.
have H_in: In n (n :: ns) by left.
have H_in': In n ns'.
  move: H_pm H_in.
  exact: Permutation_in.
apply in_split in H_in'.
move: H_in' => [ns0 [ns1 H_eq]].
rewrite H_eq in H_pm.
have H_pm' := H_pm.
apply Permutation_cons_app_inv in H_pm'.
rewrite H_eq sumM_active_app_distr /=.
rewrite (IH _ _ _ H_pm') sumM_active_app_distr.
rewrite /sum_active_fold.
case: ifP => H_mem //.
rewrite /sum_fold.
by case H_find: (NMap.find _ _) => [m0|]; first by aac_reflexivity.
Qed.

Class AggregationData (data : Type) :=
  {
    aggr_local : data -> m ;
    aggr_aggregate : data -> m ;
    aggr_adjacent : data -> NS ;
    aggr_balance : data -> NM
  }.

Section AggregationData.

Context {data} {ad : AggregationData data}.

Definition conserves_node_mass (d : data) : Prop :=
d.(aggr_local) = d.(aggr_aggregate) * sumM d.(aggr_adjacent) d.(aggr_balance).

Definition sum_local (l : list data) : m :=
fold_right (fun (d : data) (partial : m) => partial * d.(aggr_local)) 1 l.

Definition sum_aggregate (l : list data) : m :=
fold_right (fun (d : data) (partial : m) => partial * d.(aggr_aggregate)) 1 l.

Definition sum_balance (l : list data) : m :=
fold_right (fun (d : data) (partial : m) => partial * sumM d.(aggr_adjacent) d.(aggr_balance)) 1 l.

Definition conserves_mass_globally (l : list data) : Prop :=
sum_local l = sum_aggregate l * sum_balance l.

Definition conserves_node_mass_all (l : list data) : Prop :=
forall d, In d l -> conserves_node_mass d.

Definition Nodes_data (ns : list name) (state : name -> data) : list data :=
fold_right (fun (n : name) (l' : list data) => n.(state) :: l') [] ns.

Definition Nodes_data_opt (ns : list name) (state : name -> option data) : list data :=
fold_right (fun (n : name) (l' : list data) =>
              match state n with
              | Some d => d :: l'
              | None => l'
              end) [] ns.

Lemma global_conservation :
  forall (l : list data),
    conserves_node_mass_all l ->
    conserves_mass_globally l.
Proof.
rewrite /conserves_mass_globally /=.
elim => [|d l IH]; first by gsimpl.
move => H_cn.
rewrite /=.
rewrite /conserves_node_mass_all in H_cn.
have H_cn' := H_cn d.
rewrite H_cn'; last by left.
rewrite IH; first by gsimpl; aac_reflexivity.
move => d' H_in.
apply: H_cn.
by right.
Qed.

Lemma sum_local_split :
  forall ns0 ns1 state n,
    sum_local (Nodes_data (ns0 ++ n :: ns1) state) =
    n.(state).(aggr_local) * sum_local (Nodes_data (ns0 ++ ns1) state).
Proof.
elim => /=; first by move => ns1 state n; aac_reflexivity.
move => n ns IH ns1 state n'.
rewrite IH /=.
by gsimpl.
Qed.

Lemma sum_local_opt_app :
  forall ns0 ns1 state n d,
    state n = Some d ->
    sum_local (Nodes_data_opt (ns0 ++ n :: ns1) state) =
    d.(aggr_local) * sum_local (Nodes_data_opt (ns0 ++ ns1) state).
Proof.
elim => /=.
  move => ns1 state n d H_eq.
  rewrite H_eq /=.
  by aac_reflexivity.
move => n ns IH ns1 state n' d H_eq.
have IH' := IH ns1 state _ _ H_eq.
by break_match; rewrite /= IH'; first by gsimpl.
Qed.

Lemma sum_aggregate_split :
  forall ns0 ns1 state n,
    sum_aggregate (Nodes_data (ns0 ++ n :: ns1) state) =
    n.(state).(aggr_aggregate) * sum_aggregate (Nodes_data (ns0 ++ ns1) state).
Proof.
elim => /=; first by move => ns1 state n; aac_reflexivity.
move => n ns IH ns1 state n'.
rewrite IH /=.
by gsimpl.
Qed.

Lemma sum_aggregate_opt_app :
  forall ns0 ns1 state n d,
    state n = Some d ->
    sum_aggregate (Nodes_data_opt (ns0 ++ n :: ns1) state) =
    d.(aggr_aggregate) * sum_aggregate (Nodes_data_opt (ns0 ++ ns1) state).
Proof.
elim => /=.
  move => ns1 state n d H_eq.
  rewrite H_eq /=.
  by aac_reflexivity.
move => n ns IH ns1 state n' d H_eq.
have IH' := IH ns1 state _ _ H_eq.
by break_match; rewrite /= IH'; first by gsimpl.
Qed.

Lemma Nodes_data_not_in :
forall n' d state ns,
~ In n' ns ->
fold_right
  (fun (n : name) (l : list data) =>
     (match name_eq_dec n n' with
      | left _ => d
      | right _ => n.(state)
      end) :: l) [] ns = Nodes_data ns state.
Proof.
move => n' d state.
elim => //.
move => a l IH H_in.
rewrite /=.
case name_eq_dec => H_dec; first by case: H_in; left.
rewrite IH => //.
move => H_in'.
by case: H_in; right.
Qed.

Lemma Nodes_data_split :
  forall ns0 ns1 (state : name -> data),
    Nodes_data (ns0 ++ ns1) state =
    Nodes_data ns0 state ++ Nodes_data ns1 state.
Proof.
elim => //.
move => n ns0 IH ns1 state.
rewrite /=.
by rewrite IH.
Qed.

Lemma Nodes_data_opt_split :
  forall ns0 ns1 (state : name -> option data),
    Nodes_data_opt (ns0 ++ ns1) state =
    Nodes_data_opt ns0 state ++ Nodes_data_opt ns1 state.
Proof.
elim => //.
move => n ns0 IH ns1 state.
rewrite /=.
by break_match; rewrite IH.
Qed.

Lemma sum_balance_distr :
  forall dl dl',
    sum_balance (dl ++ dl') = sum_balance dl * sum_balance dl'.
Proof.
elim => /=; first by move => dl'; gsimpl.
move => d dl IH dl'.
rewrite IH.
by aac_reflexivity.
Qed.

Lemma sum_balance_Nodes_data_distr :
  forall ns0 ns1 state,
    sum_balance (Nodes_data ns0 state) * sum_balance (Nodes_data ns1 state) =
    sum_balance (Nodes_data (ns0 ++ ns1) state).
Proof.
elim => [|n ns0 IH] ns1 net /=; first by gsimpl.
rewrite -IH.
by aac_reflexivity.
Qed.

Lemma sum_balance_Nodes_data_opt_distr :
  forall ns0 ns1 state,
    sum_balance (Nodes_data_opt ns0 state) * sum_balance (Nodes_data_opt ns1 state) =
    sum_balance (Nodes_data_opt (ns0 ++ ns1) state).
Proof.
elim => [|n ns0 IH] ns1 net /=; first by gsimpl.
by break_match; rewrite /= -IH; aac_reflexivity.
Qed.

End AggregationData.

Class AggregationMsg :=
  {
    aggr_msg : Type ;
    aggr_msg_eq_dec : forall x y : aggr_msg, {x = y} + {x <> y} ;
    aggr_fail : aggr_msg ;
    aggr_of : aggr_msg -> m ;
  }.

Section AggregationMsg.

Context {am : AggregationMsg}.

Context {data} {ad : AggregationData data}.

Definition aggregate_sum_fold (mg : aggr_msg) (partial : m) : m :=
partial * aggr_of mg.

Definition sum_aggregate_msg := fold_right aggregate_sum_fold 1.

(* given n, sum aggregate messages for all its incoming channels *)
Definition sum_aggregate_msg_incoming (ns : list name) (packets : name -> name -> list aggr_msg) (n : name) : m :=
fold_right (fun (n' : name) (partial : m) =>
  partial * if In_dec aggr_msg_eq_dec aggr_fail (packets n' n) then 1 else sum_aggregate_msg (packets n' n)) 1 ns.

(* given list of active names and all names, sum all incoming channels for all active *)
Definition sum_aggregate_msg_incoming_active (allns : list name) (actns : list name)  (packets : name -> name -> list aggr_msg) : m :=
fold_right (fun (n : name) (partial : m) => partial * sum_aggregate_msg_incoming allns packets n) 1 actns.

Definition sum_fail_map (l : list aggr_msg) (from : name) (adj : NS) (map : NM) : m :=
if In_dec aggr_msg_eq_dec aggr_fail l && NSet.mem from adj then sum_fold map from 1 else 1.

Definition sum_fail_map_incoming (ns : list name) (packets : name -> name -> list aggr_msg) (n : name) (adj : NS) (map : NM) : m :=
fold_right (fun (n' : name) (partial : m) => partial * sum_fail_map (packets n' n) n' adj map) 1 ns.

Definition sum_fail_balance_incoming_active (allns : list name) (actns : list name) (packets : name -> name -> list aggr_msg) (state : name -> data) : m :=
fold_right (fun (n : name) (partial : m) =>
  partial * sum_fail_map_incoming allns packets n n.(state).(aggr_adjacent) n.(state).(aggr_balance)) 1 actns.

Definition sum_fail_balance_incoming_active_opt (allns : list name) (actns : list name) (packets : name -> name -> list aggr_msg) (state : name -> option data) : m :=
fold_right (fun (n : name) (partial : m) =>
              match state n with
              | Some d => partial * sum_fail_map_incoming allns packets n d.(aggr_adjacent) d.(aggr_balance)
              | None => partial
              end) 1 actns.

Definition conserves_network_mass (actns : list name) (allns : list name) (packets : name -> name -> list aggr_msg) (state : name -> data) : Prop :=
sum_local (Nodes_data actns state) =
  sum_aggregate (Nodes_data actns state) *
  sum_aggregate_msg_incoming_active allns actns packets *
  sum_fail_balance_incoming_active allns actns packets state.

Definition conserves_network_mass_opt (actns : list name) (allns : list name) (packets : name -> name -> list aggr_msg) (state : name -> option data) : Prop :=
sum_local (Nodes_data_opt actns state) =
  sum_aggregate (Nodes_data_opt actns state) *
  sum_aggregate_msg_incoming_active allns actns packets *
  sum_fail_balance_incoming_active_opt allns actns packets state.

End AggregationMsg.

Class AggregationMsgMap (P1 : AggregationMsg) (P2 : AggregationMsg) :=
  {
    map_msgs : list (@aggr_msg P1) -> list (@aggr_msg P2) ;
    sum_aggregate_msg_map_msgs_eq : forall ms, sum_aggregate_msg ms = sum_aggregate_msg (map_msgs ms) ;
    aggr_fail_in_in : forall ms, In aggr_fail ms <-> In aggr_fail (map_msgs ms)
  }.

Section AggregationMsgMap.

Context {data_fst} {ad_fst : AggregationData data_fst}.
Context {data_snd} {ad_snd : AggregationData data_snd}.

Lemma sum_local_aggr_local_eq :
  forall (state : name -> data_fst) (state' : name -> data_snd) ns,
   (forall n, In n ns -> n.(state).(aggr_local) = n.(state').(aggr_local)) ->
    sum_local (Nodes_data ns state) = sum_local (Nodes_data ns state').
Proof.
move => state state'.
elim => //=.
move => n ns IH H_in.
rewrite /= H_in; last by left.
rewrite IH //.
move => n' H_in'.
by rewrite H_in; last by right.
Qed.

Lemma sum_local_opt_aggr_local_eq :
  forall (state : name -> option data_fst) (state' : name -> option data_snd) ns,
   (forall n, In n ns -> state n = None <-> state' n = None) ->
   (forall n, In n ns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_local) = d1.(aggr_local)) ->
    sum_local (Nodes_data_opt ns state) = sum_local (Nodes_data_opt ns state').
Proof.
move => state state'.
elim => //=.
move => n ns IH H_imp H_in.
case H_n: state => [d0|]; case H_n': state' => [d1|].
- rewrite /=.
  rewrite (H_in n _ d0 _ d1) //; last by left.
  rewrite IH //.
  * move => n0 H_in'.
    apply: H_imp.
    by right.
  * move => n0 H_in'.
    apply: H_in.
    by right.
- apply H_imp in H_n'; last by left.
  by congruence.
- apply H_imp in H_n; last by left.
  by congruence.
- rewrite IH //.
  * move => n0 H_in'.
    apply: H_imp.
    by right.
  * move => n0 H_in'.
    apply: H_in.
    by right.
Qed.

Lemma sum_aggregate_aggr_aggregate_eq :
  forall (state : name -> data_fst) (state' : name -> data_snd) ns,
   (forall n, In n ns -> n.(state).(aggr_aggregate) = n.(state').(aggr_aggregate)) ->
    sum_aggregate (Nodes_data ns state) = sum_aggregate (Nodes_data ns state').
Proof.
move => state state'.
elim => //=.
move => n ns IH H_in.
rewrite /= H_in; last by left.
rewrite IH //.
move => n' H_in'.
by rewrite H_in; last by right.
Qed.

Lemma sum_aggregate_opt_aggr_aggregate_eq :
  forall (state : name -> option data_fst) (state' : name -> option data_snd) ns,
    (forall n, In n ns -> state n = None <-> state' n = None) ->
   (forall n, In n ns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_aggregate) = d1.(aggr_aggregate)) ->
    sum_aggregate (Nodes_data_opt ns state) = sum_aggregate (Nodes_data_opt ns state').
Proof.
move => state state'.
elim => //=.
move => n ns IH H_imp H_in.
case H_n: state => [d0|]; case H_n': state' => [d1|].
- rewrite /=.
  rewrite (H_in n _ d0 _ d1) //; last by left.
  rewrite IH //.
  * move => n0 H_in'.
    apply: H_imp.
    by right.
  * move => n0 H_in'.
    apply: H_in.
    by right.
- apply H_imp in H_n'; last by left.
  by congruence.
- apply H_imp in H_n; last by left.
  by congruence.
- rewrite IH //.
  * move => n0 H_in'.
    apply: H_imp.
    by right.
  * move => n0 H_in'.
    apply: H_in.
    by right.
Qed.

Context {am_fst : AggregationMsg}.
Context {am_snd : AggregationMsg}.
Context {amm : AggregationMsgMap am_fst am_snd}.

Lemma sum_aggregate_msg_incoming_map_msgs_eq :
  forall (ns : list name) (packets : name -> name -> list (@aggr_msg am_fst)) (n : name),
  sum_aggregate_msg_incoming ns packets n = sum_aggregate_msg_incoming ns (fun src dst => map_msgs (packets src dst)) n.
Proof.
elim => //=.
move => n ns IH packets n'.
rewrite /is_left /=.
case in_dec => H_dec; case in_dec => H_dec'.
- by gsimpl; rewrite IH.
- by apply aggr_fail_in_in in H_dec.
- by apply aggr_fail_in_in in H_dec'.
- by rewrite sum_aggregate_msg_map_msgs_eq IH.
Qed.

Lemma sum_aggregate_msg_incoming_active_map_msgs_eq :
  forall (actns allns : list name) (packets : name -> name -> list (@aggr_msg am_fst)),
  sum_aggregate_msg_incoming_active allns actns packets = sum_aggregate_msg_incoming_active allns actns (fun src dst => map_msgs (packets src dst)).
Proof.
elim => //=.
move => n ns IH allns packets.
by rewrite sum_aggregate_msg_incoming_map_msgs_eq IH.
Qed.

Lemma sum_fail_map_map_msgs_eq :
  forall (packets : name -> name -> list (@aggr_msg am_fst)) src dst from adj map,
    sum_fail_map (packets src dst) from adj map = sum_fail_map (map_msgs (packets src dst)) from adj map.
Proof.
move => packets src dst from adj map.
rewrite /sum_fail_map /=.
case in_dec => H_dec; case in_dec => /= H_dec' //; first by apply aggr_fail_in_in in H_dec.
by apply aggr_fail_in_in in H_dec'.
Qed.

Lemma sum_fail_map_incoming_map_msgs_eq :
  forall ns (packets : name -> name -> list (@aggr_msg am_fst)) n adj map,
     sum_fail_map_incoming ns packets n adj map = sum_fail_map_incoming ns (fun src dst => map_msgs (packets src dst)) n adj map.
Proof.
elim => //=.
move => n ns IH packets n' adj map.
by rewrite sum_fail_map_map_msgs_eq // IH.
Qed.

(* FIXME: equivalence for balance instead of Leibniz equality *)
Lemma sum_fail_balance_incoming_active_map_msgs_eq :
  forall (state : name -> data_fst) (state' : name -> data_snd) (packets : name -> name -> list (@aggr_msg am_fst)) allns actns,
    (forall n, In n actns -> n.(state).(aggr_adjacent) = n.(state').(aggr_adjacent)) ->
    (forall n, In n actns -> n.(state).(aggr_balance) = n.(state').(aggr_balance)) ->
    sum_fail_balance_incoming_active allns actns packets state =
    sum_fail_balance_incoming_active allns actns (fun src dst => map_msgs (packets src dst)) state'.
Proof.
move => state state' packets allns.
elim => //=.
move => n actns IH H_eq H_eq'.
rewrite sum_fail_map_incoming_map_msgs_eq //.
rewrite H_eq; last by left.
rewrite H_eq'; last by left.
rewrite IH //.
  move => n' H_in.
  by rewrite H_eq; last by right.
move => n' H_in.
by rewrite H_eq'; last by right.
Qed.

Lemma sum_fail_balance_incoming_active_opt_map_msgs_eq :
  forall (state : name -> option data_fst) (state' : name -> option data_snd) (packets : name -> name -> list (@aggr_msg am_fst)) allns actns,
    (forall n, In n actns -> state n = None <-> state' n = None) ->
    (forall n, In n actns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_adjacent) = d1.(aggr_adjacent)) ->
    (forall n, In n actns -> forall d0, state n = Some d0 -> forall d1, state' n = Some d1 -> d0.(aggr_balance) = d1.(aggr_balance)) ->
    sum_fail_balance_incoming_active_opt allns actns packets state =
    sum_fail_balance_incoming_active_opt allns actns (fun src dst => map_msgs (packets src dst)) state'.
Proof.
move => state state' packets allns.
elim => //=.
move => n ns IH H_in H_eq_adj H_eq_bal.
case H_n: state => [d0|]; case H_n': state' => [d1|].
- rewrite sum_fail_map_incoming_map_msgs_eq //.
  have H_eq_adj' := H_eq_adj n _ _ H_n _ H_n'.
  rewrite (H_eq_adj n _ d0 _ d1) //; last by left.
  rewrite (H_eq_bal n _ d0 _ d1) //; last by left.
  rewrite IH //.
  * move => n' H_in_n'.
    apply: H_in.
    by right.
  * move => n' H_in_n'.
    apply: H_eq_adj.
    by right.
  * move => n' H_in_n'.
    apply: H_eq_bal.
    by right.
- apply H_in in H_n'; last by left.
  by congruence.
- apply H_in in H_n; last by left.
  by congruence.
- rewrite IH //.
  * move => n' H_in_n'.
    apply: H_in.
    by right.
  * move => n' H_in_n'.
    apply: H_eq_adj.
    by right.
  * move => n' H_in_n'.
    apply: H_eq_bal.
    by right.
Qed.

End AggregationMsgMap.

End NameTypeADefs.


(***************************************************************************
* Calculus of Constructions - Church-Rosser Property                       *
* Arthur Chargueraud, April 2007                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN CoC_Definitions CoC_Infrastructure CoC_BetaStar.
Implicit Types x : var.

(* ********************************************************************** *)
(** ** Additional Definitions Used in this Proof *)

(* ********************************************************************** *)
(** Definition of parallel reduction *)

Inductive para : relation :=
  | para_red : forall L t1 t2 t2' u u',
      term t1 ->
      (forall x, x \notin L -> para (t2 ^ x) (t2' ^ x) ) ->
      para u u' ->
      para (trm_app (trm_abs t1 t2) u) (t2' ^^ u')
  | para_var : forall x,
      para (trm_fvar x) (trm_fvar x)
  | para_srt : forall n,
      para (trm_type n) (trm_type n)
  | para_app : forall t1 t1' t2 t2',
      para t1 t1' ->
      para t2 t2' ->
      para (trm_app t1 t2) (trm_app t1' t2')
  | para_abs : forall L t1 t1' t2 t2',
     para t1 t1' ->
     (forall x, x \notin L -> para (t2 ^ x) (t2' ^ x) ) ->
     para (trm_abs t1 t2) (trm_abs t1' t2')
  | para_prod : forall L t1 t1' t2 t2',
     para t1 t1' ->
     (forall x, x \notin L -> para (t2 ^ x) (t2' ^ x) ) ->
     para (trm_prod t1 t2) (trm_prod t1' t2').

(* ********************************************************************** *)
(** Definition of the transitive closure of a relation *)

Inductive iter_ (R : relation) : relation :=
  | iter_trans : forall t2 t1 t3,
      iter_ R t1 t2 -> iter_ R t2 t3 -> iter_ R t1 t3
  | iter_step : forall t t',
      R t t' -> iter_ R t t'.

Notation "R 'iter'" := (iter_ R) (at level 69).

(* ********************************************************************** *)
(** ** Lemmas Associated to Additional Definitions *)

Hint Constructors para iter_.

(* ********************************************************************** *)
(** Regularity *)

Lemma red_regular_para : red_regular para.
Proof.
  intros_all. induction* H.
Qed.

Lemma red_regular_para_iter : red_regular (para iter).
Proof.
  intros_all. induction* H. apply* red_regular_para.
Qed.

Hint Extern 1 (term ?t) => match goal with
  | H: para t _ |- _ => apply (proj1 (red_regular_para H))
  | H: para _ t |- _ => apply (proj2 (red_regular_para H))
  | H: (para iter) t _ |- _ => apply (proj1 (red_regular_para_iter))
  | H: (para iter) _ t |- _ => apply (proj2 (red_regular_para_iter))
  end.

(* ********************************************************************** *)
(** Automation *)

Hint Resolve para_var para_srt para_app.

Hint Extern 1 (para (trm_abs _ _) (trm_abs _ _)) =>
  let y := fresh "y" in apply_fresh para_abs as y.
Hint Extern 1 (para (trm_prod _ _) (trm_prod _ _)) =>
  let y := fresh "y" in apply_fresh para_prod as y.
Hint Extern 1 (para (trm_app (trm_abs _ _) _) (_ ^^ _)) =>
  let y := fresh "y" in apply_fresh para_red as y.

(* ********************************************************************** *)
(** Properties of parallel reduction and its iterated version *)

Section ParaProperties.

Hint Extern 1 (para (if _ == _ then _ else _) _) => case_var.

Lemma para_red_all : red_all para.
Proof.
  intros x t t' H. induction H; intros; simple*.
  rewrite* subst_open. apply_fresh* para_red as y. cross*.
  case_var*.
  apply_fresh* para_abs as y. cross*.
  apply_fresh* para_prod as y. cross*.
Qed.

Lemma para_red_refl : red_refl para.
Proof.
  intros_all. induction* H.
Qed.

Lemma para_red_out : red_out para.
Proof.
  apply* (red_all_to_out para_red_all para_red_refl).
Qed.

Lemma para_red_rename : red_rename para.
Proof.
  apply* (red_out_to_rename para_red_out).
Qed.

Lemma para_red_through : red_through para.
Proof.
  apply* (red_all_to_through red_regular_para para_red_all).
Qed.

Lemma para_iter_red_refl : red_refl (para iter).
Proof.
  intros_all. autos* para_red_refl.
Qed.

End ParaProperties.

(* ********************************************************************** *)
(** Equality of beta star and iterated parallel reductions *)

Lemma beta_star_to_para_iter :
  (beta star) simulated_by (para iter).
Proof.
  intros_all. induction* H.
  apply* para_iter_red_refl.
  apply iter_step. induction H; autos* para_red_refl.
Qed.

Lemma para_iter_to_beta_star :
  (para iter) simulated_by (beta star).
Proof.
  intros_all. induction H; eauto.
  induction H.
  applys~ (@star_trans beta (t2 ^^ u)).
   pick_fresh x. apply* (@beta_star_red_through x).
  apply* star_refl.
  apply* star_refl.
  apply~ (@star_trans beta (trm_app t1' t2)).
   apply* beta_star_app1. apply* beta_star_app2.
  apply~ (@star_trans beta (trm_abs t1' t2)).
    apply* beta_star_abs1. apply* beta_star_abs2.
  apply~ (@star_trans beta (trm_prod t1' t2)).
    apply* beta_star_prod1. apply* beta_star_prod2.
Qed.

(* ********************************************************************** *)
(** ** Proof of Church-Rosser Property for Beta Reduction *)

(* ********************************************************************** *)
(** Confluence of parallel reduction *)

Lemma para_abs_inv : forall t1 t2 u,
  para (trm_abs t1 t2) u -> exists L t1' t2',
  u = (trm_abs t1' t2') /\ para t1 t1' /\
  forall x : var, x \notin L -> para (t2 ^ x) (t2' ^ x).
intros. inversion H. exists* L.
Qed.

Lemma para_prod_inv : forall t1 t2 u,
  para (trm_prod t1 t2) u -> exists L t1' t2',
  u = (trm_prod t1' t2') /\ para t1 t1' /\
  forall x : var, x \notin L -> para (t2 ^ x) (t2' ^ x).
Proof.
  intros. inversion H. exists* L.
Qed.

Lemma para_confluence : confluence para.
Proof.
  introv HS. gen T. induction HS; intros T HT; inversions HT.
    (* case: red / red *)
  lets~ [u2 [U2a U2b]]: IHHS u'0 __. clear IHHS.
  pick_fresh x. lets~ [u1x [U1a U1b]]: H1 (t2'0 ^ x) __. auto. clear H1.
  destruct~ (@close_var_spec u1x x) as [u1 [EQu1 termu1]].
  rewrite EQu1 in U1a, U1b.
  exists (u1 ^^ u2). split; apply* (@para_red_through x).
    (* case: red / trm_app *)
  lets~ [u2 [U2a U2b]]: IHHS t2'0 __. clear IHHS.
  lets [L2 [t1'0x [t2'0x [EQ [Ht1'0 Ht2'0]]]]]: (para_abs_inv H4).
  rewrite EQ in H4 |- *.
  pick_fresh x. lets~ [u1x [U1a U1b]]: H1 (t2'0x ^ x) __. auto.
  lets~ [u1 [EQu1 termu1]]: (@close_var_spec u1x x) __.
  rewrite EQu1 in U1a, U1b.
  exists (u1 ^^ u2). split.
    apply* (@para_red_through x).
    apply_fresh para_red as y; auto.
    apply* (@para_red_rename x).
    (* case: var / var *)
  autos*.
    (* case: srt / srt *)
  autos*.
    (* case: trm_app / red *)
  lets~ [u2 [U2a U2b]]: IHHS2 u' __. clear IHHS2.
  lets [L2 [t1'x [t2'x [EQ [Ht1'x Ht2'x]]]]]: (para_abs_inv HS1).
  lets~ [u1x [U1a U1b]]: (IHHS1 (trm_abs t1'x t2'0)) __. clear IHHS1.
  rewrite EQ in HS1, U1a |- *.
  lets~ [L1 [v1 [v2 [EQ' [Hv1 Hv2]]]]]: (para_abs_inv U1b).
  rewrite EQ' in U1a, U1b.
  exists (v2 ^^ u2). split.
    inversions U1a.
    apply* (@para_red L0).
    pick_fresh x. apply* (@para_red_through x).
    (* case: trm_app / trm_app *)
  lets~ [P1 [HP11 HP12]]: (IHHS1 t1'0) __.
  lets~ [P2 [HP21 HP22]]: (IHHS2 t2'0) __.
  exists* (trm_app P1 P2).
    (* case: trm_abs / trm_abs *)
  pick_fresh x. lets~ [px [P0 P1]]: H0 (t2'0 ^ x) __. auto.
  lets~ [u1 [HP1 HP2]]: (IHHS t1'0) __. clear H0 IHHS.
  lets~ [p [EQP termp]]: (@close_var_spec px x) __.
  rewrite EQP in P0, P1.
  exists (trm_abs u1 p). split;
   apply_fresh* para_abs as y; apply* (@para_red_rename x).
    (* case: trm_prod / trm_prod *)
  pick_fresh x. lets~ [px [P0 P1]]: H0 (t2'0 ^ x) __. auto.
  lets~ [u1 [HP1 HP2]]: IHHS t1'0 __. clear H0 IHHS.
  lets~ [p [EQP termp]]: (@close_var_spec px x) __.
  rewrite EQP in P0, P1.
  exists (trm_prod u1 p). split;
   apply_fresh* para_prod as y; apply* (@para_red_rename x).
Qed.

(* ********************************************************************** *)
(** Confluence of iterated parallel reduction *)

Lemma para_iter_parallelogram :
  forall M S, (para iter) M S -> forall T, para M T ->
  exists P, para S P /\ (para iter) T P.
Proof.
  introv H. induction H; intros T MtoT.
  destruct~ (IHiter_1 T) as [P [HP1 HP2]].
   destruct~ (IHiter_2 P) as [Q [HQ1 HQ2]].
   exists Q. autos* (@iter_trans para P).
  destruct* (para_confluence H MtoT).
Qed.

Lemma para_iter_confluence : confluence (para iter).
Proof.
  introv MtoS MtoT. gen T.
  induction MtoS; intros T MtoT.
  destruct~ (IHMtoS1 T) as [P [HP1 HP2]].
   destruct~ (IHMtoS2 P) as [Q [HQ1 HQ2]]. exists* Q.
  destruct* (para_iter_parallelogram MtoT H).
Qed.

(* ********************************************************************** *)
(** Church-Rosser property of beta reduction *)

Lemma confluence_beta_star : confluence (beta star).
Proof.
  intros_all. destruct (@para_iter_confluence M S T).
  autos* beta_star_to_para_iter.
  autos* beta_star_to_para_iter.
  autos* para_iter_to_beta_star.
Qed.

Lemma church_rosser_beta : church_rosser beta.
Proof.
  introv H. induction H.
  exists* t.
  destruct* IHequiv_.
  destruct IHequiv_1 as [u [Pu Qu]].
   destruct IHequiv_2 as [v [Pv Qv]].
   destruct (confluence_beta_star Qu Pv) as [w [Pw Qw]].
   exists w. split.
     apply* (@star_trans beta u).
     apply* (@star_trans beta v).
  exists* t'.
Qed.


Require Export Iron.Language.SystemF2Cap.Type.Exp.Base.
Require Export Iron.Language.SystemF2Cap.Type.Relation.EquivT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.SubsT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.KindTs.

(********************************************************************)
Inductive EquivTs : kienv -> stprops -> list ty -> list ty -> ki -> Prop :=
 | EqsSum
   :  forall ke sp ts1 ts2 k
   ,  SumKind k
   -> KindTs ke sp ts1 k
   -> KindTs ke sp ts2 k
   -> Forall (fun t2 => In t2 ts1) ts2
   -> Forall (fun t1 => In t1 ts2) ts1
   -> EquivTs ke sp ts1 ts2 k.

(********************************************************************)
Lemma equivTs_app
 :  forall ke sp ts1 ts1' ts2 ts2' k
 ,  EquivTs ke sp ts1 ts1' k
 -> EquivTs ke sp ts2 ts2' k
 -> EquivTs ke sp (ts1 ++ ts2) (ts1' ++ ts2') k.
Proof.
 intros.
 inverts H. inverts H0.
 eapply EqsSum; snorm.
  eapply in_app_split in H0. inverts H0.
   eauto. eauto.
  eapply in_app_split in H0. inverts H0.
   eauto. eauto.
Qed.
Hint Resolve equivTs_app.

Lemma equivTs_sumkind
 :  forall  ks sp ts1 ts2 k
 ,  EquivTs ks sp ts1 ts2 k
 -> SumKind k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve equivTs_sumkind.

Lemma equivTs_kinds_left
 :  forall  ks sp ts1 ts2 k
 ,  EquivTs ks sp ts1 ts2 k
 -> KindTs  ks sp ts1 k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve equivTs_kinds_left.

Lemma equivTs_kinds_right
 :  forall  ks sp ts1 ts2 k
 ,  EquivTs ks sp ts1 ts2 k
 -> KindTs  ks sp ts2 k.
Proof. intros. inverts H; auto. Qed.
Hint Resolve equivTs_kinds_right.

Lemma equivTs_refl
 :  forall  ke sp ts k
 ,  SumKind k
 -> KindTs  ke sp ts k
 -> EquivTs ke sp ts ts k.
Proof.
 intros.
 induction ts.
  eapply EqsSum; auto.
  eapply EqsSum; auto.
   norm. norm.
Qed.
Hint Resolve equivTs_refl.

Lemma equivTs_sym
 :  forall ke sp ts1 ts2 k
 ,  SumKind k
 -> KindTs  ke sp ts1 k
 -> KindTs  ke sp ts2 k
 -> EquivTs ke sp ts1 ts2 k
 -> EquivTs ke sp ts2 ts1 k.
Proof.
 intros. inverts H2.
 eapply EqsSum; auto.
Qed.

Lemma equivTs_trans
 :  forall ke sp ts1 ts2 ts3 k
 ,  EquivTs ke sp ts1 ts2 k
 -> EquivTs ke sp ts2 ts3 k
 -> EquivTs ke sp ts1 ts3 k.
Proof.
 intros.
 inverts H. inverts H0.
 eapply EqsSum; snorm.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal49.

Set Printing Depth 1000.
Definition lfind_eval  l n0:=
mem n0 l.

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)))) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).


From AC Require Import expression.
From AC Require Import sensor_state.
From AC Require Import value_tree.
From AC Require Import nvalue.
Require Import Bool.
Require Import String.
Require Import List.

Variable Delta : nat.
Variable Sigma : sensor_state exp.
Variable VtEnvironment : value_tree_env.

Reserved Notation "t '==>' t'" (at level 40).
Inductive bigstep : exp -> exp -> Prop :=
  | ST_Val : forall x e1 e2 w1 w2,
    value w1 ->
    value w2 ->
    <{e1}> ==> <{w1}> ->
    <{/x := w1/ e2 }> ==> <{w2}> ->
    <{val x = e1 ; e2}> ==> <{w2}>
  | ST_App : forall f e1 w1 e2 w2,
    is_fun f ->
    <{e1}> ==> f ->
    <{e2}> ==> <{w1}> ->
    <{f w1}> ==> <{w2}> ->
    <{e1 e2}> ==> <{w2}>
  | ST_Fun : forall n x T2 e v w,
    value v ->
    value w ->
    <{ /n:=(fun n [x:T2] {e})/ /x:=v/ e }> ==> <{w}> ->
    <{(fun n [x:T2] {e}) v}> ==> <{w}>
  | ST_Succ: forall (n:nat) w e,
    w = S n ->
    <{e}> ==> <{n}> ->
    <{succ e}> ==> <{w}>
  | ST_Pred: forall (n:nat) w e,
    w = Nat.pred n ->
    <{e}> ==> <{n}> ->
    <{pred e}> ==> <{w}>
  | ST_Prod: forall n (n':nat) m (m':nat) w,
    w = n' * m' ->
    <{n}> ==> <{n'}> ->
    <{m}> ==> <{m'}> ->
    <{n * m}> ==> <{w}>
  | ST_If_T: forall t1 t2 t3,
    <{t1}> ==> <{true}> ->
    <{if t1 then t2 else t3}> ==> <{t2}>
  | ST_If_F: forall t1 t2 t3,
    <{t1}> ==> <{false}> ->
    <{if t1 then t2 else t3}> ==> <{t3}>
  | ST_Refl: forall t1, <{t1}> ==> <{t1}>
  | ST_NvGet: forall (n:nat) (w:nvalue literal) e1 e2 (l:literal),
    l = nvalue.get n w ->
    <{e1}> ==> <{n}> ->
    <{e2}> ==> <{w}> ->
    <{nv_get e1 e2}> ==> <{l}>
  | ST_NvDefault: forall e1 (l:literal) (w: nvalue literal),
    l = nvalue.getDefault w ->
    <{e1}> ==> <{w}> ->
    <{nv_default e1}> ==> <{l}>
where "t '==>' t'" := (bigstep t t').


Require Export FunctorCategory Category.Morphisms.
Require Import Common NaturalTransformation.Composition.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.
Local Open Scope morphism_scope.

Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := @Isomorphic [C, D] F G.

Arguments NaturalIsomorphism {_} [C D] F G / .

Coercion NaturalIsomorphismNT `{Funext} C D F G (T : @NaturalIsomorphism _ C D F G)
: NaturalTransformation F G
  := T : Morphism _ _ _.

Infix "≅" := NaturalIsomorphism : natural_transformation_scope.

Global Instance NTC_NI_R `{Funext} A (a : A)
       `(T : @NaturalIsomorphism _ C D F G)
       `{@NTC_Composable _ _ a (T : Morphism _ _ _) T' term}
: @NTC_Composable A _ a T T' term | 0.

Global Instance NTC_NI_L `{Funext} A (a : A)
       `(T : @NaturalIsomorphism _ C D F G)
       `{@NTC_Composable _ _ (T : Morphism _ _ _) a T' term}
: @NTC_Composable _ _ T a T' term | 0.

Definition iso_NaturalTransformation0 `{Funext} `{@IsIsomorphism [C, D] F G T} x
: IsIsomorphism (T x).
Proof.
  exists (T^-1 x).
  - exact (apD10 (ap ComponentsOf LeftInverse) x).
  - exact (apD10 (ap ComponentsOf RightInverse) x).
Defined.

Hint Immediate iso_NaturalTransformation0 : typeclass_instances.

Definition iso_NaturalTransformation1_NT `{Funext}
           C D (F G : Functor C D) (T : NaturalTransformation F G)
           `{forall x, IsIsomorphism (T x)}
: NaturalTransformation G F.
Proof.
  exists (fun x => (T x)^-1);
  abstract (
      intros;
      iso_move_inverse;
      first [ apply Commutes
            | symmetry; apply Commutes ]
    ).
Defined.

Definition iso_NaturalTransformation1 `{Funext}
           C D F G (T : NaturalTransformation F G)
           `{forall x, IsIsomorphism (T x)}
: @IsIsomorphism [C, D] F G T.
Proof.
  exists (iso_NaturalTransformation1_NT _);
  abstract (
      nt_eq;
      first [ apply LeftInverse
            | apply RightInverse ]
    ).
Defined.

Section idtoiso.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable D : PreCategory.

  Definition idtoiso_FunctorCategory_NT
             (F G : Object [C, D])
             (T : F = G)
  : NaturalTransformation F G.
  Proof.
    refine (Build_NaturalTransformation
              F G
              (fun x => idtoiso _ (ap10 (ap ObjectOf T) x))
              _).
    intros; case T; simpl.
    etransitivity; [ | symmetry ];
    first [ apply LeftIdentity
          | apply RightIdentity ].
  Defined.

  Definition idtoiso_FunctorCategory
             (F G : Object [C, D])
             (T : F = G)
  : F ≅ G.
  Proof.
    exists (idtoiso_FunctorCategory_NT T).
    exists (idtoiso_FunctorCategory_NT (inverse T));
      abstract (nt_eq; case T; simpl; auto with morphism).
  Defined.

  Lemma eta_idtoiso_FunctorCategory
        (F G : Object [C, D])
        (T : F = G)
  : idtoiso _ T = idtoiso_FunctorCategory T.
  Proof.
    case T.
    expand; f_ap.
    exact (center _).
  Qed.
End idtoiso.

Hint Immediate iso_NaturalTransformation0 iso_NaturalTransformation1 : typeclass_instances.


Require Import FormalSystem Translation.

(*-----------------------------*)
(*Classical Logic*)

(*Schema of Excluded Middle*)
Inductive classic : form -> Prop :=
  Cem P : classic (Or P (!P)).

(*The union of two theories/contexts*)
Definition U_theory L L' : form -> Prop :=
  fun f => L f \/ L' f.
Notation "L ⋃ T" := (U_theory L T)
                      (at level 99).

(*Classical derivability*)
Definition deriv_classic L f : Prop :=
  L ⋃ classic ⊢ f.
Notation "L ⊢ₖ f" := (deriv_classic L f)
                       (at level 99).

(*Question 3.1.1*)
(*There is always an intuitionistic proof of nnt(A + ¬A)*)
Lemma c_nnt f :
  classic f ->
  forall L, L ⊢ nnt f.
Proof.
  intro H. induction H; simpl in *; intros.
  apply imp_i, (imp_e _ (Or (nnt P) (!(nnt P)))).
  - apply ax. right. reflexivity.
  - apply or_i2, imp_i, (imp_e _ (Or (nnt P) (!(nnt P)))).
    + apply ax. left. right. reflexivity.
    + apply or_i1, ax. right. reflexivity.
Qed.

(* Question 3.2.1 *)
(*Elimination of EM under the translation*)
Lemma nnt_lem L f :
  L ⊢ₖ f ->
  nnt_ctx L ⊢ nnt f.
Proof.
  intro H.
  assert (nnt_ctx (L ⋃ classic) ⊢ nnt f).
  - apply nnt_soundness. assumption.
  - apply (deriv_substitution (nnt_ctx (L ⋃ classic))).
    + assumption.
    + intros f0 H'. destruct H' as [x [H' H'']]. rewrite H''.
      case H'.
      * intro. apply nnt_soundness, ax. assumption.
      * intro. apply c_nnt. assumption.
Qed.

(*Fin*)


Require Import FOL Peano Tarski Deduction CantorPairing NumberTheory Synthetic DecidabilityFacts Formulas Coding Church.
Require Import Lia.
Require Import Equations.Equations Equations.Prop.DepElim.

Import Vector.VectorNotations.

Notation "x 'el' A" := (List.In x A) (at level 70).
Notation "A '<<=' B" := (List.incl A B) (at level 70).
Notation "x ∣ y" := (exists k, x * k = y) (at level 50).

Definition unary α := bounded 1 α.
Definition binary α := bounded 2 α.

Section Model.

  Context {Δ1 : Delta1}.

  Variable D : Type.
  Variable I : interp D.
  Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).
  Variable axioms : forall ax, PA ax -> ⊨ ax.

  Notation "N⊨ phi" := (forall rho, @sat _ _ nat interp_nat _ rho phi) (at level 40).
  Notation "x 'i⧀' y" := (exists d : D, y = iσ (x i⊕ d) ) (at level 40).

  Variable ψ : form.
  Variable Hψ : binary ψ /\ (forall x, Q ⊢I ∀ ψ[up (num x)..] <--> $0 == num (Irred x) ).

  Definition div_num n (d : D) := exists e, inu n i⊗ e = d.
  Definition div_pi n a :=  (inu n .: (fun _ => a)) ⊨ (∃ (ψ ∧ ∃ $1 ⊗ $0 == $3)).

  (** * Enumerable and discrete PA models have decidable divisibility. *)

  Lemma dec_div :
    Enumerable D -> Discrete D -> Dec (fun '(n, d) => div_num n d).
  Proof.
    intros [G Hg] [eq]%Discrete_sum.
    pose (g n := match G n with None => i0 | Some d => d end).
    constructor. intros [n d].
    destruct (eq d i0) as [->|h].
    { left; exists i0. now rewrite mult_zero_r. }
    destruct n as [|n].
    { right; intros [k Hk]. rewrite mult_zero in Hk; auto. }
    refine (let H' := @iEuclid' D I axioms d (S n) _ in _).
    assert (exists q r, r < S n /\ d = (g q) i⊗ inu (S n) i⊕ inu r) as H.
    { destruct H' as [Q [r ]], (Hg Q) as [q Hq].
      exists q, r. unfold g. now rewrite Hq.
    } clear H'.
    apply ProductWO in H.
    destruct H as [q [r [? Hr]]].
    * destruct (eq_dec r 0) as [E|E].
      + left. exists (g q).
        now rewrite Hr, E, add_zero_r, mult_comm.
      + right. intros [k Hk]. apply E.
        enough (iE : inu r = inu 0).
        { now apply inu_inj in iE. }
        enough ((g q) = k /\ inu r = inu 0) by tauto.
        unshelve eapply (iFac_unique _ _ (inu (S n))).
        -- apply axioms.
        -- apply lt_equiv; auto.
        -- apply lt_equiv; auto. lia.
        -- now rewrite add_zero, add_comm, <-Hr, mult_comm.
    * intros x y. apply dec_conj; [apply lt_dec|apply eq].
    Unshelve. lia.
  Qed.

  (*  We can show the same for types that are witnessing and discrete.
      This is a bit more general, since every enumerable type is witnessing.
   *)
  Lemma dec_div_2 :
    Witnessing D -> Discrete D -> Dec (fun '(n, d) => div_num n d).
  Proof.
    intros wo [eq]%Discrete_sum.
    constructor. intros [n d].
    destruct (eq d i0) as [->|h].
    { left; exists i0. now rewrite mult_zero_r. }
    destruct n as [|n].
    { right; intros [k Hk]. rewrite mult_zero in Hk; auto. }
    refine (let H := @iEuclid' D I axioms d (S n) _ in _).
    apply wo in H.
    - destruct H as [a Ha].
      apply Witnessing_nat in Ha.
      * destruct Ha as [r [? Hr]].
        destruct (eq_dec r 0) as [E|E].
        + left. exists a.
          now rewrite Hr, E, add_zero_r, mult_comm.
        + right. intros [k Hk]. apply E.
          enough (iE : inu r = inu 0).
          { now apply inu_inj in iE. }
          enough (a = k /\ inu r = inu 0) by tauto.
          unshelve eapply (iFac_unique _ _ (inu (S n))).
          -- apply axioms.
          -- now apply lt_equiv.
          -- apply lt_equiv; auto. lia.
          -- now rewrite add_zero, add_comm, <-Hr, mult_comm.
      * intros x. apply dec_conj; [apply lt_dec|apply eq].
    - intros ?. apply dec_lt_bounded_exist.
      intros ?. apply eq.
    Unshelve. lia.
  Qed.

  (** * Tennenbaum's Theorem via a diagnoal argument. *)

  Fact dec_contraposition A B :
    dec B -> (~B -> ~A) -> (A -> B).
  Proof. intros HB nB a. destruct HB; tauto. Qed.

  (*  This lemma is similar to the coding lemmas in Coding.v as
      it allows decidable predicates to be coded.
   *)
  Lemma Coding_Dec p :
    CT_Q -> Stable std -> ~ stdModel D ->
    Dec p -> ~~ exists c, forall n, p n <-> div_pi n c.
  Proof.
    intros rt%CT_RTs ? notStd Dec_p.
    destruct (rt _ Dec_p) as [ϕ (b1 & _ & H1 & H2)].
    unshelve refine (let H:= Coding_nonStd_unary _ _ _ _ Hψ _ _ (∃ ϕ) _ in _); auto.
    - now solve_bounds.
    - apply (DN_chaining H), DN; clear H.
      intros [c Hc].
      exists c; intros n. split.
      + intros H. specialize (Hc n (fun _ => c)) as [Hc1 _].
        apply H1 in H. apply soundness in H.
        unfold div_pi.
        eapply bound_ext with (N:= 2)(sigma:= inu n .: c .: (fun _ => c)).
        { repeat solve_bounds.
          eapply bounded_up; [apply Hψ|lia]. }
        { intros [|[]]; cbn; [reflexivity|reflexivity|lia]. }
        cbn in Hc1; apply Hc1.
        destruct (H D I (fun _ => c)) as [d Hd].
        intros ??; apply axioms; now constructor.
        exists d. rewrite <-switch_up_num.
        eapply bound_ext with (N:=1). 3: apply Hd.
        eapply subst_bound. 1: eauto.
        intros [|[]]; solve_bounds.
        cbn. rewrite num_subst. apply closed_num.
        intros [|]; solve_bounds.
      + specialize (Hc n (fun _ => c)) as [_ Hc2].
        destruct (Dec_p) as [dec_p]; auto.
        apply dec_contraposition; [apply dec_p|].
        intros h [d Hd].
        specialize (H2 _ h). apply soundness in H2.
        eapply H2 with (rho := fun _ => i0); fold sat.
        intros ??; apply axioms; now constructor.
        setoid_rewrite switch_num. cbn in Hc2.
        eapply bound_ext with (N:= 1)(sigma:= inu n .: c .: (fun _ => c)).
        { now solve_bounds. }
        intros []; cbn; [reflexivity|lia].
        apply Hc2. exists d. split.
        { eapply bound_ext. apply Hψ. 2: apply Hd.
          intros [|[]]; cbn; [reflexivity|reflexivity|lia]. }
        destruct Hd as [_ [k Hk]]. exists k.
        now rewrite Hk.
  Qed.

  (*  We can now use the above coding lemma in combination with RT
      to give a diagonal argument which shows that enumerable and
      discrete PA models must potentially be standard.
      The double negation can actually also be eliminated, and this
      is done in Variants.v, where the needed lemmas are shown.
   *)
  Theorem Tennenbaum_diagonal :
    CT_Q -> MP -> Enumerable D -> Discrete D -> ~~ forall e, std e.
  Proof.
    intros ct mp enum eq notStd.
    specialize (dec_div enum eq) as [dec_div].
    specialize enum as [G HG].
    pose (g n := match G n with None => i0 | Some d => d end).
    pose (p n := ~ div_pi n (g n)).
    apply (Coding_Dec p); auto.
    - intros e. apply MP_Dec_stable; auto.
      apply Discrete_sum in eq.
      destruct eq as [eq].
      constructor. intros n. apply eq.
    - unfold p. constructor. intros n.
      destruct (dec_div (Irred n, g n)) as [h|nh].
      + right. apply DN. now apply ψ_equiv.
      + left. intros ?. apply nh. eapply ψ_equiv; eauto.
    - intros [c' H]. destruct (HG c') as [c Hc].
      specialize (H c). revert H.
      unfold p, g. rewrite Hc.
      tauto.
  Qed.

  (*  We can still establish the same result, with the weaker
      assumption of WCT_Q.
   *)
  Theorem Tennenbaum_diagonal' :
    WCT_Q -> MP -> Enumerable D -> Discrete D -> ~ exists e, ~std e.
  Proof.
    intros wrt%WCT_WRTs mp enum eq.
    specialize (dec_div enum eq) as [dec_div].
    specialize enum as [G HG].
    apply Discrete_sum in eq.
    pose (g n := match G n with None => i0 | Some d => d end).
    pose (p n := ~ div_pi n (g n)).
    enough (Dec p) as Dec_p.
    apply (DN_remove (wrt _ Dec_p)).
    intros [ϕ (b1 & _ & H1 & H2)] nonStd.
    unshelve refine (let H:= Coding_nonStd_unary _ _ _ _ Hψ _ _ (∃ ϕ) _ in _); auto.
    - now apply nonStd_notStd.
    - intros e. apply MP_Dec_stable; auto.
      destruct eq as [eq]. constructor. intros n. apply eq.
    - now solve_bounds.
    - enough (~~False) by tauto.
      apply (DN_chaining H), DN.
      intros [cp Hcp]; clear H.
      destruct (HG cp) as [c Hc].
      specialize (Hcp c (fun _ => g c)) as [Hc1 Hc2].
      destruct Dec_p as [Dec_p], (Dec_p c) as [h|h].
      * specialize (H1 _ h). apply soundness in H1.
        apply h. unfold div_pi.
        eapply bound_ext with (N:= 2)(sigma:= inu c .: cp .: (fun _ => g c)).
        { repeat solve_bounds.
          eapply bounded_up; [apply Hψ|lia]. }
        { intros [|[]]; cbn; [reflexivity| |lia].
          intros _. unfold g. now rewrite Hc. }
        cbn in Hc1; apply Hc1.
        destruct (H1 D I (fun _ => g c)) as [d Hd].
        intros ??; apply axioms; now constructor.
        exists d. rewrite <-switch_up_num.
        eapply bound_ext with (N:=1). 3: apply Hd.
        eapply subst_bound. 1: eauto.
        intros [|[]]; solve_bounds.
        cbn. rewrite num_subst. apply closed_num.
        intros [|]; solve_bounds.
      * specialize (H2 _ h). apply soundness in H2.
        apply h. intros H'. eapply H2 with (rho := fun _ => i0); fold sat.
        intros ??; apply axioms; now constructor.
        setoid_rewrite switch_num. cbn in Hc2.
        eapply bound_ext with (N:= 1)(sigma:= inu c .: cp .: (fun _ => g c)).
        { now solve_bounds. }
        intros []; cbn; [reflexivity|lia].
        apply Hc2. destruct H' as [d Hd].
        exists d. split.
        { eapply bound_ext. apply Hψ. 2: apply Hd.
          intros [|[]]; cbn; [reflexivity|reflexivity|lia]. }
        destruct Hd as [_ [k Hk]]. exists k.
        rewrite Hk; cbn. unfold g. now rewrite Hc.
    - unfold p. constructor. intros n.
      destruct (dec_div (Irred n, g n)) as [h|nh].
      + right. apply DN. now apply ψ_equiv.
      + left. intros ?. apply nh. eapply ψ_equiv; eauto.
  Qed.

End Model.


Require Import ssr.
Require Import lib.
Require Import ring.
Require Import nzring.
Require Import poly.
Require Import poly2.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope nati_scope.
Open Scope poly_scope.
Open Scope ring_scope.

(* ========================================================================== *)
(*  Division, Roots and Euclidean structure                                   *)
(* ========================================================================== *)

Section Div.

Variable F : nzfield.

Definition poly := (poly_idom F).

Notation X := (X F:poly_ring F).

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

Fixpoint div_alg_aux (n:nat) (f g : poly) {struct n} : poly * poly :=
  if n is S n' then
    if deg f < (deg g + Nat n')%I then div_alg_aux n' f g
    else
      let s := const (lc f * (lc g)^-1) * powX _ n' in
      let (q,r) := div_alg_aux n' (f - s * g) g in
        (q + s,r)
  else (0,f).

Definition div_alg f g :=
  match (S' (deg f) - deg g)%I with
    | -oo => (0,0)
    | Nat n => div_alg_aux n f g
  end.

Definition quo (f g : poly) := fst (div_alg f g).
Definition rem (f g : poly) := snd (div_alg f g).

(* ------------------  Lemma instances for weak rewriting  ------------------ *)

Lemma pone : (Nz (one_nz F):F) = 1. Proof. done. Qed.

Lemma addr0' : forall x: poly, x + 0 = x.
Proof. exact: addr0. Qed.

Lemma lc_mul : forall p q : poly, lc (p * q) = lc p * lc q.
Proof. exact: lc_mul. Qed.

Lemma nz_lc : forall p : polynz F, lc (Nz p) = Nz (lc_nz p).
Proof. done. Qed.

Lemma deg_opp : forall p : poly, deg (- p) = deg p.
Proof. exact: deg_opp. Qed.

Lemma lc_opp : forall p : poly, lc (- p) = - lc p.
Proof. exact: lc_opp. Qed.

Lemma leqi_add_sub : forall n m : nati, n <> -oo -> n <= m -> (n + (m - n))%I = m.
Proof. by move=> [|n] [|m] //= _ H; rewrite leq_add_sub. Qed.

Lemma deg_mul : forall p q : poly, deg (p * q) = (deg p + deg q)%I.
Proof. exact: deg_mul. Qed.

Lemma mul0r' : forall x : poly, 0 * x = 0.
Proof. exact: mul0r. Qed.

Lemma mulC' : forall x y : poly, x * y = y * x.
Proof. exact: mulC. Qed.

Lemma add_unevenL : forall p1 p2 : poly, deg p2 < deg p1 -> deg (p1 + p2) = deg p1.
Proof. exact: add_unevenL. Qed.

Lemma mulr0' : forall p : poly, p * 0 = 0. Proof. exact: mulr0. Qed.

Lemma poly_ind : forall (P : poly -> Prop),
   P 0 -> (forall (c : F) (p : poly), P p -> P (const c + (poly2.X F) * p))
        -> (forall (p : poly), P p).
Proof. exact: poly_ind. Qed.

Definition invL := @invL (field_of_nzfield F).
Definition invR := @invR (field_of_nzfield F).
Definition integ := @integ (field_of_nzfield F).

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

Inductive div_spec (f g : poly) : poly * poly -> Type :=
  | DivSpec (q r : poly) : f = q * g + r -> deg r < deg g -> div_spec f g (q,r).

Lemma div_correct :
  forall f g : poly, g <> 0 -> div_spec f g (div_alg f g).
Proof.
 (* {{{ *)
move=> f g.
case Dg : {1}g => [|g'] => [[//]|_].
rewrite /div_alg.
case Dn : (_ - _)%I => [|n].
  rewrite Dg in Dn *.
  by case: f Dn => [|f'].
have {Dn} : deg f < (deg g + Nat n)%I.
  case: (deg f) Dn => [|df] // <-.
  by rewrite Dg /= -leq_sub_add leqnn.
elim: n f => [|n IH] f.
  rewrite Dg /= addn0.
  by split.
move=> Hfg /=.
case Hn : (_ < _).
  auto.
case Df : {1}f Hn => [|f'] Hn; first by rewrite Dg in Hn.
have Hd : deg f = (deg g + Nat n)%I.
  move: Hn Hfg.
  rewrite Dg Df /= => Hn.
  rewrite addnS ltnS leq_eqVlt Hn orbF.
  by move/eqP => ->.
case: IH => [|q r Hqr Hr].
  rewrite -Hd addC.
  apply: lc_cancel.
  - by rewrite Df.
  - rewrite deg_opp !deg_mul deg_powX deg_const Dg Df /=.
    rewrite /mulr /=.
    case H : (nzring.mul_nz _ _) => [|k].
      contradiction (mul_nz_nz H).
    rewrite add0i.
    by rewrite Df Dg /= addnC in Hd.
  - rewrite lc_opp !lc_mul lc_const lc_powX mulr1 Dg nz_lc.
    by rewrite -mulA invL ?mulr1.
split => //.
by rewrite distPM -addA [_ + r]addC addA -[_ + r]Hqr -addA oppL addr0.
 (* }}} *)
Qed.

Lemma quoP : forall f g, f = quo f g * g + rem f g.
Proof.
 (* {{{ *)
move=> f [|g].
  by case: f.
rewrite /quo /rem.
by case: div_correct.
 (* }}} *)
Qed.

Lemma remP : forall f g, g <> 0 -> deg (rem f g) < deg g.
Proof.
 (* {{{ *)
move=> f g Hg.
rewrite /rem.
by case: div_correct.
 (* }}} *)
Qed.

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

Lemma div_const : forall (c : F) f, c <> 0 -> const c |` f.
Proof.
 (* {{{ *)
move=> [|c] f; first by move/eqP; rewrite eq_refl.
move=> _; exists (const (Nz c : F)^-1 * f).
rewrite mulA const_mul invR //.
rewrite /mulr /=.
case: f => [|f'] //.
by rewrite cmulnz1.
 (* }}} *)
Qed.

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

(* euclid_aux _ f g = (d,a,b) means d is the gcd of f,g,
   and a * f + b * g = d *)
Fixpoint euclid_aux (n:nat) (f g : poly) {struct n} : poly * poly * poly:=
  if n is S n' then
    match div_alg f g with
      | (_,Zero) => (g,0,1)
      | (q,r) => let: (d,a,b) := euclid_aux n' g r in (d,b,a - b * q)
    end
  else (g,0,1).

Definition euclid f g :=
  match deg g with
    | -oo => (0,0,0)
    | Nat n => euclid_aux (S n) f g
  end.

Hint Resolve div_refl.

Inductive gcd (f g d : poly) : Type :=
  Gcd : (d |` f) -> (d |` g) ->
       (forall d', (d' |` f) -> (d' |` g) -> (d' |` d)) -> gcd f g d.

Inductive euclid_spec (f g : poly) : poly * poly * poly -> Type :=
  | EuclidSpec (d a b : poly) :
    gcd f g d -> a * f + b * g = d -> euclid_spec f g (d,a,b).

Lemma euclid_correct :
  forall f g : poly, g <> 0 -> euclid_spec f g (euclid f g).
Proof.
 (* {{{ *)
move=> f [|g] => [[] //|_]; rewrite /euclid /deg.
elim: {g}(S (deg_nz g)) f {-2 4}g (ltnSn (deg_nz g)) => [|n IH] f g //= Hn.
case: div_correct => // q [|r] Hqr Hqr'.
  split; try split; rewrite ?div_refl => //.
    by exists q; rewrite mulC' Hqr addr0'.
  by rewrite mul1r mul0r' add0r.
case: IH => [|d a b [Hdg Hdr Hrgd] Ed]; first exact: leq_trans Hqr' Hn.
have Ed': b * f + (a - b * q) * Nz g = d.
  by rewrite Hqr distMP distPM mulA addA addC !addA mul_oppL oppL add0r addC.
by move: div_add div_mulR; do 2!split => // *; [rewrite Hqr | rewrite -Ed']; auto.
 (* }}} *)
Defined.

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

Definition root (p : poly) x := p @ x == 0.

Lemma root_const : forall (c x : F), root (const c) x -> (c == 0).
Proof.  by case. Qed.

Lemma root_prod : forall (p q : poly) x, root (p * q) x -> root p x || root q x.
Proof.
 (* {{{ *)
move=> p q x.
rewrite /root; move/eqP.
rewrite /= evalp_mul.
by move/integ => [|] ->; rewrite eq_refl // orbT.
 (* }}} *)
Qed.

Lemma rootX : forall x, root X x -> x = 0.
Proof.  by move=> x; rewrite /root /= pone mulr1 add0r; move/eqP. Qed.

(* --------------------------  The Main Theorems  --------------------------- *)

Definition evalp_add := @evalp_add F.
Definition evalp_mul := @evalp_mul F.
Definition evalp_const := @evalp_const F.

Theorem remainder_thm : forall f b,
  rem f ((X:poly_ring F) - const b) = const (f @ b).
Proof.
 (* {{{ *)
move=> f b.
move: (@remP f (X - const b) (@linear_nz _ _)).
move: (@quoP f (X - const b)).
set p := (X - const b).
have -> : (deg p = Nat (S O)).
  rewrite /p add_unevenL // deg_opp deg_const /=.
  by case b.
move=> H1 H2.
move: {H2}(deg_lt1 H2) => [r Hr].
rewrite Hr.
rewrite Hr in H1.
move: {H1}(congr1 (fun x => evalp x b) H1).
rewrite /p.
by rewrite !evalp_add !evalp_const !evalp_mul evalp_root mulr0 /= => ->.
 (* }}} *)
Qed.

Theorem root_div1 : forall f x, root f x -> rdivides (X - const x) f.
Proof.
 (* {{{ *)
move=> f x.
rewrite /root /divides.
move/eqP => Hx.
exists (quo f (X - const x)).
move: (@quoP f (X - const x)).
rewrite remainder_thm Hx const0 addr0'.
move=> H.
symmetry.
by rewrite mulC'.
 (* }}} *)
Qed.

Theorem root_div2 : forall f x, rdivides (X - const x) f -> root f x.
Proof.
 (* {{{ *)
move=> f x.
rewrite /root /divides. (* XXX can't have the next line here??? *)
move=> [b <-].
by rewrite evalp_mul evalp_root.
 (* }}} *)
Qed.

(* ------------------------------  more roots  ------------------------------ *)

Lemma root_linear : forall x y : F, root (X + const x) y -> y = -x.
Proof.
 (* {{{ *)
move=> x y.
move/root_div1 => [q Hq].
have Hq1 : deg q = Nat O.
  move/(congr1 (@deg _)): (Hq).
  rewrite deg_mul const_opp !deg_linear /=.
  case H : (deg q) => [|k] //=.
  by case: k H.
move/deg0: Hq1 => [H1 [c Hc2]].
move: Hq.
rewrite Hc2 distPM const_opp const_mul.
rewrite addC [_ + const x]addC.
rewrite -{2}(mulr1 X).
move=> H.
have Hc : c = 1.
  move: (congr1 (fun p => coef p 1%nat) H).
  by rewrite -!hornerP !coef_horner /= coef_const.
rewrite Hc const1 !mulr1 in H.
move/(congr1 (fun x => x + (- X))) : H.
rewrite -!addA !oppR !addr0 => H.
move: (congr1 (fun p => coef p O) H).
rewrite !coef_const => <-.
by rewrite opp_opp.
 (* }}} *)
Qed.

Theorem root_bound : forall n (p : poly), deg p = Nat n -> forall l, all (root p) l -> uniq l -> (size l <= n)%N.
Proof.
 (* {{{ *)
elim=> [|n IH] p //=.
  move/deg0 => [H1 [c Hc]].
  rewrite Hc.
  case => [|x l] //=.
  move/andP => [H2 H3].
  move/root_const: H2.
  move/eqP => H.
  by rewrite H /= in Hc.
move=> Hp [|x l] //=.
move/andP => [H1 H2].
move/andP => [H3 H4].
move/root_div1: H1 => [q Hq].
move: (congr1 (@deg _) Hq).
rewrite deg_mul const_opp deg_linear => H.
have Hq1 : deg q = Nat n.
  rewrite {}Hp in H.
  case: {Hq} q H => [|q] //=.
  by move=> [->].
move: {IH Hq1} (IH _ Hq1) => IH.
rewrite leqSS.
suffices Hq2 : all (root q) l by auto.
move: {IH H} H2.
rewrite -{}Hq => H.
apply/allP => y Hy.
move/allP: (Hy) => T.
move/T: H.
move/root_prod.
move/orP => [|] //.
rewrite const_opp.
move/root_linear.
rewrite opp_opp => H.
case : H3.
by rewrite -H Hy.
 (* }}} *)
Qed.

(* ----------------------------  Euclidean Ring  ---------------------------- *)

Definition poly_id := idom_of_nzring (poly_idom F).

Definition poly_ering : euclid_ring.
 (* {{{ *)
exists poly_id (@deg F).
- exact: degInf.
- by move=> x ->.
- move=> a [|b] // _.
  exact: deg_mulL.
move=> a [|b] // _.
set q := quo a (Nz b).
set r := rem a (Nz b).
apply: (@Div_res poly_id _ _ _ q r).
  exact: quoP.
exact: remP.
 (* }}} *)
Defined.

End Div.

Section Euclid.

Variable F : nzfield.

Notation poly := (poly_ering F).

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

Definition is_const (p : poly) := exists c : F, c <> 0 /\ p = const c.

Definition irr (p : poly) := forall p1 p2, p = p1 * p2 -> deg p1 = Nat O \/ deg p2 = Nat O.

Definition deg_mul' := @deg_mul F.
Definition invR' := @invR F.

Lemma addi_eq0 : forall x y, (x + y)%I = Nat O -> x = Nat O /\ y = Nat O.
Proof. by move=> [|[|x]] [|[|y]]. Qed.

Definition const_mul := @const_mul F.
Lemma unit_const : forall p : poly, unit p <-> is_const p.
Proof.
 (* {{{ *)
move=> p.
split.
  move=> [q Hq].
  move: (congr1 deg Hq).
  rewrite deg_mul' /=.
  move/addi_eq0 => [H1 _].
  move/deg0: H1 => [H [c Hc]].
  exists c; split => //.
  move=> H'.
  by rewrite H' const0 in Hc.
move=> [c [Hc ->]].
rewrite /unit.
exists (const c^-1).
by rewrite const_mul invR'.
 (* }}} *)
Qed.

Lemma irr_prime : forall p : poly_ering F, (~ is_const p /\ irr p) <-> prime p.
Proof.
 (* {{{ *)
move=> p.
rewrite /irr /prime.
split.
  move=> [H1 H].
  split.
    by move/unit_const.
  move=> x y Hxy.
  move: (H x y).
  apply: antsE; first by symmetry.
  move=>[|].
    move/deg0 => [H2 [c Hc]].
    rewrite Hc in H2 *.
    left.
    exists (const c^-1).
    rewrite const_mul invR' //.
    move=> Hc'.
    by rewrite Hc' in H2.
  move/deg0 => [H2 [c Hc]].
  rewrite Hc in H2 *.
  right.
  exists (const c^-1).
  rewrite const_mul invR' //.
  move=> Hc'.
  by rewrite Hc' in H2.
move=> [H1 H2].
split.
  by move/unit_const.
move=> q r H.
rewrite H in H2.
move: (H2 q r).
apply: antsE => //.
move=> [|].
  move/unit_const => [c [Hc Hc']].
  rewrite Hc'; left.
  rewrite deg_const.
  by case: c Hc Hc'.
move/unit_const => [c [Hc Hc']].
rewrite Hc'; right.
rewrite deg_const.
by case: c Hc Hc'.
 (* }}} *)
Qed.

Lemma irr0 : ~ irr 0.
Proof.
 (* {{{ *)
rewrite /irr.
move=> H.
move: (H 0 0).
apply: antsE; first by rewrite mulr0.
by move=> [|].
 (* }}} *)
Qed.

End Euclid.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.