Require Import axiom.axiom.
Require Import axiom.logic.
Require Import operation.basic.
Require Import relation.relation.
Require Import relation.function.
Require Import relation.util_function.
Require Import relation.equiv.
Require Import nat.inductive.
Require Import nat.nat.
Require Import nat.recursion.
Require Import nat.nat_arith.
Require Import nat.order.
Require Import int.int.

(* Order *)
Definition int_less_rel :=
  subset_ctor (fun x => exists m n p q, m ∈ ω /\ n ∈ ω /\ p ∈ ω /\ q ∈ ω /\
    x = ⟨int m n , int p q⟩ /\ ((m +ₙ q) <ₙ (n +ₙ p))) (cp ℤ ℤ).

Notation "m <z n" := (⟨m, n⟩ ∈ int_less_rel) (at level 65, no associativity).

Lemma int_less_elim_1: forall x y, x ∈ ℤ -> y ∈ ℤ -> x <z y ->
  exists m n p q, m ∈ ω /\ n ∈ ω /\ p ∈ ω /\ q ∈ ω /\
    x = int m n /\ y = int p q /\ (m +ₙ q) <ₙ (n +ₙ p).
Proof.
  intros x y P1 P2 P3.
  destruct (subset_elim _ _ _ P3) as [P4 [m [n [p [q [Q1 [Q2 [Q3 [Q4 [P5 P6]]]]]]]]]].
  exists m. exists n. exists p. exists q.
  repeat split.
  all: is_nat.
  + apply (opair_equal_elim_fst _ _ _ _ P5).
  + apply (opair_equal_elim_snd _ _ _ _ P5).
Qed.

Lemma int_less_elim_2: forall m n p q, m ∈ ω -> n ∈ ω -> p ∈ ω -> q ∈ ω ->
  int m n <z int p q -> (m +ₙ q) <ₙ (n +ₙ p).
Proof.
  intros m n p q P1 P2 P3 P4 P5.
  destruct (int_less_elim_1 _ _ (int_ctor_is_int _ _ P1 P2)
    (int_ctor_is_int _ _ P3 P4) P5)
    as [m2 [n2 [p2 [q2 [R1 [R2 [R3 [R4 [P6 [P7 P8]]]]]]]]]].
  pose (int_equal_elim _ _ _ _ P1 P2 P6) as Q1.
  pose (int_equal_elim _ _ _ _ P3 P4 P7) as Q2.
  symmetry in Q2.
  pose (add_equation _ _ _ _ Q1 Q2) as Q3.
  rewrite (add_associative (m +ₙ n2) q p2) in Q3.
  rewrite (add_cyc m n2 q) in Q3.
  rewrite <- (add_associative (m +ₙ q) n2 p2) in Q3.
  rewrite (add_associative (n +ₙ m2) p q2) in Q3.
  rewrite (add_cyc n m2 p) in Q3.
  rewrite <- (add_associative (n +ₙ p) m2 q2) in Q3.
  rewrite (add_commutative (m +ₙ q) (n2 +ₙ p2)) in Q3.
  rewrite (add_commutative (n +ₙ p) (m2 +ₙ q2)) in Q3.
  symmetry in Q3.
  apply (equal_less_less (m2 +ₙ q2) (n2 +ₙ p2) _ _).
  all: is_nat_z4.
Qed.

Lemma int_less_intro: forall m n p q, m ∈ ω -> n ∈ ω -> p ∈ ω -> q ∈ ω ->
  (m +ₙ q) <ₙ (n +ₙ p) -> int m n <z int p q .
Proof.
  intros m n p q P1 P2 P3 P4 P5.
  apply (subset_intro).
  + is_nat_z3.
  + exists m. exists n. exists p. exists q.
    repeat split.
    all: is_nat.
Qed.

Lemma int_less_trans: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
 m <z n -> n <z l -> m <z l.
Proof.
  intros m n l P1 P2 P3 P4 P5.
  destruct (int_less_elim_1 _ _ P1 P2 P4) as
    [q1 [q2 [r1 [r2 [Q1 [Q2 [R1 [R2 [Q3 [R3 P6]]]]]]]]]].
  destruct (int_less_elim_1 _ _ P2 P3 P5) as
    [s1 [s2 [t1 [t2 [S1 [S2 [T1 [T2 [S3 [T3 P7]]]]]]]]]].
  rewrite R3 in S3.
  pose (int_equal_elim _ _ _ _ R1 R2 S3) as P8.
  rewrite Q3.
  rewrite T3.
  pose (less_add_eq _ _ _
    (add_is_nat _ _ Q1 R2) (add_is_nat _ _ Q2 R1)
    (add_is_nat _ _ S2 T2) P6) as P9.
  rewrite (add_associative (q2 +ₙ r1) s2 t2) in P9.
  rewrite <- (add_associative q2 r1 s2) in P9.
  rewrite (add_commutative q2 (r1 +ₙ s2)) in P9.
  rewrite <- (add_associative (r1 +ₙ s2) q2 t2) in P9.
  rewrite (add_commutative s2 t2) in P9.
  rewrite (add_associative (q1 +ₙ r2) t2 s2) in P9.
  rewrite (add_cyc q1 r2 t2) in P9.
  rewrite <- (add_associative (q1 +ₙ t2) r2 s2) in P9.

  pose (less_add_eq _ _ _
    (add_is_nat _ _ S1 T2) (add_is_nat _ _ S2 T1)
    (add_is_nat _ _ R2 Q2) P7) as P10.
  rewrite (add_associative (s1 +ₙ t2) r2 q2) in P10.
  rewrite (add_cyc s1 t2 r2) in P10.
  rewrite <- (add_associative (s1 +ₙ r2) t2 q2) in P10.
  rewrite (add_commutative s1 r2) in P10.
  rewrite (add_commutative t2 q2) in P10.
  rewrite (add_commutative r2 q2) in P10.
  rewrite (add_associative (s2 +ₙ t1) q2 r2) in P10.
  rewrite <- (add_associative s2 t1 q2) in P10.
  rewrite (add_commutative s2 (t1 +ₙ q2)) in P10.
  rewrite <- (add_associative (t1 +ₙ q2) s2 r2) in P10.
  rewrite (add_commutative t1 q2) in P10.
  rewrite (add_commutative s2 r2) in P10.
  rewrite <- P8 in P10.
  apply int_less_intro.
  all: is_nat.
  apply (less_add_cancellation _ _ (r2 +ₙ s2)).
  all: is_nat.
  apply (less_less_less _ ((r1 +ₙ s2) +ₙ (q2 +ₙ t2)) _).
  all: is_nat.
Qed.

Lemma int_not_less_self: forall m, m ∈ ℤ -> ~(m <z m).
Proof.
  intros m P1 P2.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  rewrite Q3 in P2.
  pose (int_less_elim_2 _ _ _ _ Q1 Q2 Q1 Q2 P2) as P3.
  rewrite (add_commutative _ _ Q1 Q2) in P3.
  apply (nat_not_in_self _ (add_is_nat _ _ Q2 Q1) P3).
Qed.

Lemma int_trichotomy: forall m n, m ∈ ℤ -> n ∈ ℤ ->
  ((m <z n) /\ ~(m = n) /\ ~(n <z m)) \/
  (~(m <z n) /\ (m = n) /\ ~(n <z m)) \/
  (~(m <z n) /\ ~(m = n) /\ (n <z m)).
Proof.
  intros m n P1 P2.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  rewrite Q3.
  rewrite R3.
  destruct (nat_trichotomy (qm +ₙ rn) (qn +ₙ rm)
    (add_is_nat _ _ Q1 R2) (add_is_nat _ _ Q2 R1))
      as [[P3 [P4 P5]] | [[P3 [P4 P5]] | [P3 [P4 P5]]]].
  + left.
    repeat split.
    - apply int_less_intro.
      all: is_nat.
    - intros P6.
      pose (int_equal_elim _ _ _ _ Q1 Q2 P6) as P7.
      contradiction.
    - intros P6.
      pose (int_less_elim_2 _ _ _ _ R1 R2 Q1 Q2 P6) as P7.
      rewrite (add_commutative _ _ Q2 R1) in P5.
      rewrite (add_commutative _ _ Q1 R2) in P5.
      contradiction.
  + right. left.
    repeat split.
    - intros P6.
      pose (int_less_elim_2 _ _ _ _ Q1 Q2 R1 R2 P6) as P7.
      contradiction.
    - apply (int_equal_intro _ _ _ _ Q1 Q2 R1 R2 P4).
    - intros P6.
      pose (int_less_elim_2 _ _ _ _ R1 R2 Q1 Q2 P6) as P7.
      rewrite (add_commutative _ _ Q2 R1) in P5.
      rewrite (add_commutative _ _ Q1 R2) in P5.
      contradiction.
  + right. right.
    repeat split.
    - intros P6.
      pose (int_less_elim_2 _ _ _ _ Q1 Q2 R1 R2 P6) as P7.
      contradiction.
    - intros P6.
      pose (int_equal_elim _ _ _ _ Q1 Q2 P6) as P7.
      contradiction.
    - rewrite (add_commutative _ _ Q2 R1) in P5.
      rewrite (add_commutative _ _ Q1 R2) in P5.
      apply int_less_intro.
      all: is_nat.
Qed.

Lemma int_less_add_equal: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  m <z n -> (m +z l) <z (n +z l).
Proof.
  intros m n l P1 P2 P3 P4.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  rewrite Q3 in P4.
  rewrite R3 in P4.
  pose (int_less_elim_2 _ _ _ _ Q1 Q2 R1 R2 P4) as P5.
  rewrite Q3.
  rewrite R3.
  rewrite S3.
  rewrite (int_add_elim qm qn sm sn).
  rewrite (int_add_elim rm rn sm sn).
  apply int_less_intro.
  all: is_nat.
  rewrite (add_associative (qm +ₙ sm) rn sn).
  rewrite (add_cyc qm sm rn).
  rewrite <- (add_associative (qm +ₙ rn) sm sn).
  rewrite (add_associative (qn +ₙ sn) rm sm).
  rewrite (add_cyc qn sn rm).
  rewrite <- (add_associative (qn +ₙ rm) sn sm).
  rewrite (add_commutative sn sm).
  apply (less_add_eq).
  all: is_nat.
Qed.

Lemma int_less_multi_equal: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  z.0 <z l -> m <z n -> (m ×z l) <z (n ×z l).
Proof.
  intros m n l P1 P2 P3 P4 P5.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  rewrite S3 in P4.
  pose (int_less_elim_2 _ _ _ _ empty_is_nat empty_is_nat S1 S2 P4) as P6.
  rewrite Q3 in P5.
  rewrite R3 in P5.
  pose (int_less_elim_2 _ _ _ _ Q1 Q2 R1 R2 P5) as P7.
  rewrite Q3.
  rewrite R3.
  rewrite S3.
  rewrite (int_multi_elim qm qn sm sn).
  rewrite (int_multi_elim rm rn sm sn).
  apply int_less_intro.
  all: is_nat.
  rewrite (add_zero_l sn) in P6.
  rewrite (add_zero_l sm) in P6.
  rewrite <- (add_associative (qm ×ₙ sm) (qn ×ₙ sn) ((rm ×ₙ sn) +ₙ (rn ×ₙ sm))).
  rewrite (add_associative (qn ×ₙ sn) (rm ×ₙ sn) (rn ×ₙ sm)).
  rewrite (add_commutative (qn ×ₙ sn +ₙ rm ×ₙ sn) (rn ×ₙ sm)).
  rewrite (add_associative (qm ×ₙ sm) (rn ×ₙ sm) (qn ×ₙ sn +ₙ rm ×ₙ sn)).
  rewrite <- (distributive_r qm rn sm).
  rewrite <- (distributive_r qn rm sn).
  rewrite <- (add_associative (qm ×ₙ sn) (qn ×ₙ sm) ((rm ×ₙ sm) +ₙ (rn ×ₙ sn))).
  rewrite (add_associative (qn ×ₙ sm) (rm ×ₙ sm) (rn ×ₙ sn)).
  rewrite (add_commutative (qn ×ₙ sm +ₙ rm ×ₙ sm) (rn ×ₙ sn)).
  rewrite (add_associative (qm ×ₙ sn) (rn ×ₙ sn) (qn ×ₙ sm +ₙ rm ×ₙ sm)).
  rewrite <- (distributive_r qm rn sn).
  rewrite <- (distributive_r qn rm sm).
  apply order_inequation.
  all: is_nat.
Qed.

Lemma int_less_multi_equal_rev: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  l <z z.0 -> m <z n -> (n ×z l) <z (m ×z l).
Proof.
  intros m n l P1 P2 P3 P4 P5.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  rewrite S3 in P4.
  pose (int_less_elim_2 _ _ _ _ S1 S2 empty_is_nat empty_is_nat P4) as P6.
  rewrite Q3 in P5.
  rewrite R3 in P5.
  pose (int_less_elim_2 _ _ _ _ Q1 Q2 R1 R2 P5) as P7.
  rewrite Q3.
  rewrite R3.
  rewrite S3.
  rewrite (int_multi_elim qm qn sm sn).
  rewrite (int_multi_elim rm rn sm sn).
  apply int_less_intro.
  all: is_nat.
  rewrite (add_zero sn) in P6.
  rewrite (add_zero sm) in P6.
  rewrite <- (add_associative (rm ×ₙ sm) (rn ×ₙ sn) ((qm ×ₙ sn) +ₙ (qn ×ₙ sm))).
  rewrite (add_associative (rn ×ₙ sn) (qm ×ₙ sn) (qn ×ₙ sm)).
  rewrite (add_commutative (rn ×ₙ sn +ₙ qm ×ₙ sn) (qn ×ₙ sm)).
  rewrite (add_associative (rm ×ₙ sm) (qn ×ₙ sm) (rn ×ₙ sn +ₙ qm ×ₙ sn)).
  rewrite <- (distributive_r rm qn sm).
  rewrite <- (distributive_r rn qm sn).
  rewrite <- (add_associative (rm ×ₙ sn) (rn ×ₙ sm) ((qm ×ₙ sm) +ₙ (qn ×ₙ sn))).
  rewrite (add_associative (rn ×ₙ sm) (qm ×ₙ sm) (qn ×ₙ sn)).
  rewrite (add_commutative (rn ×ₙ sm +ₙ qm ×ₙ sm) (qn ×ₙ sn)).
  rewrite (add_associative (rm ×ₙ sn) (qn ×ₙ sn) (rn ×ₙ sm +ₙ qm ×ₙ sm)).
  rewrite <- (distributive_r rm qn sn).
  rewrite <- (distributive_r rn qm sm).
  rewrite (add_commutative ((rm +ₙ qn) ×ₙ sm) ((rn +ₙ qm) ×ₙ sn)).
  rewrite (add_commutative ((rm +ₙ qn) ×ₙ sn) ((rn +ₙ qm) ×ₙ sm)).
  rewrite (add_commutative rm qn).
  rewrite (add_commutative rn qm).
  apply order_inequation.
  all: is_nat.
Qed.
(*----------------------------------------------------------------------------*)

(* Sub Z *)
Notation ℤ' := (subset_ctor (fun x => z.0 <z x) ℤ).

Lemma in_subz: forall m, m ∈ ℤ' -> m ∈ ℤ.
Proof.
  intros m P1.
  destruct (subset_elim _ _ _ P1) as [P2 _].
  apply P2.
Qed.

Lemma in_subz_not_zero: forall m, m ∈ ℤ' -> m <> z.0.
Proof.
  intros m P1 P2.
  destruct (subset_elim _ _ _ P1) as [_ P3].
  rewrite P2 in P3.
  pose (int_less_elim_2 _ _ _ _
    empty_is_nat empty_is_nat empty_is_nat empty_is_nat P3) as P4.
  rewrite (add_zero _ empty_is_nat) in P4.
  apply (not_in_empty _ P4).
Qed.

Lemma in_subz_positive: forall m, m ∈ ℤ' -> z.0 <z m.
Proof.
  intros m P1.
  destruct (subset_elim _ _ _ P1) as [_ P2].
  apply P2.
Qed.

Lemma int_multi_subz: forall m n, m ∈ ℤ' -> n ∈ ℤ' -> (m ×z n) ∈ ℤ'.
Proof.
  intros m n P1 P2.
  apply subset_intro.
  + apply (int_multi_is_int _ _ (in_subz _ P1) (in_subz _ P2)).
  + pose (in_subz_positive _ P1) as P3.
    pose (in_subz_positive _ P2) as P4.
    pose (int_less_multi_equal _ _ _ zero_is_int
      (in_subz _ P1) (in_subz _ P2) P4 P3) as P5.
    rewrite (int_multi_commutative _ _ zero_is_int (in_subz _ P2)) in P5.
    rewrite (int_multi_zero _ (in_subz _ P2)) in P5.
    apply P5.
Qed.

Lemma int_one_in_subz: z.1 ∈ ℤ'.
Proof.
  apply subset_intro.
  + apply one_is_int.
  + apply int_less_intro.
    all: is_nat.
    rewrite add_zero.
    rewrite add_commutative.
    rewrite add_zero.
    all: is_nat.
    apply suc_intro_1.
Qed.
(*----------------------------------------------------------------------------*)

(* Other laws *)
Lemma int_add_cancellation: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  m +z l = n +z l -> m = n.
Proof.
  intros m n l P1 P2 P3 P4.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  rewrite Q3 in P4.
  rewrite R3 in P4.
  rewrite S3 in P4.
  rewrite (int_add_elim qm qn sm sn) in P4.
  rewrite (int_add_elim rm rn sm sn) in P4.
  pose (int_equal_elim (qm +ₙ sm) (qn +ₙ sn) (rm +ₙ sm) (rn +ₙ sn)
    (add_is_nat _ _ Q1 S1) (add_is_nat _ _ Q2 S2) P4) as P5.
  rewrite (add_associative (qm +ₙ sm) rn sn) in P5.
  rewrite (add_cyc qm sm rn)in P5.
  rewrite <- (add_associative (qm +ₙ rn) sm sn) in P5.
  rewrite (add_associative (qn +ₙ sn) rm sm) in P5.
  rewrite (add_cyc qn sn rm)in P5.
  rewrite <- (add_associative (qn +ₙ rm) sn sm) in P5.
  rewrite (add_commutative sn sm) in P5.
  rewrite Q3.
  rewrite R3.
  apply (int_equal_intro).
  all: is_nat.
  apply (add_cancellation _ _ (sm +ₙ sn)).
  all: is_nat.
Qed.

Lemma int_add_less_cancellation: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  m +z l <z n +z l -> m <z n.
Proof.
  intros m n l P1 P2 P3 P4.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  rewrite Q3 in P4.
  rewrite R3 in P4.
  rewrite S3 in P4.
  rewrite (int_add_elim qm qn sm sn) in P4.
  rewrite (int_add_elim rm rn sm sn) in P4.
  pose (int_less_elim_2 (qm +ₙ sm) (qn +ₙ sn) (rm +ₙ sm) (rn +ₙ sn)
    (add_is_nat _ _ Q1 S1) (add_is_nat _ _ Q2 S2)
    (add_is_nat _ _ R1 S1) (add_is_nat _ _ R2 S2) P4) as P5.
  rewrite (add_associative (qm +ₙ sm) rn sn) in P5.
  rewrite (add_cyc qm sm rn)in P5.
  rewrite <- (add_associative (qm +ₙ rn) sm sn) in P5.
  rewrite (add_associative (qn +ₙ sn) rm sm) in P5.
  rewrite (add_cyc qn sn rm)in P5.
  rewrite <- (add_associative (qn +ₙ rm) sn sm) in P5.
  rewrite (add_commutative sn sm) in P5.
  rewrite Q3.
  rewrite R3.
  apply (int_less_intro).
  all: is_nat.
  apply (less_add_cancellation _ _ (sm +ₙ sn)).
  all: is_nat.
Qed.

Lemma int_multi_cancellation: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ' ->
  m ×z l = n ×z l -> m = n.
Proof.
  intros m n l P1 P2 P3 P4.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ (in_subz _ P3)) as [sm [sn [S1 [S2 S3]]]].
  rewrite Q3 in P4.
  rewrite R3 in P4.
  rewrite S3 in P4.
  rewrite (int_multi_elim qm qn sm sn) in P4.
  rewrite (int_multi_elim rm rn sm sn) in P4.
  assert (((qm ×ₙ sm +ₙ qn ×ₙ sn) +ₙ (rm ×ₙ sn +ₙ rn ×ₙ sm))
    = ((qm ×ₙ sn +ₙ qn ×ₙ sm) +ₙ (rm ×ₙ sm +ₙ rn ×ₙ sn))) as P5.
  { apply (int_equal_elim).
    all: is_nat. }
  rewrite (add_commutative (rm ×ₙ sn) (rn ×ₙ sm)) in P5.
  rewrite (add_associative (qm ×ₙ sm +ₙ qn ×ₙ sn) (rn ×ₙ sm) (rm ×ₙ sn)) in P5.
  rewrite (add_cyc (qm ×ₙ sm) (qn ×ₙ sn) (rn ×ₙ sm)) in P5.
  rewrite <- (add_associative (qm ×ₙ sm +ₙ rn ×ₙ sm) (qn ×ₙ sn) (rm ×ₙ sn)) in P5.
  rewrite <- (distributive_r qm rn sm) in P5.
  rewrite <- (distributive_r qn rm sn) in P5.
  rewrite (add_commutative (rm ×ₙ sm) (rn ×ₙ sn)) in P5.
  rewrite (add_associative (qm ×ₙ sn +ₙ qn ×ₙ sm) (rn ×ₙ sn) (rm ×ₙ sm)) in P5.
  rewrite (add_cyc (qm ×ₙ sn) (qn ×ₙ sm) (rn ×ₙ sn)) in P5.
  rewrite <- (add_associative (qm ×ₙ sn +ₙ rn ×ₙ sn) (qn ×ₙ sm) (rm ×ₙ sm)) in P5.
  rewrite <- (distributive_r qm rn sn) in P5.
  rewrite <- (distributive_r qn rm sm) in P5.
  rewrite Q3.
  rewrite R3.
  apply (int_equal_intro).
  all: is_nat.
  pose (in_subz_not_zero _ P3) as P6.
  rewrite S3 in P6.
  pose (int_not_zero_elim _ _ S1 S2 P6) as P7.
  apply (not_equal_cyc_equal _ _ sm sn).
  all: is_nat.
Qed.

Lemma int_multi_zero_elim_1: forall m n, m ∈ ℤ -> n ∈ ℤ' -> m ×z n = z.0
  -> m = z.0.
Proof.
  intros m n P1 P2 P3.
  destruct (int_no_zero_divisor _ _ P1 (in_subz _ P2) P3) as [P4|P4].
  + apply P4.
  + pose (in_subz_not_zero _ P2) as P5.
    contradiction.
Qed.

Lemma int_multi_zero_elim_2: forall m n, m ∈ ℤ' -> n ∈ ℤ -> m ×z n = z.0
  -> n = z.0.
Proof.
  intros m n P1 P2 P3.
  destruct (int_no_zero_divisor _ _ (in_subz _ P1) P2 P3) as [P4|P4].
  + pose (in_subz_not_zero _ P1) as P5.
    contradiction.
  + apply P4.
Qed.

Lemma subz_elim: forall m, m ∈ ℤ' -> (z.0 <z m \/ m <z z.0).
Proof.
  intros m P1.
  destruct (int_trichotomy _ _ (in_subz _ P1) zero_is_int) as [P2|[P2|P2]].
  + destruct P2 as [P2 _].
    right.
    apply P2.
  + destruct P2 as [_ [P2 _]].
    pose (in_subz_not_zero _ P1) as P3.
    contradiction.
  + destruct P2 as [_ [_ P2]].
    left.
    apply P2.
Qed.

Lemma int_less_multi_cancellation: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ' ->
  m ×z l <z n ×z l -> m <z n.
Proof.
  intros m n l P1 P2 P3 P4.
  destruct (int_trichotomy _ _ P1 P2) as [P5|[P5|P5]].
  + destruct P5 as [P5 _].
    apply P5.
  + destruct P5 as [_ [P5 _]].
    rewrite P5 in P4.
    pose (int_not_less_self _ (int_multi_is_int _ _ P2 (in_subz _ P3)) P4) as P6.
    contradiction.
  + destruct P5 as [_ [_ P5]].
    pose (int_less_multi_equal _ _ _ P2 P1
      (in_subz _ P3) (in_subz_positive _ P3) P5) as P6.
    pose (int_less_trans _ (n ×z l) _
      (int_multi_is_int _ _ P1 (in_subz _ P3))
      (int_multi_is_int _ _ P2 (in_subz _ P3))
      (int_multi_is_int _ _ P1 (in_subz _ P3)) P4 P6) as P7.
    pose (int_not_less_self _ (int_multi_is_int _ _ P1 (in_subz _ P3)) P7) as P8.
    contradiction.
Qed.

Lemma int_zero_less_one: z.0 <z z.1.
Proof.
  apply int_less_intro.
  all: is_nat.
  rewrite (add_red _ _ empty_is_nat empty_is_nat).
  rewrite (add_zero _ empty_is_nat).
  apply suc_intro_1.
Qed.
(*----------------------------------------------------------------------------*)

(* Ltac *)
Ltac is_int :=
  repeat match goal with
    | [            |- ?P = ?P         ] => reflexivity
    | [            |- z.0 ∈ ℤ         ] => apply zero_is_int
    | [            |- z.1 ∈ ℤ         ] => apply one_is_int
    | [            |- z.-1 ∈ ℤ        ] => apply inverse_one_is_int
    | [            |- z.1 ∈ ℤ'        ] => apply int_one_in_subz
    | [ H: ?P      |- ?P              ] => apply H
    | [ H: ?P ∈ ℤ' |- ?P ∈ ℤ          ] => apply (in_subz P H)
    | [            |- -z _ ∈ ℤ        ] => apply int_add_inverse_intro_1
    | [            |- ?P ×z ?Q ∈ ℤ'   ] => apply int_multi_subz
    | [            |- ⟨_, _⟩ ∈ cp _ _ ] => apply cp_intro
    | [            |- ?P +z ?Q ∈ ℤ    ] => apply int_add_is_int
    | [            |- ?P ×z ?Q ∈ ℤ    ] => apply int_multi_is_int
  end.

(*Ltac int_unwrap_multi_ M :=*)
  (*repeat match M with*)
    (*| ?R ×ₙ (?P +ₙ ?Q) => rewrite (distributive_l R P Q)*)
    (*| (?P +ₙ ?Q) ×ₙ ?R => rewrite (multi_commutative (P +ₙ Q) R)*)
    (*| ?P ×ₙ (?Q ×ₙ ?R) => rewrite (multi_commutative P (Q ×ₙ R))*)
    (*| ?P ×ₙ ?Q         => int_unwrap_multi_ P; int_unwrap_multi_ Q*)
    (*| ?P +ₙ ?Q         => int_unwrap_multi_ P; int_unwrap_multi_ Q*)
  (*end.*)

(*Ltac int_unwrap_multi :=*)
  (*repeat match goal with*)
    (*| [ |- ?P = ?Q ] => int_unwrap_multi_ P; int_unwrap_multi_ Q*)
  (*end.*)

(*Ltac int_unwrap_add_ M :=*)
  (*repeat match M with*)
    (*| ?P +ₙ (?Q +ₙ ?R) => rewrite (add_associative P Q R)*)
    (*| ?P +ₙ ?Q         => int_unwrap_add_ P*)
  (*end.*)

(*Ltac int_unwrap_add :=*)
  (*repeat match goal with*)
    (*| [ |- ?P = ?Q ] => int_unwrap_add_ P; int_unwrap_add_ Q*)
  (*end.*)

(*Ltac int_normal_form :=*)
  (*int_unwrap_multi;*)
  (*int_unwrap_add.*)

(*Ltac int_red_ M P :=*)
  (*repeat match M with*)
    (*[>| P              => assumption<]*)
    (*[>| _ +ₙ P         => assumption [>do nothing<]<]*)
    (*| P +ₙ ?Q        => rewrite (add_commutative P Q)*)
    (*| (?R +ₙ P) +ₙ ?Q => rewrite (add_cyc R P Q)*)
    (*| ?Q +ₙ _        => int_red_ Q P*)
  (*end.*)

(*Ltac int_red :=*)
  (*repeat match goal with*)
    (*| [ |- ?P               = ?P      ] => reflexivity*)
    (*| [ |- _          +ₙ ?P = _ +ₙ ?P ] => apply add_cancellation_inverse*)
    (*| [ |- ?P         +ₙ ?Q = _ +ₙ ?P ] => rewrite (add_commutative P Q)*)
    (*| [ |- (?R +ₙ ?P) +ₙ ?Q = _ +ₙ ?P ] => rewrite (add_cyc R P Q)*)
    (*| [ |- ?R         +ₙ _  = _ +ₙ ?P ] => repeat int_red_ R P*)
  (*end.*)

(*Lemma test: forall a b c d, a ∈ ℤ -> b ∈ ℤ -> c ∈ ℤ -> d ∈ ℤ ->*)
  (*(a ×ₙ b) +ₙ a ×ₙ (c +ₙ d) ×ₙ (a +ₙ b) = a ×ₙ (c +ₙ d) ×ₙ (a +ₙ b) +ₙ (a ×ₙ b).*)
(*Proof.*)
  (*intros a b c d P1 P2 P3 P4.*)
  (*int_normal_form.*)
  (*int_red.*)
  (*all: is_int.*)
(*Qed.*)
(*----------------------------------------------------------------------------*)


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra.

Section contents.
  Variable σ: Signature.

  Notation OpType := (OpType (sorts σ)).

  Section homo.
  Context (A B: sorts σ → Type)
    `{A_equiv : ∀ a, Equiv (A a)} `{B_equiv : ∀ a, Equiv (B a)}
    `{A_ops : AlgebraOps σ A} `{B_ops : AlgebraOps σ B}.

  Section with_f.
    Context (f : ∀ a, A a → B a).

    Arguments f {a} _.

    Fixpoint Preservation {n : OpType}: op_type A n → op_type B n → Prop :=
      match n with
      | ne_list.one d => λ oA oB, f oA = oB
      | ne_list.cons x y => λ oA oB, ∀ x, Preservation (oA x) (oB (f x))
      end.

    Class HomoMorphism: Prop :=
      { homo_proper:> ∀ a, Setoid_Morphism (@f a)
      ; preserves: ∀ (o: σ), Preservation (A_ops o) (B_ops o)
      ; homo_source_algebra: Algebra σ A
      ; homo_target_algebra: Algebra σ B }.

    Context `{∀ a, Setoid (A a)} `{∀ b, Setoid (B b)} `{∀ a, Setoid_Morphism (@f a)}.

    Global Instance Preservation_proper n:
      Proper (op_type_equiv _ _ _ ==> op_type_equiv _ B n ==> iff) (@Preservation n).
        (* todo: use (=) in the signature and see why things break *)
    Proof with auto.
     induction n; simpl; intros x y E x' y' E'.
      split; intro F. rewrite <- E, <- E'... rewrite E, E'...
     split; simpl; intros.
      eapply IHn; eauto; symmetry; [now apply E | now apply E'].
     eapply IHn; eauto; [now apply E | now apply E'].
   Qed.

    Global Instance Preservation_proper'' n:
      Proper (eq ==> (=) ==> iff) (@Preservation n).
    Proof with auto.
     induction n; simpl; intros x y E x' y' E'.
      split; intro F. rewrite <- E, <- E'... rewrite E, E'...
     split; simpl; intros.
      subst.
      apply (IHn (y x0) (y x0) eq_refl (y' (f x0)) (x' (f x0)) ).
       symmetry.
       apply E'.
       reflexivity.
      apply H2.
     subst.
     apply (IHn (y x0) (y x0) eq_refl (y' (f x0)) (x' (f x0)) ).
      symmetry.
      apply E'.
      reflexivity.
     apply H2.
    Qed. (* todo: evil, get rid of *)
  End with_f.

  Lemma Preservation_proper' (f g: ∀ a, A a → B a)
   `{∀ a, Setoid (A a)} `{∀ b, Setoid (B b)} `{∀ a, Setoid_Morphism (@f a)}:
    (∀ a (x: A a), f a x = g a x) → ∀ (n: OpType) x y, Proper (=) x → Proper (=) y →
      @Preservation f n x y →
      @Preservation g n x y.
  Proof.
     induction n.
      simpl.
      intros ? ? ? ? E.
      rewrite <-E.
      symmetry.
      intuition.
     simpl.
     intros a b E1 E2 E3 z.
     apply IHn.
       apply E1. reflexivity.
      apply E2. reflexivity.
     assert (b (g _ z) = b (f _ z)) as E4.
      apply E2.
      symmetry.
      apply H2.
     now apply (Preservation_proper'' f n (a z) (a z) eq_refl _ _ E4).
    Qed.

    Lemma HomoMorphism_Proper: Proper ((λ f g, ∀ a x, f a x = g a x) ==> iff) HomoMorphism.
      (* todo: use pointwise_thingy *)
    Proof with try apply _; intuition.
     intros x y E1. constructor; intros [? ? ? ?]; simpl in *.
      repeat constructor...
       intros ? ? E2.
       rewrite <-2!E1.
       rewrite E2...
      apply (Preservation_proper' x y E1 (σ o) (A_ops o) (B_ops o))...
     repeat constructor...
      intros ? ? E2.
      rewrite 2!E1.
      rewrite E2...
     assert (∀ (a : sorts σ) (x0 : A a), y a x0 = x a x0) as E2. symmetry. apply E1.
     apply (Preservation_proper' y x E2 (σ o) (A_ops o) (B_ops o))...
    Qed.
  End homo.

  Global Instance id_homomorphism A
    `{∀ a, Equiv (A a)} {ao: AlgebraOps σ A} `{!Algebra σ A}: HomoMorphism _ _ (λ _, id).
  Proof with try apply _; intuition.
   constructor; intros...
   generalize (ao o).
   induction (σ o); simpl...
   reflexivity.
  Qed.

  Global Instance compose_homomorphisms A B C f g
    `{∀ a, Equiv (A a)} `{∀ a, Equiv (B a)} `{∀ a, Equiv (C a)}
    {ao: AlgebraOps σ A} {bo: AlgebraOps σ B} {co: AlgebraOps σ C}
    {gh: HomoMorphism A B g} {fh: HomoMorphism B C f}: HomoMorphism A C (λ a, f a ∘ g a).
  Proof with try apply _; auto.
   pose proof (homo_source_algebra _ _ g).
   pose proof (homo_target_algebra _ _ g).
   pose proof (homo_target_algebra _ _ f).
   constructor; intros...
   generalize (ao o) (bo o) (co o) (preserves _ _ g o) (preserves _ _ f o).
   induction (σ o); simpl; intros; unfold compose.
    rewrite H5...
   apply (IHo0 _ (o2 (g _ x)))...
  Qed.

  Lemma invert_homomorphism A B f
    `{∀ a, Equiv (A a)} `{∀ a, Equiv (B a)}
    {ao: AlgebraOps σ A} {bo: AlgebraOps σ B}
    {fh: HomoMorphism A B f}
    `{inv: ∀ a, Inverse (f a)}:
    (∀ a, Bijective (f a)) →
    HomoMorphism A B f → HomoMorphism B A inv.
  Proof with try assumption; try apply _.
   intros ? [? ? ? ?].
   constructor...
   intro.
   generalize (ao o) (bo o) (preserves _ _ f o)
     (algebra_propers o: Proper (=) (ao o)) (algebra_propers o: Proper (=) (bo o)).
   induction (σ o); simpl.
    intros.
    apply (injective (f t)).
    pose proof (surjective (f t) o1 o1 (reflexivity o1)).
    transitivity o1...
    symmetry...
   intros P Q R S T x.
   apply IHo0.
     eapply Preservation_proper''; eauto; intros; try apply _.
     symmetry. now apply T, (surjective (f t) x x).
    apply S. reflexivity.
   apply T. reflexivity.
  Qed.

(*
    Instance eval_morphism `{Algebra σ}  A {V} (v: Vars σ A V):
      HomoMorphism (Term0 σ V) A (λ _ => eval σ v).
    Proof.
     constructor; repeat intro; try apply _.
     unfold AlgebraOps_instance_0.
     generalize (algebra_propers o: eval v (Op V o) = H o).
     generalize (Op V o) (H o).
     induction (operation_type σ o); simpl; repeat intro.
      assumption.
     apply IHo0. simpl.
     apply H1.
     destruct H0. reflexivity.
    Qed.
*)

End contents.


Require Import List.
Import ListNotations.

Lemma cons_inj {A} (x1 x2 : A) (l1 l2 : list A) : x1::l1 = x2::l2 -> x1=x2 /\ l1=l2.
Proof.
  intro.
  split.
  - eapply f_equal with (f:= fun l => match l with |[] => x1 |x::l'=> x end) in H.
    assumption.
  - eapply f_equal with (f:= fun l => match l with |[] => l1 |x::l'=> l' end) in H.
    assumption.
Qed.

Lemma discr_nil_cons {A} (x:A) (l:list A) : nil <> x::l.
Proof.
  unfold not.
  intro.
  eapply f_equal with (f:= fun x => match x with nil => True |_ => False end) in H.
  rewrite <- H.
  trivial.
Qed.

Fail Inductive lambda := Lam (_:lambda->lambda).

Parameter lambda : Type.
Parameter Lam : (lambda->lambda) -> lambda.

Parameter match_lambda : forall P:lambda -> Type, (forall (l:lambda->lambda), P (Lam l) ) -> forall l, P l.

Parameter lambda_eq : forall P H f, match_lambda P H (Lam f) = H f.

Definition app (l1 l2 : lambda) :=
  match_lambda (fun _ => lambda) (fun f => f l2) l1
.

Lemma app_red : forall(f:lambda -> lambda) (x:lambda), app (Lam f) x = f x.
Proof.
  intros.
  unfold app.
  rewrite lambda_eq.
  reflexivity.
Qed.

Definition Y := Lam (fun f =>
  app
    (Lam (fun x => app f (app x x)))
    (Lam (fun x => app f (app x x)))
).

Lemma fixpt : forall (f:lambda -> lambda), exists t, f t = t.
Proof.
  intros.
  exists (app Y (Lam f)).
  unfold Y at 1.

  rewrite app_red.
  rewrite app_red.
  rewrite app_red.
  unfold Y.
  rewrite app_red at 2.
  rewrite a pp_red.
  rewrite app_red.


Require Import Lia.
Definition dec P := {P} + {~P}.
Definition EQ X := forall x y : X, {x = y} + {x <> y}.

Fixpoint fin n : Type :=
  match n with
    0 => False
  | S n' => option (fin n')
  end.

Fact EQ_option X :
  EQ X -> EQ (option X).
Proof. intros H [x|][y|]; decide equality. Defined.

Fact EQ_fin n : EQ (fin n).
Proof. induction n. {intros []. } now apply EQ_option. Defined.

Fact dec_exists {n} (p: fin n -> Prop) :
  (forall x, dec (p x)) ->  {x & p x} + (forall x, ~p x).
Proof.
  intros D. induction n as [|n IH]; auto.
  destruct (IH (fun x => p(Some x)) ltac:(firstorder)) as [[]|]; eauto.
  destruct (D None); eauto.
  right; intros []; auto.
Defined.

Definition Spec {X Y} (f : option X -> option Y) x r_x :=
  match f None, f(Some x) with
  | None    , _       => f(Some x) = Some r_x
  | Some y0 , None    => r_x = y0
  | Some y0 , Some y  => r_x <> y0 /\ r_x = y
  end.

Definition R {X Y} (f : option X -> option Y) :
  (forall x, f(Some x) <> f None) -> forall x, { r_x & Spec f x r_x}.
Proof.
  unfold Spec; intros H x.
  destruct  (f None) as [y0|] eqn:?,
            (f (Some x)) as [y|] eqn:?.
  - exists y. split; congruence.
  - exists y0. reflexivity.
  - exists y. reflexivity.
  - exfalso. now apply (H x).
Defined.

Definition r {X Y} (f : option X -> option Y) H x := projT1 (R f H x).
Definition r_spec {X Y} (f : option X -> option Y) H x := projT2 (R f H x).

Lemma r_agree {X Y} (f : option X -> option Y) H x x' :
let r := r f H in
  r x = r x' -> f(Some x) = f(Some x').
Proof.
  unfold r in *; intros e.
  generalize (r_spec f H x), (r_spec f H x').
  rewrite <-e.
  generalize (projT1 (R f H x)) as z.
  intros ?. clear e; unfold Spec.
  destruct (f None) as [y0|]. 2: congruence.
  destruct  (f (Some x)) as [y|],
            (f (Some x')) as [y'|].
  * intros [][]; subst; congruence.
  * intros [] ?; subst; congruence.
  * intros ? []; subst; congruence.
  * intros [][]; reflexivity.
Qed.

Lemma Pigeonhole M N (f : fin M -> fin N) :
  M > N -> {a &{b & a <> b /\ f a = f b}}.
Proof.
  revert M f. induction N.
  { intros [] f; [lia | destruct (f None)]. }
  intros [|M] f H_NM; try lia.
  destruct (dec_exists (fun x => f(Some x) = f None)) as [H|H].
  { intros ?; apply EQ_fin. }
  - destruct H as [x ]. exists (Some x), None.
    split; congruence.
  - destruct (IHN _ (r f H) ltac:(lia)) as (x & x' &[]).
    exists (Some x), (Some x').
    split; try congruence.
    eapply r_agree; eauto.
Qed.


(**

- Construction of a pseudofunctor from a strong monoidal functor - between the bicategories (trivially)
  generated from the monoidal categories.
- And the opposite direction: We fix two bicategories and a pseudofunctor between them and an object in
  the domain bicategory. This gives rise to a strong monoidal functor between the associated monoidal
  categories of endomorphisms for the fixed object and its image.

Author: Ralph Matthes 2021

*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorsTensored.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicategoryFromMonoidal.
Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.

Local Open Scope cat.

Section monoidal_functor_to_psfunctor.

  Context (M N : monoidal_cat).

  Local Definition M_as_bicat := bicat_from_monoidal M.
  Local Definition N_as_bicat := bicat_from_monoidal N.

  Context (smF : strong_monoidal_functor M N).

Definition monoidal_functor_to_psfunctor_map_data: psfunctor_data M_as_bicat N_as_bicat.
Proof.
  use make_psfunctor_data.
  - cbn. exact (fun x => x).
  - intros a b. cbn.
    exact (functor_on_objects smF).
  - intros a b f g. cbn.
    exact (functor_on_morphisms smF).
  - intros a. cbn. exact (lax_monoidal_functor_ϵ smF).
  - intros a b c f g. cbn. apply (lax_monoidal_functor_μ smF (f,g)).
Defined.

Definition monoidal_functor_to_psfunctor_map_laws: psfunctor_laws monoidal_functor_to_psfunctor_map_data.
Proof.
  repeat split; red; cbn.
  - intros H0 H1 a. apply functor_id.
  - intros H0 H1 a b c f g. apply functor_comp.
  - intros H0 H1 a. apply lax_monoidal_functor_unital.
  - intros H0 H1 a. apply (lax_monoidal_functor_unital smF a).
  - intros H0 H1 H2 H3 a b c.
    do 2 rewrite <- assoc. apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ (nat_z_iso_pointwise_z_iso (monoidal_cat_associator N) ((smF a, smF b), smF c))).
    do 2 rewrite assoc.
    etrans.
    2: { apply maponpaths. apply functor_on_inv_from_z_iso'. }
    apply z_iso_inv_on_left.
    cbn.
    apply pathsinv0.
    apply lax_monoidal_functor_assoc.
  - intros H0 H1 H2 a b1 b2 g. red in g.
    apply pathsinv0.
    assert (Heq := nat_trans_ax (lax_monoidal_functor_μ smF) (a,,b1) (a,,b2) (id a,,g)).
    cbn in Heq.
    rewrite functor_id in Heq.
    exact Heq.
  - intros H0 H1 H2 a1 a2 b f.
    apply pathsinv0.
    assert (Heq := nat_trans_ax (lax_monoidal_functor_μ smF) (a1,,b) (a2,,b) (f,,id b)).
    cbn in Heq.
    rewrite functor_id in Heq.
    exact Heq.
Qed.

Definition monoidal_functor_to_psfunctor: psfunctor M_as_bicat N_as_bicat.
Proof.
  use make_psfunctor.
    - exact (monoidal_functor_to_psfunctor_map_data).
    - exact (monoidal_functor_to_psfunctor_map_laws).
    - split ; red; cbn.
      + intros H0. unfold two_cells_from_monoidal.
        exists (strong_monoidal_functor_ϵ_inv smF).
        exact (pr2 (strong_monoidal_functor_ϵ_is_z_iso smF)).
      + intros H0 H1 H2 a b. unfold two_cells_from_monoidal.
        exists (strong_monoidal_functor_μ_inv smF (a,,b)).
        exact (pr2 (strong_monoidal_functor_μ_is_nat_z_iso smF (a,,b))).
Defined.

End monoidal_functor_to_psfunctor.

(** *** Going into the opposite direction *)
(** see the description in the file header *)

Section psfunctor_to_monoidal_functor.

Local Open Scope bicategory_scope.
Import Bicat.Notations.

Context {C : bicat}.
Context (c0: ob C).
Context {D : bicat}.
Context (psF: psfunctor C D).

Local Definition d0 : D := psF c0.
Local Definition M : monoidal_cat := monoidal_cat_from_bicat_and_ob c0.
Local Definition N : monoidal_cat := monoidal_cat_from_bicat_and_ob d0.

Definition psfunctor_to_lax_monoidal_functor_data: functor_data M N.
Proof.
  use make_functor_data.
  - cbn. intro f. exact (# psF f).
  - intros a b f. red in f. cbn in f.
    cbn. exact (##psF f).
Defined.

Lemma psfunctor_to_lax_monoidal_functor_data_is_functor : is_functor psfunctor_to_lax_monoidal_functor_data.
Proof.
  split; red; cbn.
  - intros a. apply psF.
  - intros a b c f g. apply psF.
Qed.

Definition psfunctor_to_lax_monoidal_functor_functor : M ⟶ N.
Proof.
  use make_functor.
  - exact psfunctor_to_lax_monoidal_functor_data.
  - exact psfunctor_to_lax_monoidal_functor_data_is_functor.
Defined.

Local Definition auxμ : nat_trans_data (monoidal_functor_map_dom M N psfunctor_to_lax_monoidal_functor_functor)
                                       (monoidal_functor_map_codom M N psfunctor_to_lax_monoidal_functor_functor).
Proof.
  red. cbn. intro fg.
  exact (psfunctor_comp psF (pr1 fg) (pr2 fg)).
Defined.

Local Lemma auxμ_is_nat_trans: is_nat_trans _ _ auxμ.
Proof.
  red. cbn. intros gh gh' αβ.
  red in αβ. cbn in αβ.
  change (## psF (pr2 αβ) ⋆⋆ ## psF (pr1 αβ) • psfunctor_comp psF (pr1 gh') (pr2 gh') =
          psfunctor_comp psF (pr1 gh) (pr2 gh) • ## psF (pr2 αβ ⋆⋆ pr1 αβ)).
  apply pathsinv0.
  apply (psfunctor_comp_natural psF).
Qed.

Local Definition μ : monoidal_functor_map M N psfunctor_to_lax_monoidal_functor_functor
  := (auxμ,, auxμ_is_nat_trans).

Lemma psfunctor_to_lax_monoidal_functor_laws :
  monoidal_functor_associativity M N psfunctor_to_lax_monoidal_functor_functor μ
  × monoidal_functor_unitality M N psfunctor_to_lax_monoidal_functor_functor (pr1(psfunctor_id psF c0)) μ.
Proof.
  split.
  * red. cbn. intros x y z. unfold rassociator_fun'. cbn.
    assert (Hyp := psfunctor_rassociator psF x y z).
    change ((id₂ (# psF z) ⋆⋆  psfunctor_comp psF x y • psfunctor_comp psF (x · y) z)
              • ## psF (rassociator x y z) =
            (rassociator (# psF x) (# psF y) (# psF z) •  psfunctor_comp psF y z ⋆⋆ id₂ (# psF x))
              •  psfunctor_comp psF x (y · z)).
    rewrite hcomp_identity_right.
    rewrite hcomp_identity_left.
    exact Hyp.
  * red. cbn. intro x.
    split.
    -- change (lunitor (# psF x) =
               (id₂ (# psF x) ⋆⋆ psfunctor_id psF c0 • psfunctor_comp psF (id₁ c0) x)
                 • ## psF (lunitor x)).
       rewrite hcomp_identity_right.
       apply psfunctor_lunitor.
    -- change (runitor (# psF x) =
               (psfunctor_id psF c0 ⋆⋆ id₂ (# psF x) • psfunctor_comp psF x (id₁ c0))
                 • ## psF (runitor x)).
       rewrite hcomp_identity_left.
       apply psfunctor_runitor.
Qed.

Definition psfunctor_to_lax_monoidal_functor: lax_monoidal_functor M N.
Proof.
  exists psfunctor_to_lax_monoidal_functor_functor.
  cbn.
    exists (psfunctor_id psF c0).
    exists μ.
    exact psfunctor_to_lax_monoidal_functor_laws.
Defined.

Definition psfunctor_to_monoidal_functor: strong_monoidal_functor M N.
Proof.
  exists psfunctor_to_lax_monoidal_functor.
  split.
  - exact (pr2 (psfunctor_id psF c0)).
  - intro c. exact (pr2 (psfunctor_comp psF (pr1 c) (pr2 c))).
Defined.

End psfunctor_to_monoidal_functor.


 Set Asymmetric Patterns.
(* Set Implicit Arguments. *)

(* Require Import Modal.
Require Import SecOrder.  *)
Require Export ST_setup.
Require Export Correctness_ST_world_model.
Require Import Coq.Arith.Peano_dec my_arith.

(* Definition of family of types of lists with n elements. *)
Inductive nlist_pa (W : Set) : nat -> Type :=
        | niln_pa : nlist_pa W 0
        | consn_pa : forall n:nat, (W -> Prop) -> nlist_pa W n -> nlist_pa W (S n).

Inductive nlist {A : Type} : nat -> Type :=
  | niln : nlist 0
  | consn : forall n:nat, A -> nlist n -> nlist (S n).

(*
Inductive nlist_pred : nat -> Type :=
        | niln_pred : nlist_pred 0
        | consn_pred : forall n:nat, predicate -> nlist_pred n -> nlist_pred (S n).
*)

(* Converts nlist_pa to list. *)
Fixpoint nlist_list_pa (W:Set) (n : nat) (ln : nlist_pa W n) : list (W -> Prop) :=
  match ln with
    | niln_pa  => nil
    | consn_pa  m pa ln' => cons pa (nlist_list_pa _ _ ln')
  end.

Fixpoint list_nlist {A : Type} (l : list A) : nlist (length l) :=
  match l in list _ return nlist (length l) with
  | nil => niln
  | cons P l' => consn _ P (list_nlist l')
  end.

Fixpoint nlist_list {A : Type} (n : nat) (ln : nlist n) : list A :=
  match ln with
  | niln => nil
  | consn m P l' => cons P (nlist_list _ l')
  end.

(*
Fixpoint list_nlist_pred (l : list predicate) : nlist_pred (length l) :=
  match l in list _ return nlist_pred (length l) with
  | nil => niln_pred
  | cons P l' => consn_pred P (list_nlist_pred l')
  end.
*)
(*
Fixpoint nlist_list_pred (n : nat) (ln : nlist_pred n) : list predicate :=
  match ln with
  | niln_pred => nil
  | consn_pred m P l' => cons P (nlist_list_pred l')
  end.
*)

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

(* Similar to alt_Ip but with list. *)
Fixpoint alt_Ip_list {D:Set} (Ip: predicate -> D -> Prop) (l_pa : list (D -> Prop))
                      (l_pred : list (predicate)) : predicate -> D -> Prop:=
  match l_pa, l_pred with
    nil, _ => Ip
  | _, nil => Ip
  | cons pa l_pa', cons P l_pred' =>  alt_Ip (alt_Ip_list Ip l_pa' l_pred') pa P
  end.

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

(* Destructs an nlist with n>0 intros consn_pa. *)
Lemma nlist_cons : forall (W : Set) (n : nat) (pa_l : nlist_pa W (S n)),
           exists (pa : W -> Prop) (pa_l' : nlist_pa W n),
              (pa_l = consn_pa W n pa pa_l').
Proof.
  intros.
  refine (match pa_l as pa_l0 in nlist_pa _ m
            return forall pf: (m = (S n)),
                   eq_rect m (nlist_pa W) pa_l0 (S n) pf = pa_l ->
                   exists (pa : W -> Prop) (pa_l' : nlist_pa W n),
                   pa_l = consn_pa W n pa pa_l'
            with
          | niln_pa => _
          | consn_pa _ _ _ => _
          end eq_refl eq_refl).
    intros.
    inversion pf.

    intros.
    inversion pf.
    exists P.
    subst pa_l.
    subst n.
    exists n1.
    rewrite <- Eqdep_dec.eq_rect_eq_dec.
      reflexivity.

      apply eq_nat_dec.
Qed.

(* Destructs an nlist with n>0 into consn. *)
Lemma nlist_cons2 : forall {A : Type} (n : nat) (l : nlist (S n)),
           exists (P : A) (l' : nlist n),
              (l = consn n P l').
Proof.
  intros.
  refine (match l as l0 in nlist m
            return forall pf: (m = (S n)),
                   eq_rect m (nlist) l0 (S n) pf = l ->
                   exists (P : A) (l' : nlist n),
                   l = consn n P l'
            with
          | niln => _
          | consn _ _ _ => _
          end eq_refl eq_refl).
    intros.
    inversion pf.

    intros.
    inversion pf.
    exists a.
    subst l.
    subst n.
    exists n1.
    rewrite <- Eqdep_dec.eq_rect_eq_dec.
      reflexivity.

      apply eq_nat_dec.
Qed.

(* Destructs an nlist with n=0 into niln_pa. *)
Lemma nlist_nil : forall (W : Set) (pa_l : nlist_pa W 0),
           (pa_l = niln_pa W).
Proof.
  intros.
  refine (match pa_l as pa_l0 in nlist_pa _ m
            return forall pf: (m = 0),
                   eq_rect m (nlist_pa W) pa_l0 0 pf = pa_l ->
                     pa_l = niln_pa W
            with
          | niln_pa  => _
          | consn_pa  _ _ _ => _
          end eq_refl eq_refl).
    intros.
    subst pa_l.
    rewrite <- Eqdep_dec.eq_rect_eq_dec.
      reflexivity.

      apply eq_nat_dec.

    intros.
    inversion pf.
Qed.

(* Destructs an nlist with n=0 into niln_pa. *)
Lemma nlist_nil2 : forall {A : Type} (l : nlist 0),
           (l = @niln A).
Proof.
  intros.
  refine (match l as l0 in nlist m
            return forall pf: (m = 0),
                   eq_rect m (nlist) l0 0 pf = l ->
                     l = niln
            with
          | niln  => _
          | consn  _ _ _ => _
          end eq_refl eq_refl).
    intros.
    subst l.
    rewrite <- Eqdep_dec.eq_rect_eq_dec.
      reflexivity.

      apply eq_nat_dec.

    intros.
    inversion pf.
Qed.

Lemma nlist_list_cons : forall (W : Set) (pa : W -> Prop) (l : list predicate)
                               (t : nlist_pa W (length l)),
      (nlist_list_pa W (S (length l) ) (consn_pa W (length l) pa t))
         = cons pa (nlist_list_pa W (length l) t).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Lemma nlist_list_nlist : forall {A : Type} l ln,
  nlist_list (length l) ln = l ->
  ln = @list_nlist A l.
Proof.
  intros A l. induction l; intros ln H.
    simpl in *.
    apply (nlist_nil2 ln).

    simpl in *.
    destruct (nlist_cons2 _ ln) as [a' [ln' H2]].
    rewrite H2 in *.
    simpl in *.
    inversion H.
    rewrite IHl with (ln := ln').
      reflexivity.
      assumption.
Qed.

Lemma length_nlist_list : forall {A : Type} n (nl : @nlist A n),
  length (nlist_list _ nl) = n.
Proof.
  intros A. induction n; intros nl.
    rewrite (nlist_nil2 nl).
    reflexivity.

    destruct (nlist_cons2 _ nl) as [a [nl' Heq]].
    rewrite Heq.
    simpl.
    rewrite IHn.
    reflexivity.
Qed.

Lemma nlist_list_ex : forall {A : Type} n (l : list A),
  length l = n ->
  exists (ln : nlist n),
  nlist_list _ ln = l.
Proof.
  intros A n. induction n; intros l H.
    exists niln.
    simpl. apply List.length_zero_iff_nil in H.
    symmetry. assumption.

    case_eq l.
      intros Hnil; rewrite Hnil in H.
      simpl in *; discriminate.

      intros a l' Heq.
      rewrite Heq in H.
      simpl in H.
      inversion H as [H2].
      destruct (IHn l' H2) as [ln Heq2].
      rewrite H.
      exists (consn _ a ln).
      simpl.
      rewrite Heq2.
      reflexivity.
Qed.

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

Lemma alt_Ip_eq : forall (W : Set) (Ip : predicate -> W -> Prop) (pa1 pa2 : W -> Prop)
                                 (P : predicate),
     alt_Ip (alt_Ip Ip pa2 P) pa1 P
                    = alt_Ip Ip pa1 P.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  apply functional_extensionality.
  intros.
  destruct x.
  destruct P.
  simpl.
  case_eq (EqNat.beq_nat n0 n).
    intros.
    reflexivity.

    intros.
    reflexivity.
Qed.

Lemma alt_Ip_switch : forall (W : Set) (Ip : predicate -> W -> Prop) (pa1 pa2 : W -> Prop)
                                 (n m : nat),
     ~(n = m) -> (alt_Ip (alt_Ip Ip pa2 (Pred m)) pa1 (Pred n)
                    = alt_Ip (alt_Ip Ip pa1 (Pred n)) pa2 (Pred m) ).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  apply functional_extensionality.
  intros.
  destruct x.
  simpl.
  case_eq (EqNat.beq_nat n n0).
    case_eq (EqNat.beq_nat m n0).
      intros.
      pose proof ((EqNat.beq_nat_true m n0) H0).
      pose proof ((EqNat.beq_nat_true n n0) H1).
      rewrite <- H2 in H3.
      contradiction.

      intros.
      reflexivity.

    intros.
    case_eq (EqNat.beq_nat m n0).
      intros.
      reflexivity.

      intros.
      reflexivity.
Qed.

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

Lemma alt_Ip_list_cons : forall (D:Set) (Ip: predicate -> D -> Prop) (l_pa : list (D -> Prop))
                      (l_pred : list (predicate)) (P : predicate) (pa : D -> Prop),
            alt_Ip_list Ip (cons pa l_pa) (cons P l_pred)
               = alt_Ip (alt_Ip_list Ip l_pa l_pred) pa P.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Lemma alt_Ip_list_nil : forall (D:Set) (Ip: predicate -> D -> Prop) (l_pa : list (D -> Prop)) ,
  alt_Ip_list Ip l_pa nil = Ip.
Proof.
  intros.
  case l_pa.
    simpl.
    reflexivity.

    simpl.
    reflexivity.
Qed.

Lemma alt_Ip_list_tail : forall (W : Set) (Ip : predicate -> W -> Prop) (P : predicate)
                            (l : list predicate) (pa_l : nlist_pa W (length l))
                            (pa: W -> Prop),
         alt_Ip_list (alt_Ip Ip pa P) (nlist_list_pa W (length l) pa_l) l
            = alt_Ip_list Ip (app (nlist_list_pa W (length l) pa_l) (cons pa nil) ) (app l (cons P nil)).
Proof.
  intros.
  induction l.
    simpl.
    simpl length in pa_l.
    assert (pa_l = niln_pa W).
      apply nlist_nil.
    rewrite H.
    simpl.
    reflexivity.

    assert (exists (pa1 : W -> Prop) (pa_l1 : nlist_pa W (length l)),
              (pa_l = consn_pa W (length l) pa1 pa_l1)).
      apply nlist_cons.
    destruct H as [pa1 [pa_l1 H]].
    rewrite H.
    simpl.
    rewrite IHl.
    reflexivity.
Qed.

Lemma alt_Ip_list_app : forall (W : Set) (Ip : predicate -> W -> Prop) (P : predicate)
                            (l : list predicate) (pa_l : nlist_pa W (length l))
                            (pa : W -> Prop),
       (alt_Ip_list Ip (app (nlist_list_pa W (length l) pa_l) (cons pa nil)) (l ++ P :: nil))
     = (alt_Ip_list (alt_Ip_list Ip (nlist_list_pa W 1 (consn_pa W 0 pa (niln_pa W)))
          (P :: nil)) (nlist_list_pa W (length l) pa_l) l).
Proof.
  intros.
  induction l.
    simpl in pa_l.
    assert (pa_l = (niln_pa W)).
      apply nlist_nil.
    rewrite H.
    simpl.
    reflexivity.

    simpl.
    assert (exists (pa1 : W -> Prop) (pa_l1 : nlist_pa W (length l)),
              (pa_l = consn_pa W (length l) pa1 pa_l1)).
       apply nlist_cons.
    destruct H as [pa1 [pa_l1 H]].
    rewrite H.
    specialize (IHl pa_l1).
    simpl.
    rewrite IHl.
    simpl.
    reflexivity.
Qed.

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

Lemma alt_alt_list_1 : forall (W : Set) (l : list predicate) (pa_l_hat : nlist_pa W (length l))
                            (pa_hat : W -> Prop) (P : predicate) (Ip : predicate -> W -> Prop) ,
      exists (pa : W -> Prop) (pa_l : nlist_pa W (length l)),
          (alt_Ip (alt_Ip_list Ip (nlist_list_pa W (length l) pa_l_hat) l) pa_hat P)
        = (alt_Ip_list (alt_Ip Ip pa P) (nlist_list_pa W (length l) pa_l) l).
Proof.
  intros W l.
  induction l.
    intros.
    simpl.
    simpl in pa_l_hat.
    assert (pa_l_hat = niln_pa W).
      apply nlist_nil.
    rewrite H.
    simpl.
    exists pa_hat.
    exists (niln_pa W).
    simpl.
    reflexivity.

    intros.
    simpl in pa_l_hat.
    assert (exists (pa : W -> Prop) (pa_l' : nlist_pa W (length l)),
              (pa_l_hat = consn_pa W (length l) pa pa_l')).
       apply nlist_cons.
    destruct H as [pa1 [pa_l1 H]].
    destruct a as [Qm]; destruct P as [Pn].
    case_eq (EqNat.beq_nat Qm Pn).
      intros.
      pose proof ((EqNat.beq_nat_true Qm Pn) H0).
      rewrite <- H1.
      rewrite H.
      simpl nlist_list_pa.
      rewrite alt_Ip_list_cons.
      rewrite alt_Ip_eq.
      specialize (IHl pa_l1 pa_hat (Pred Qm) Ip).
      destruct IHl as [pa2 [pa_l2 IHl']].

      exists pa2.
      exists (consn_pa W (length l) pa_hat pa_l2).
      simpl nlist_list_pa.
      rewrite alt_Ip_list_cons.
      rewrite <- IHl'.
      rewrite alt_Ip_eq.
      reflexivity.

      intros.
      pose proof ((EqNat.beq_nat_false Qm Pn) H0).
      rewrite H.
      simpl nlist_list_pa.
      rewrite alt_Ip_list_cons.
      rewrite <- alt_Ip_switch.
      specialize (IHl pa_l1 pa_hat (Pred Pn) Ip).
      destruct IHl as [pa2 [pa_l2 IHl']].
      rewrite IHl'.
      assert (S (length l) = length (cons (Pred Pn) l)).
        simpl; reflexivity.
      rewrite <- alt_Ip_list_cons.
      exists pa2.
      exists (consn_pa W (length l) pa1 pa_l2).
      reflexivity.

        exact H1.
Qed.

Lemma alt_alt_list_2 : forall (W : Set) (Ip : predicate -> W -> Prop) (P : predicate)
                            (l : list predicate) (pa_l_hat : nlist_pa W (length l))
                            (pa_hat : W -> Prop),
   exists (pa : W -> Prop) (pa_l : nlist_pa W (length l)),
     (alt_Ip (alt_Ip_list Ip (nlist_list_pa W (length l) pa_l) l) pa P) =
        (alt_Ip_list (alt_Ip Ip pa_hat P) (nlist_list_pa W (length l) pa_l_hat) l).
Proof.
  intros.
  rewrite alt_Ip_list_tail.
  induction l.
    simpl length in *.
    assert (pa_l_hat = niln_pa W).
      apply nlist_nil.
    rewrite H.
    simpl.
    exists pa_hat.
    exists (niln_pa W).
    simpl.
    reflexivity.

    assert (exists (pa1 : W -> Prop) (pa_l1 : nlist_pa W (length l)),
              (pa_l_hat = consn_pa W (length l) pa1 pa_l1)).
      apply nlist_cons.
    destruct H as [pa1 [pa_l1 H']].
    rewrite H'.
    simpl.
    destruct a as [Qm].
    destruct P as [Pn].
    rewrite alt_Ip_list_app.
    specialize (IHl pa_l1).
    destruct IHl as [pa2 [pa_l2 IHl']].
    case_eq (EqNat.beq_nat Qm Pn).
      intros.
      pose proof ((EqNat.beq_nat_true Qm Pn) H).
      rewrite <- H0.
      assert (nlist_list_pa W (length (cons (Pred Pn) nil))
                    (consn_pa W (length (nil: list predicate)) pa_hat (niln_pa W))
               = cons pa_hat (nlist_list_pa W (length (nil:list predicate)) (niln_pa W)))
              as list_cons.
        apply nlist_list_cons.
      simpl length in list_cons.
      rewrite list_cons.
      rewrite alt_Ip_list_cons.
      rewrite alt_Ip_list_app in IHl'.
      rewrite list_cons in IHl'.
      rewrite alt_Ip_list_cons in IHl'.
      rewrite alt_Ip_list_nil.
      rewrite alt_Ip_list_nil in IHl'.
      rewrite H0.
      rewrite <- IHl'.
      exists pa1.
      exists (consn_pa W (length l) pa2 pa_l2).
      assert ((nlist_list_pa W (length (cons (Pred Pn) l)) (consn_pa W (length l) pa2 pa_l2))
                 =  cons pa2 (nlist_list_pa W (length l) pa_l2) ) as list_cons2.
        apply nlist_list_cons.
      simpl length in list_cons2.
      rewrite list_cons2.
      rewrite alt_Ip_list_cons.
      reflexivity.

      intros.
      exists pa2.
      exists (consn_pa W (length l) pa1 pa_l2).
      assert ((nlist_list_pa W (length (cons (Pred Pn) l)) (consn_pa W (length l) pa1 pa_l2))
               = cons pa1 (nlist_list_pa W (length l) pa_l2)) as list_cons.
        apply nlist_list_cons.
      simpl length in list_cons.
      rewrite list_cons.
      rewrite alt_Ip_list_app in IHl'.
      simpl nlist_list_pa in IHl'.
      rewrite alt_Ip_list_cons in IHl'.
      simpl alt_Ip_list in IHl' at 3.
      rewrite alt_Ip_list_cons.
      assert ((nlist_list_pa W (length (cons (Pred Pn) nil))
              (consn_pa W (length (nil: list predicate)) pa_hat (niln_pa W)))
                 = cons pa_hat (nlist_list_pa W (length (nil:list predicate)) (niln_pa W)))
              as list_cons2.
        apply nlist_list_cons.
      simpl length in list_cons2.
      rewrite list_cons2.
      rewrite alt_Ip_list_cons.
      unfold nlist_list_pa at 2.
      unfold alt_Ip_list at 3.
      rewrite <- IHl'.
      apply alt_Ip_switch.
      pose proof ((EqNat.beq_nat_false Qm Pn) H).
      unfold not; intros.
      symmetry in H1.
      contradiction.
Qed.

Lemma nlist_list_closed_SO : forall (W : Set) (Iv : FOvariable -> W)
                           (Ir: W -> W -> Prop) (alpha: SecOrder) (l : list predicate)
                           (Ip: predicate -> W -> Prop),
     SOturnst W Iv Ip Ir (list_closed_SO alpha l) <->
   forall pa_l : (nlist_pa W (length l)),
      SOturnst W Iv (alt_Ip_list Ip (nlist_list_pa W (length l) pa_l) l) Ir alpha.
Proof.
  intros W Iv Ir alpha l.
  induction l.
    simpl.
    split.
      intros H pa_l.
      rewrite alt_Ip_list_nil.
      exact H.

      intros H.
      specialize (H (niln_pa W)).
      rewrite alt_Ip_list_nil in H.
      exact H.

    intros.
    split.
      intros.
      assert (exists (pa1 : W -> Prop) (pa_l1 : nlist_pa W (length l)),
              (pa_l = consn_pa W (length l) pa1 pa_l1)).
         apply nlist_cons.
      destruct H0 as [pa1 [pa_l1 H0]].
      rewrite H0.
      simpl nlist_list_pa.
      simpl alt_Ip_list.
      assert (exists (pa : W -> Prop) (pa_l : nlist_pa W (length l)),
            (alt_Ip (alt_Ip_list Ip (nlist_list_pa W (length l) pa_l1) l) pa1 a) =
            (alt_Ip_list (alt_Ip Ip pa a) (nlist_list_pa W (length l) pa_l) l)).
        apply alt_alt_list_1.
      destruct H1 as [pa2 [pa_l2 H1]].
      rewrite H1.
      apply IHl.
      simpl list_closed_SO in H.
      rewrite SOturnst_allSO in H.
      specialize (H pa2).
      exact H.

      intros.
      simpl list_closed_SO.
      rewrite SOturnst_allSO.
      intros.
      apply IHl.
      intros.
      simpl in H.
      assert (exists (pred_asgmt1 : W -> Prop) (pa_l1 : nlist_pa W (length l)),
           (alt_Ip (alt_Ip_list Ip (nlist_list_pa W (length l) pa_l1) l)
              pred_asgmt1 a) =
           (alt_Ip_list (alt_Ip Ip pred_asgmt a)
              (nlist_list_pa W (length l) pa_l) l)).
         apply alt_alt_list_2.
       destruct H0 as [pred_asgmt1 [pa_l1 H0]].
       rewrite <- H0.
       specialize (H (consn_pa W (length l) pred_asgmt1 pa_l1)).
       apply H.
Qed.
(* ----------------------------------------------------------------------------------------*)

(* Checks whether Ip and Ip' agree on given predicate values in list l. *)
Fixpoint same_Ip_list (W : Set) (Ip Ip' : predicate -> W -> Prop) (l : list predicate) : Prop :=
  match l with
  | nil => True
  | cons P l' => Ip P = (Ip' P) /\ (same_Ip_list W Ip Ip' l')
  end.

Lemma same_cons : forall (W : Set) (Ip Ip' : predicate -> W -> Prop) (l : list predicate)
                          (P : predicate),
     ( same_Ip_list W Ip Ip' (cons P l)) = (Ip P = Ip' P /\ (same_Ip_list W Ip Ip' l)).
Proof.
  intros;  simpl; reflexivity.
Qed.

Lemma same_comm : forall  (W : Set) (Ip Ip' : predicate -> W -> Prop) (l : list predicate),
    same_Ip_list W Ip Ip' l <-> same_Ip_list W Ip' Ip l.
Proof.
  intros.
  induction l.
    simpl.
    intuition.

    simpl in *.
    split.
      intros.
      destruct H as [H1 H2].
      symmetry in H1.
      apply conj.
        exact H1.

        apply IHl.
        exact H2.

      intros.
      destruct H as [H1 H2].
      symmetry in H1.
      apply conj.
        exact H1.

        apply IHl.
        exact H2.
Qed.

Lemma same_app2 : forall (W : Set) (Ip Ip' : predicate -> W -> Prop)
                         (l1 l2 : list predicate),
        same_Ip_list W Ip Ip' (app l1 l2) <->
          (same_Ip_list W Ip Ip' l1 /\ same_Ip_list W Ip Ip' l2).
Proof.
  intros.
  induction l1.
    simpl.
    apply True_conj.
    apply iff_refl.

    simpl.
    split.
      intros.
      destruct H as [pf_eq pf_app].
      apply conj.
        apply conj.
          apply pf_eq.

          assert (same_Ip_list W Ip Ip' (l1 ++ l2) ->
                  same_Ip_list W Ip Ip' l1 /\ same_Ip_list W Ip Ip' l2).
            apply IHl1.
          pose proof (H pf_app).
          apply H0.

        assert (same_Ip_list W Ip Ip' (l1 ++ l2) ->
                same_Ip_list W Ip Ip' l1 /\ same_Ip_list W Ip Ip' l2).
        apply IHl1.
        pose proof (H pf_app).
        apply H0.

      intros.
      apply conj.
        apply H.

        apply IHl1.
        apply conj.
          apply H.

          apply H.
Qed.

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

(* Removes nth predicate from list l if it is in it. *)
Fixpoint list_rem (l : list predicate) (n : nat) : list predicate :=
  match l with
  | nil => nil
  | cons (Pred m) l' => if EqNat.beq_nat n m then list_rem l' n
                                       else cons (Pred m) (list_rem l' n)
  end.

(* List l1 without the elements of list l2. *)
Fixpoint list_without (l1 l2 : list predicate) : list predicate :=
  match l2 with
  | nil => l1
  | cons (Pred n) l2' => list_without (list_rem l1 n) l2'
  end.

Lemma list_rem_switch : forall (l : list predicate) (n n2 : nat),
       (list_rem (list_rem l n) n2)
     = (list_rem (list_rem l n2) n).
Proof.
  induction l.
    intros.
    simpl.
    reflexivity.

    intros.
    destruct a as [m].
    case_eq (EqNat.beq_nat n m).
      intros.
      simpl list_rem.
      rewrite H.
      case_eq (EqNat.beq_nat n2 m).
        intros.
        apply IHl.

        intros.
        simpl list_rem.
        rewrite H.
        apply IHl.

      intros.
      case_eq (EqNat.beq_nat n2 m).
        intros.
        simpl list_rem.
        rewrite H.
        simpl list_rem.
        rewrite H0.
        apply IHl.

        intros.
        simpl list_rem.
        rewrite H.
        simpl list_rem.
        rewrite H0.
        simpl list_rem.
        rewrite H.
        rewrite (IHl n n2).
        reflexivity.
Qed.

Lemma list_without_rem : forall (l2 l1 : list predicate) (n : nat),
         (list_without (list_rem l1 n) l2)
       = (list_rem (list_without l1 l2) n).
Proof.
  intros l2.
  induction l2.
    intros.
    simpl.
    reflexivity.

    intros.
    destruct a.
    simpl.
    rewrite <- IHl2.
    rewrite list_rem_switch.
    reflexivity.
Qed.

Lemma list_without_id : forall (l : list predicate),
        list_without l l = nil.
Proof.
  intros.
  induction l.
    simpl ; reflexivity.

    destruct a.
    simpl.
    rewrite <- EqNat.beq_nat_refl.
    rewrite list_without_rem.
    rewrite IHl.
    simpl.
    reflexivity.
Qed.

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

Lemma same_rem : forall (W:Set) (l : list predicate)
                        (Ip Ip': predicate -> W -> Prop) (n : nat) ,
      same_Ip_list W Ip Ip' l -> same_Ip_list W Ip Ip' (list_rem l n).
Proof.
  intros.
  induction l.
    simpl.
    exact I.

    destruct a.
    case_eq (EqNat.beq_nat n n0).
      intros.
      simpl.
      rewrite H0.
      apply IHl.
      simpl in H.
      apply H.

      intros.
      simpl.
      rewrite H0.
      simpl.
      simpl in H.
      apply conj.
        apply H.

        apply IHl.
        apply H.
Qed.

Lemma same_alt_rem : forall (W:Set) (l : list predicate)
                            (Ip Ip': predicate -> W -> Prop)
                            (n : nat) (pred_asgmt : W -> Prop) ,
  same_Ip_list W Ip Ip' (list_rem l n) <->
    same_Ip_list W (alt_Ip Ip pred_asgmt (Pred n))
                   (alt_Ip Ip' pred_asgmt (Pred n)) l.
Proof.
  intros W l.
  induction l.
    intros.
    simpl.
    apply iff_refl.

    intros.
    rewrite same_cons.
    split.
      intros.
      apply conj.
      destruct a.
      case_eq (EqNat.beq_nat n n0).
        intros.
        pose proof (EqNat.beq_nat_true n n0 H0).
        rewrite H1 in *.
        simpl alt_Ip.
        rewrite <- EqNat.beq_nat_refl.
        reflexivity.

        intros.
        pose proof (EqNat.beq_nat_false n n0 H0).
        unfold alt_Ip.
        rewrite H0.
        simpl in H.
        rewrite H0 in H.
        rewrite same_cons in H.
        apply H.

      apply IHl.
      destruct a.
      simpl in H.
      case_eq (EqNat.beq_nat n n0).
        intros.
        rewrite H0 in H.
        exact H.

        intros.
        rewrite H0 in H.
        rewrite same_cons in H.
        apply H.

    intros.
    destruct H as [pf_eq pf_alt].
    destruct a.
    simpl list_rem.
    case_eq (EqNat.beq_nat n n0).
      intros.
      apply IHl with (pred_asgmt := pred_asgmt).
      exact pf_alt.

      intros.
      rewrite same_cons.
      apply conj.
        simpl in pf_eq.
        rewrite H in pf_eq.
        exact pf_eq.

        apply IHl with (pred_asgmt := pred_asgmt).
        exact pf_alt.
Qed.

Lemma same_preds_in : forall (W:Set)(alpha : SecOrder) (Ip Ip': predicate -> W -> Prop)
                             (Ir: W -> W -> Prop) (Iv : FOvariable -> W),
    same_Ip_list W Ip Ip' (preds_in alpha) ->
     (SOturnst W Iv Ip Ir alpha -> SOturnst W Iv Ip' Ir alpha).
Proof.
  intros W alpha.
  induction alpha.
    intros.
    destruct p; destruct f.
    simpl in *.
    destruct H.
    rewrite <- H.
    exact H0.

    intros.
    destruct f; destruct f0.
    simpl in *.
    exact H0.

    intros.
    destruct f; destruct f0.
    simpl in *.
    exact H0.

    intros.
    destruct f.
    simpl preds_in in *.
    rewrite SOturnst_allFO in *.
    intros d.
    apply IHalpha with (Ip := Ip).
      exact H.

      apply H0.

    intros.
    destruct f.
    simpl preds_in in *.
    rewrite SOturnst_exFO in *.
    destruct H0 as [d H0].
    exists d.
    apply IHalpha with (Ip := Ip).
      exact H.

      apply H0.

    intros.
    simpl in *.
    unfold not in *; intros.
    apply H0.
    apply IHalpha with (Ip := Ip').
      apply same_comm.
      exact H.

      exact H1.

    intros.
    rewrite SOturnst_conjSO in *.
    simpl preds_in in H.
    apply conj.
      apply IHalpha1 with (Ip := Ip).
        apply same_app2 with (l2 := (preds_in alpha2)).
        apply H.

        apply H0.

      apply IHalpha2 with (Ip := Ip).
        apply same_app2 with (l1 := (preds_in alpha1)).
        apply H.

        apply H0.

    intros.
    rewrite SOturnst_disjSO in *.
    simpl preds_in in H.
    destruct H0.
      left.
      apply IHalpha1 with (Ip := Ip).
        apply same_app2 with (l2 := (preds_in alpha2)).
        apply H.

        exact H0.

      right.
      apply IHalpha2 with (Ip := Ip).
        apply same_app2 with (l1 := (preds_in alpha1)).
        apply H.

        exact H0.

    intros.
    simpl in *.
    intros.
      apply IHalpha2 with (Ip := Ip).
        apply same_app2 with (l1 := (preds_in alpha1)).
        apply H.

        apply H0.
        apply IHalpha1 with (Ip := Ip').
          apply same_comm.
          apply same_app2 with (l2 := (preds_in alpha2)).
          exact H.

          exact H1.
(*
    intros.
    simpl in *.
    destruct p.
(*    split.
*)      intros.
      apply IHalpha2 with (Ip := Ip).
        apply same_app2 with (l1 := (preds_in alpha1)).
        apply H.

        apply H0.
        apply IHalpha1 with (Ip := Ip').
          apply same_comm.
          apply same_app2 with (l2 := (preds_in alpha2)).
          apply H.

          exact H1.

      intros.
      apply IHalpha1 with (Ip := Ip).
        apply same_app2 with (l2 := (preds_in alpha2)).
        apply H.

        apply H0.
        apply IHalpha2 with (Ip := Ip').
          apply same_comm.
          apply same_app2 with (l1 := (preds_in alpha1)).
          apply H.

          exact H1.
*)
    intros.
    destruct p.
    simpl preds_in in H.
    rewrite same_cons in *.
    rewrite SOturnst_allSO in *.
    intros.
    apply IHalpha with (Ip := (alt_Ip Ip pred_asgmt (Pred n))).
      apply same_alt_rem.
      apply same_rem.
      apply H.

      apply H0.

    intros.
    destruct p.
    rewrite SOturnst_exSO in *.
    destruct H0 as [pred_asgmt H0].
    exists pred_asgmt.
    simpl preds_in in H.
    rewrite same_cons in H.
    apply IHalpha with (Ip := (alt_Ip Ip pred_asgmt (Pred n))).
    apply same_alt_rem.
      apply same_rem.
      apply H.

      exact H0.

(*    intros.
    destruct p; destruct p0.
    simpl in *.
    rewrite <- H0 in H.
    destruct H.
    rewrite <- H.
    destruct H1.
    rewrite H1.
    reflexivity. *)
Qed.

Lemma same_preds_in_without : forall (W:Set) (l : list predicate)
                              (alpha : SecOrder) (Ip Ip': predicate -> W -> Prop)
                              (Ir: W -> W -> Prop) (Iv : FOvariable -> W),
    same_Ip_list W Ip Ip' (list_without (preds_in alpha) l) ->
     (SOturnst W Iv Ip Ir (list_closed_SO alpha l) ->
         SOturnst W Iv Ip' Ir (list_closed_SO alpha l)).
Proof.
  intros W l.
  induction l.
    intros.
    simpl in *.
    apply same_preds_in with (Ip := Ip).
      exact H.

      exact H0.

    intros.
    destruct a.
    simpl list_closed_SO in *.
    simpl list_without in H.
    rewrite SOturnst_allSO in *.
    intros.
    specialize (H0 pred_asgmt).
    apply IHl with (Ip := (alt_Ip Ip pred_asgmt (Pred n))).
      apply same_alt_rem.
      rewrite <- list_without_rem.
      exact H.

      exact H0.
Qed.

(* For universally closed formulas, Ip doesn't matter. *)
Lemma Ip_uni_closed : forall (W:Set) (alpha : SecOrder) (Iv: FOvariable -> W)
                             (Ip Ip': predicate -> W -> Prop)
                             (Ir: W -> W -> Prop)  ,
     SOturnst W Iv Ip Ir (uni_closed_SO alpha) -> SOturnst W Iv Ip' Ir (uni_closed_SO alpha).
Proof.
  intros.
  unfold uni_closed_SO in *.
  apply same_preds_in_without with (Ip := Ip).
    rewrite list_without_id.
    simpl; exact I.

    exact H.
Qed.


Require Import List.
Import ListNotations.

Require Import Cryptol.Lib.

Require Import Cryptol.Coqlib.

(* Works as long as you pass in enough fuel *)
(* just use the length of the list *)
Fixpoint get_each_n' {A : Type} (fuel : nat) (tot : nat) (l : list A) : list (list A) :=
  match l,fuel with
  | _ :: _,S fuel' => (firstn tot l) :: get_each_n' fuel' tot (list_drop tot l)
  | _,_ => nil
  end.

Definition get_each_n {A : Type} (tot : nat) (l : list A) :=
  get_each_n' (length l) tot l.

Lemma get_each_n'_fuel :
  forall {A} n (l : list A) fuel tot,
    (n >= length l)%nat ->
    (fuel >= length l)%nat ->
    tot <> O ->
    get_each_n' fuel tot l = get_each_n' (length l) tot l.
Proof.
  induction n; intros.
  destruct l; simpl in *; destruct fuel; try reflexivity; omega.
  destruct l. simpl in *.
  destruct fuel; reflexivity.
  assert (n >= length l)%nat by (simpl in *; omega).
  simpl. destruct tot; try omega.
  simpl. destruct fuel; simpl in *; try omega.
  f_equal.
  assert (tot = O \/ tot <> O) by omega.
  destruct H3. subst. simpl.
  eapply IHn; eauto; omega.
  assert (length (list_drop tot l) <= length l)%nat by (eapply list_drop_length; eauto).
  erewrite IHn; try omega.
  symmetry.
  eapply IHn; omega.
Qed.

Lemma get_each_n_head :
  forall {A : Type} (l l' : list A) n,
    n = length l ->
    n <> O ->
    get_each_n n (l ++ l') = [l] ++ get_each_n n l'.
Proof.
  induction l; intros.
  simpl in *. congruence.
  simpl in *.
  destruct n; inversion H.
  assert (n = O \/ n <> O) by omega.
  destruct H1. subst.
  destruct l; simpl in H1; try omega.
  simpl. unfold get_each_n. simpl. reflexivity.
  unfold get_each_n. simpl.
  rewrite firstn_app.
  rewrite list_drop_app.
  f_equal.
  unfold get_each_n in IHl.
  eapply get_each_n'_fuel; eauto.

  rewrite app_length.
  omega.
Qed.

Lemma get_each_n'_zero :
  forall {A} fuel (l : list A),
    l <> nil ->
    get_each_n' fuel O l = repeat [] fuel.
Proof.
  induction fuel; intros.
  simpl. destruct l; reflexivity.
  simpl. destruct l; try congruence.
  erewrite IHfuel; eauto.
Qed.

Lemma get_each_n'_map_commutes_strong :
  forall {A B : Type} (f : A -> B) len k l fuel n,
    (len >= Datatypes.length l)%nat ->
    (k >= fuel)%nat ->
    get_each_n' fuel n (map f l) = map (map f) (get_each_n' fuel n l).
Proof.
  induction len; induction k; intros.
  assert (fuel = O) by omega. subst. simpl.
  destruct l; reflexivity.
  destruct l; simpl in H; try omega.
  simpl. destruct fuel; simpl; reflexivity.
  destruct fuel; try omega.
  destruct l; simpl; reflexivity.
  assert (fuel = S k \/ k >= fuel)%nat by omega.
  destruct H1. subst.
  simpl. destruct l; simpl; auto.
  f_equal. erewrite <- firstn_map. reflexivity.
  replace (f a :: map f l) with (map f (a :: l)) by auto.
  erewrite list_map_drop.
  assert (n = O \/ n > O)%nat by omega.
  destruct H1. subst. repeat erewrite get_each_n'_zero by (simpl; congruence).
  eapply map_repeat_nil.
  eapply IHlen.
  eapply length_list_drop in H1.
  instantiate (1 := a :: l) in H1.
  omega. congruence.
  instantiate (1 := k). omega.
  eauto.
Qed.

Lemma get_each_n_map_commutes :
  forall {A B : Type} (f : A -> B) n l,
    get_each_n n (map f l) = map (map f) (get_each_n n l).
Proof.
  intros.
  unfold get_each_n.
  erewrite get_each_n'_map_commutes_strong.
  erewrite map_length. reflexivity.
  instantiate (1 := Datatypes.length l). omega.
  instantiate (1 := Datatypes.length (map f l)). omega.
Qed.

(* Everything below is for type_stream_of_bytes *)
Lemma get_each_n'_extra_fuel :
  forall {A} fuel fuel' n (l : list A),
    (fuel >= fuel')%nat ->
    (fuel' >= Datatypes.length l)%nat ->
    (n <> O) ->
    get_each_n' fuel n l = get_each_n' fuel' n l.
Proof.
  induction fuel; intros.
  assert (fuel' = O) by omega.
  subst. destruct l; simpl in *; try omega.
  reflexivity.
  assert (fuel' = S fuel \/ fuel >= fuel')%nat by omega.
  destruct H2. subst. reflexivity.

  destruct l; simpl.
  simpl in *.
  destruct fuel'; simpl; auto.

  destruct fuel'. simpl in H0; omega.
  simpl. f_equal.

  simpl in H0.
  assert (fuel >= fuel')%nat by omega.
  assert (fuel' >= length l)%nat by omega.
  destruct n; try congruence.

  unfold list_drop. fold list_drop.
  eapply IHfuel. omega.
  generalize (list_drop_length l n). intros. omega.
  congruence.
Qed.


Require Import bool.
Require Import nat.
Require Import syntax.
Require Import eval.
Require Import state.
Require Import dictionary.
Require Import equiv.
Require Import transform.
Require Import optimize.
Require Import fold_constants.
Require Import fold_constants_sound.

Theorem optimize_0plus_aexp_sound : atrans_sound optimize_0plus_aexp.
Proof.
    unfold atrans_sound, aequiv.
    intros a. induction a as [n|k|a1 IH1 a2 IH2|a1 IH1 a2 IH2|a1 IH1 a2 IH2].
    - reflexivity.
    - reflexivity.
    - simpl. intros env. destruct a1 as [[|n]|[n]|b1 b2|b1 b2|b1 b2];
        simpl;
        simpl in IH1;
        try rewrite IH1;
        rewrite IH2;
        reflexivity.
    - simpl. intros env. rewrite IH1, IH2. reflexivity.
    - simpl. intros env. rewrite IH1, IH2. reflexivity.
Qed.

Theorem optimize_0plus_bexp_sound : btrans_sound optimize_0plus_bexp.
Proof. apply btrans_is_sound. apply optimize_0plus_aexp_sound. Qed.

Theorem optimize_0plus_com_sound: ctrans_sound optimize_0plus_com.
Proof.
    apply ctrans_is_sound.
    - apply optimize_0plus_aexp_sound.
    - apply optimize_0plus_bexp_sound.
Qed.

Theorem optimize_aexp_sound : atrans_sound optimize_aexp.
Proof.
    apply (compose_aexp_sound fold_constants_aexp).
    - apply fold_constants_aexp_sound.
    - apply optimize_0plus_aexp_sound.
Qed.

Theorem optimize_bexp_sound : btrans_sound optimize_bexp.
Proof. apply btrans_is_sound. apply optimize_aexp_sound. Qed.

Theorem optimize_com_sound : ctrans_sound optimize_com.
Proof.
    apply ctrans_is_sound.
    - apply optimize_aexp_sound.
    - apply optimize_bexp_sound.
Qed.


Require Import Init.Init.
Require Import Relation.Relation.
Require Import Nat.Inductive.
Require Import Nat.Nature.

(* Recursion Theorem *)
Definition _rec_accept (F A a: J) :=
  λ f, fn f ∧ dom(f) ⊆ ω ∧ ran(f) ⊆ A ∧ ∅ ∈ dom(f) ∧ f[∅] = a ∧
    (∀ n, n ∈ ω → S(n) ∈ dom(f) → n ∈ dom(f) ∧ f[S(n)] = F[f[n]]).

Lemma _rec_fun: ∀ A, ∀ a, ∀ F, fn (∪{x: 𝒫(ω ⨉ A)| _rec_accept F A a x}).
Proof.
  intros A a F.
  pose (_rec_accept F A a) as P.
  pose ({x: 𝒫(ω ⨉ A)| P x}) as H.
  pose (∪H) as h.
  split.
  (* is relation *)
  + apply union_rel.
    intros f P1.
    destruct (sub_e _ _ _ P1) as [_ [[P2 _] _]].
    apply P2.
  (* is single value *)
  + intros a0.
    (* induction property *)
    pose (λ x, ∀ b1, ∀ b2, ⟨x, b1⟩ ∈ h → ⟨x, b2⟩ ∈ h → b1 = b2) as PI.
    assert (PI ∅) as P1.
    { intros b1 b2 P2 P3.
      destruct (union_e _ _ P2) as [H1 [Q1 Q2]].
      destruct (sub_e _ _ _ Q1) as [_ [Q3 [_ [_ [Q4 [Q5 _]]]]]].
      destruct (fval_e _ _ _ Q5 Q3 Q4) as [_ Q6].
      apply (eq_cl (λ x, x = b2) (Q6 _ Q2)).
      destruct (union_e _ _ P3) as [H2 [R1 R2]].
      destruct (sub_e _ _ _ R1) as [_ [R3 [_ [_ [R4 [R5 _]]]]]].
      destruct (fval_e _ _ _ R5 R3 R4) as [_ R6].
      apply (R6 _ R2). }
    (* induction step *)
    assert (induction_step PI) as P2.
    { intros k P2 P3 b1 b2 P4 P5.
      destruct (union_e _ _ P4) as [H1 [Q1 Q2]].
      destruct (sub_e _ _ _ Q1) as [_ [Q3 [_ [_ [_ [_ Q4]]]]]].
      destruct (Q4 _ P2 (dom_i _ _ _  Q2)) as [Q5 Q6].
      apply (eq_cl (λ x, x = b2) (fval_i _ _ _ Q3 Q2)).
      apply (eq_cr (λ x, x = b2) Q6).
      destruct (union_e _ _ P5) as [H2 [R1 R2]].
      destruct (sub_e _ _ _ R1) as [_ [R3 [_ [_ [_ [_ R4]]]]]].
      destruct (R4 _ P2 (dom_i _ _ _ R2)) as [R5 R6].
      apply (eq_cl (λ x, F[H1[k]] = x) (fval_i _ _ _ R3 R2)).
      apply (eq_cr (λ x, F[H1[k]] = x) R6).
      assert (H1[k] = H2[k]) as P6.
      { apply P3.
        + apply union_i.
          exists H1.
          split.
          - apply Q1.
          - apply (fval_i2 _ _ Q3 Q5).
        + apply union_i.
          exists H2.
          split.
          - apply R1.
          - apply (fval_i2 _ _ R3 R5). }
      apply (eq_cr (λ x, F[x] = F[H2[k]]) P6).
      apply eq_r. }
    destruct (LEM (a0 ∈ ω)) as [P3 | P3].
    - apply (induction_principle _ P1 P2 a0 P3).
    - intros b1 b2 P4 _.
      apply bot_e.
      apply P3.
      destruct (union_e _ _ P4) as [Hi [P5 P6]].
      destruct (sub_e _ _ _ P5) as [_ [_ [P7 _]]].
      apply (P7 _ (dom_i _ _ _ P6)).
Qed.

Lemma _rec_single_pair_accept: ∀ A, ∀ a, ∀ F, a ∈ A
  → `{⟨∅, a⟩} ∈ {x: 𝒫(ω ⨉ A)| _rec_accept F A a x}.
Proof.
  intros A a F P1.
  pose (_rec_accept F A a) as P.
  pose ({x: 𝒫(ω ⨉ A)| P x}) as H.
  pose (∪H) as h.
  apply sub_i.
  { apply power_i.
    intros x P2.
    apply (eq_cl (λ x, x ∈ ω ⨉ A) (sing_e _ _ P2)).
    apply cp_i.
    + apply empty_is_nat.
    + apply P1. }
  split.
  { apply sing_pair_is_fn. }
  split.
  { apply (eq_cr (λ x, x ⊆ ω) (sing_pair_dom ∅ a)).
    intros x P2.
    apply (eq_cl (λ x, x ∈ ω) (sing_e _ _ P2)).
    apply empty_is_nat. }
  split.
  { apply (eq_cr (λ x, x ⊆ A) (sing_pair_ran ∅ a)).
    intros x P2.
    apply (eq_cl (λ x, x ∈ A) (sing_e _ _ P2)).
    apply P1. }
  split.
  { apply (eq_cr (λ x, ∅ ∈ x) (sing_pair_dom ∅ a)).
    apply sing_i. }
  split.
  { apply fval_i.
    + apply sing_pair_is_fn.
    + apply sing_i. }
  { intros n P3 P4.
    apply bot_e.
    apply (empty_not_suc n).
    apply (sing_e _ _ (eq_cl (λ x, S(n) ∈ x) (sing_pair_dom ∅ a) P4)). }
Qed.

Lemma _rec_union_fn: ∀ A, ∀ a, ∀ F, ∀ f, ∀ x, ∀ y, a ∈ A → F ∈ A ↦ A
  → S(x) ∉  dom(f) → ⟨x, y⟩ ∈ f → x ∈ ω → f ∈ {x: 𝒫(ω ⨉ A)| _rec_accept F A a x}
  → fn (f ∪ `{⟨S(x), F[y]⟩}).
Proof.
  intros A a F f x y P1 P2 P3 P4 P5 P6.
  pose (_rec_accept F A a) as P.
  pose ({x: 𝒫(ω ⨉ A)| P x}) as H.
  pose (∪H) as h.
  apply piecewise_function.
  + destruct (sub_e _ _ _ P6) as [_ [Q1 _]].
    apply Q1.
  + apply sing_pair_is_fn.
  + apply (eq_cr (λ x, dom(f) ∩ x = ∅) (sing_pair_dom (S(x)) (F[y]))).
    apply (eq_cr (λ x, x = ∅) (inter2_s (dom(f)) (`{S(x)}))).
    apply inter2_empty.
    intros s P7 P8.
    apply P3.
    apply (eq_cr (λ s, s ∈ dom(f)) (sing_e _ _ P7) P8).
Qed.

Lemma _rec_union_accept: ∀ A, ∀ a, ∀ F, ∀ f, ∀ x, ∀ y, a ∈ A → F ∈ A ↦ A
  → S(x) ∉  dom(f) → ⟨x, y⟩ ∈ f → x ∈ ω → f ∈ {x: 𝒫(ω ⨉ A)| _rec_accept F A a x}
  → (f ∪ `{⟨S(x), F[y]⟩}) ∈ {x: 𝒫(ω ⨉ A)| _rec_accept F A a x}.
Proof.
  intros A a F f x y P1 P2 P3 P4 P5 P6.
  pose (_rec_accept F A a) as P.
  pose ({x: 𝒫(ω ⨉ A)| P x}) as H.
  pose (∪H) as h.
  apply sub_i.
  { apply power_i.
    intros z Q1.
    destruct (union2_e _ _ _ Q1) as [Q2 | Q2].
    + destruct (sub_e _ _ _ P6) as [Q3 _].
      apply (power_e _ _ Q3 _ Q2).
    + apply (eq_cl (λ z, z ∈ ω ⨉ A) (sing_e _ _ Q2)).
      apply cp_i.
      - apply (suc_is_nat _ P5).
      (*- destruct P2 as [Q3 [Q4 Q5]]. *)
      - apply (fmap_ran _ _ _ P2).
        apply fval_ran.
        * apply (fmap_fn _ _ _ P2).
        * destruct (sub_e _ _ _ P6) as [_ [_ [_ [Q6 _]]]].
          apply (eq_cr (λ x, y ∈ x) (fmap_dom _ _ _ P2)).
          apply (Q6 _ (ran_i _ _ _ P4)). }
  split.
  { apply (_rec_union_fn _ _ _ _ _ _ P1 P2 P3 P4 P5 P6). }
  split.
  { apply (eq_cr (λ x, x ⊆ ω) (union2_dom f `{⟨S(x), F[y]⟩})).
    apply union2_sub.
    + destruct (sub_e _ _ _ P6) as [_ [_ [Q3 _]]].
      apply Q3.
    + apply (eq_cr (λ x, x ⊆ ω) (sing_pair_dom (S(x)) (F[y]))).
      apply sing_sub_i.
      apply (suc_is_nat _ P5). }
  split.
  { apply (eq_cr (λ x, x ⊆ A) (union2_ran f `{⟨S(x), F[y]⟩})).
    apply union2_sub.
    + destruct (sub_e _ _ _ P6) as [_ [_ [_ [Q3 _]]]].
      apply Q3.
    + destruct (sub_e _ _ _ P6) as [_ [_ [_ [Q4 _]]]].
      apply (eq_cr (λ x, x ⊆ A) (sing_pair_ran (S(x)) (F[y]))).
      apply sing_sub_i.
      apply (fmap_ran _ _ _ P2).
      apply fval_ran.
      - apply (fmap_fn _ _ _ P2).
      - apply (eq_cr (λ x, y ∈ x) (fmap_dom _ _ _ P2)).
        apply Q4.
        apply (ran_i _ _ _ P4). }
  split.
  { destruct (sub_e _ _ _ P6) as [_ [_ [_ [_ [Q1 _]]]]].
    apply (eq_cr (λ x, ∅ ∈ x) (union2_dom f `{⟨S(x), F[y]⟩})).
    apply union2_il.
    apply Q1. }
  split.
  { apply fval_i.
    + apply (_rec_union_fn _ _ _ _ _ _ P1 P2 P3 P4 P5 P6).
    + destruct (sub_e _ _ _ P6) as [_ [Q1 [_ [_ [Q2 [Q3 _]]]]]].
      apply union2_il.
      apply (eq_cl (λ x, ⟨∅, x⟩ ∈ f) Q3).
      apply (fval_i2 _ _ Q1 Q2). }
  { apply (eq_cr (λ s, ∀ n, n ∈ ω → S(n) ∈ s
      → n ∈ s ∧ (f ∪ `{⟨S(x), F [y]⟩})[S(n)] = F[(f ∪ `{⟨S(x), F[y]⟩})[n]])
      (union2_dom f `{⟨S(x), F[y]⟩})).
    intros n Q1 Q2.
    destruct (union2_e _ _ _ Q2) as [Q3 | Q3].
    + split.
      - destruct (sub_e _ _ _ P6) as [_ [_ [_ [_ [_ [_ Q4]]]]]].
        destruct (Q4 _ Q1 Q3) as [Q5 _].
        apply union2_il.
        apply Q5.
      - destruct (sub_e _ _ _ P6) as [_ [Q4 [_ [_ [_ [_ Q5]]]]]].
        destruct (Q5 _ Q1 Q3) as [Q6 Q7].
        apply (eq_cl (λ s, s = F[(f ∪ `{⟨S(x), F[y]⟩})[n]])
          (union2_fvall _ _ _ Q4
          (_rec_union_fn _ _ _ _ _ _ P1 P2 P3 P4 P5 P6) Q3)).
        apply (eq_cl (λ s, f[S(n)] = F[s])
          (union2_fvall _ _ _ Q4
          (_rec_union_fn _ _ _ _ _ _ P1 P2 P3 P4 P5 P6) Q6)).
        apply Q7.
    + pose (eq_cl (λ x, S(n) ∈ x) (sing_pair_dom (S(x)) (F[y])) Q3) as Q4.
      pose (suc_unique _ _ P5 Q1 (sing_e _ _ Q4)) as Q5.
      pose (eq_cl (λ x, x ∈ dom(f)) Q5 (dom_i _ _ _ P4)) as Q6.
      destruct (sub_e _ _ _ P6) as [_ [Q7 [_ [_ [_ [_ _]]]]]].
      split.
      - apply union2_il.
        apply Q6.
      - apply (eq_cl (λ s, s = F[(f ∪ `{⟨S(x), F[y]⟩})[n]])
          (union2_fvalr _ _ _ (sing_pair_is_fn (S(x)) (F[y]))
          (_rec_union_fn _ _ _ _ _ _ P1 P2 P3 P4 P5 P6) Q3)).
        apply (eq_cl (λ s, `{⟨S(x), F[y]⟩}[S(n)] = F[s])
          (union2_fvall _ _ _ Q7
          (_rec_union_fn _ _ _ _ _ _ P1 P2 P3 P4 P5 P6) Q6)).
        apply fval_i.
        * apply sing_pair_is_fn.
        * apply sing_i2.
          apply opair_eq_i.
          ++apply (eq_cr (λ x, S(n) = S(x)) Q5).
            apply eq_r.
          ++apply (eq_cl (λ x, F[f[x]] = F[y]) Q5).
            apply (eq_cr (λ x, F[x] = F[y]) (fval_i _ _ _ Q7 P4)).
            apply eq_r. }
Qed.

Lemma _rec_dom: ∀ A, ∀ a, ∀ F, a ∈ A → F ∈ A ↦ A
  → dom(∪{x: 𝒫(ω ⨉ A)| _rec_accept F A a x}) = ω.
Proof.
  intros A a F P1 S1.
  pose (_rec_accept F A a) as P.
  pose ({x: 𝒫(ω ⨉ A)| P x}) as H.
  pose (∪H) as h.
  assert (inductive (dom(h))) as P2.
  { split.
    + apply (dom_i _ _ a).
      apply union_i.
      exists (`{⟨∅, a⟩}).
      split.
      - apply (_rec_single_pair_accept _ _ _ P1).
      - apply sing_i.
    + intros x P2.
      destruct (dom_e _ _ P2) as [y P3].
      destruct (union_e _ _ P3) as [f [P4 P5]].
      destruct (LEM (S(x) ∈ dom(f))) as [P6 | P6].
      - apply (dom_i _ _ (f[S(x)])).
        apply union_i.
        exists f.
        split.
        * apply P4.
        * destruct (sub_e _ _ _ P4) as [_ [P7 _]].
          apply (fval_i2 _ _ P7 P6).
      - pose (f ∪ `{⟨S(x), F[y]⟩}) as g.
        apply (dom_i _ _ (g[S(x)])).
        apply union_i.
        exists (f ∪ `{⟨S(x), F[y]⟩}).
        assert (x ∈ ω) as P7.
        { destruct (sub_e _ _ _ P4) as [_ [_ [P7 _]]].
          apply P7.
          apply (dom_i _ _ y).
          apply P5. }
        split.
        * apply (_rec_union_accept _ _ _ _ _ _ P1 S1 P6 P5 P7 P4).
        * destruct (sub_e _ _ _ P4) as [_ [P8 _]].
          apply fval_i2.
          apply (_rec_union_fn _ _ _ _ _ _ P1 S1 P6 P5 P7 P4).
          apply (eq_cr (λ s, S(x) ∈ s) (union2_dom f (`{⟨S(x), F[y]⟩}))).
          apply union2_ir.
          apply (eq_cr (λ s, S(x) ∈ s) (sing_pair_dom (S(x)) (F[y]))).
          apply sing_i. }
  assert (dom(h) ⊆ ω) as P3.
  { intros x P3.
    destruct (dom_e _ _ P3) as [y P4].
    destruct (union_e _ _ P4) as [f [P5 P6]].
    destruct (sub_e _ _ _ P5) as [_ [_ [P7 _]]].
    apply (P7 _ (dom_i _ _ _ P6)). }
  apply (inductive_subset_omega_coincident _ P3 P2).
Qed.

Lemma _rec_ran: ∀ A, ∀ a, ∀ F, a ∈ A
  → ran(∪{x: 𝒫(ω ⨉ A)| _rec_accept F A a x}) ⊆ A.
Proof.
  intros A a F P1 y P2.
  destruct (ran_e _ _ P2) as [x P3].
  destruct (union_e _ _ P3) as [f [P4 P5]].
  destruct (sub_e _ _ _ P4) as [_ [_ [_ [P6 _]]]].
  apply (P6 _ (ran_i _ _ _ P5)).
Qed.

Theorem recursion_thm: ∀ A, ∀ a, ∀ F, ∃ h, a ∈ A → F ∈ A ↦ A
  → h ∈ ω ↦ A ∧ h[∅] = a ∧ (∀ n, n ∈ ω → h[S(n)] = F[h[n]]).
Proof.
  intros A a F.
  pose (_rec_accept F A a) as P.
  pose ({x: 𝒫(ω ⨉ A)| P x}) as H.
  pose (∪H) as h.
  exists h.
  intros P1 P2.
  split.
  (* fover h ω A *)
  { apply fmap_i.
    + apply _rec_fun.
    + apply (_rec_dom _ _ _ P1 P2).
    + apply (_rec_ran _ _ _ P1). }
  split.
  { apply fval_i.
    + apply _rec_fun.
    + apply union_i.
      exists (`{⟨∅, a⟩}).
      split.
      - apply (_rec_single_pair_accept _ _ _ P1).
      - apply sing_i. }
  { intros n P3.
    pose (eq_cr (λ x, S(n) ∈ x) (_rec_dom A a F P1 P2) (suc_is_nat _ P3)) as P4.
    destruct (dom_e _ _ P4) as [y P5].
    destruct (union_e _ _ P5) as [f [P6 P7]].
    destruct (sub_e _ _ _ P6) as [_ [P8 [_ [_ [_ [_ P9]]]]]].
    destruct (P9 n P3 (dom_i _ _ _ P7)) as [P10 P11].
    apply (eq_cl (λ x, x = F[h[n]])
      (union_fval _ _ _ P6 P8 (_rec_fun A a F) (dom_i _ _ _ P7))).
    apply (eq_cl (λ x, f[S(n)] = F[x])
      (union_fval _ _ _ P6 P8 (_rec_fun A a F) P10)).
    apply P11. }
Qed.
(*----------------------------------------------------------------------------*)


Require Import Coqlib.
Require Import Lattice.
Require Import OrderedType.

Require Import AliasFMapAVLPlus.
Require Import AliasLib.

Module MapSemiLattice
  (KEY: OrderedType)
  (VAL: SEMILATTICE)
  <: SEMILATTICE.

  Module M := FMapAVLPlus(KEY).

  Module FMF := FMapFacts.WFacts_fun KEY M.

  Definition t := M.t VAL.t.

  Definition eq (x y: t): Prop :=
    forall k,
      match M.find k x, M.find k y with
      | None, None     => True
      | Some a, Some b => VAL.eq a b
      | _, _           => False
      end.

  Theorem eq_refl: forall x, eq x x.
  Proof.
    repeat intro. destruct M.find. apply VAL.eq_refl. auto.
  Qed.

  Theorem eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    repeat intro. unalias. specialize (H k).
    destruct M.find; destruct M.find; auto. apply VAL.eq_sym. auto.
  Qed.

  Theorem eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    repeat intro. unalias. specialize (H k). specialize (H0 k).
    destruct M.find; destruct M.find; destruct M.find; auto.
    eapply VAL.eq_trans; eauto. contradiction.
  Qed.

  Definition beq: t -> t -> bool := M.equal VAL.beq.

  Theorem beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    repeat intro. apply M.equal_2 in H. inv H.
    destruct (M.find k x) as []_eqn; destruct (M.find k y) as []_eqn; auto.
    apply VAL.beq_correct. eapply H1; apply FMF.find_mapsto_iff; eauto.
    apply FMF.not_find_in_iff in Heqo0. elim Heqo0. apply H0.
    apply FMF.in_find_iff. congruence.
    apply FMF.not_find_in_iff in Heqo. elim Heqo. apply H0.
    apply FMF.in_find_iff. congruence.
  Qed.

  (* Assuming None is the same as bot *)
  Definition ge_m k x y :=
    match M.find k x, M.find k y with
    | None,   None   => True
    | Some a, Some b => VAL.ge a b
    | Some _, None   => True
    | None,   Some b => VAL.ge VAL.bot b
    end.
  Definition ge x y := forall k, ge_m k x y.
  Hint Unfold ge ge_m: unalias.

  Theorem ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    repeat intro. unalias. specialize (H k).
    destruct (M.find k x) as []_eqn; destruct (M.find k y) as []_eqn; auto.
    apply VAL.ge_refl. auto. contradiction.
  Qed.

  Theorem ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    repeat intro. unalias. specialize (H k). specialize (H0 k).
    destruct (M.find k x) as []_eqn; destruct (M.find k y) as []_eqn;
    destruct (M.find k z) as []_eqn; auto.
    eapply VAL.ge_trans; eauto.
    eapply VAL.ge_trans. apply VAL.ge_bot. auto.
    eapply VAL.ge_trans. eauto. auto.
  Qed.

  Definition bot: t := M.empty VAL.t.

  Theorem ge_bot: forall x, ge x bot.
  Proof.
    repeat intro. unalias.
    destruct (M.find k x) as []_eqn; rewrite FMF.empty_o; auto.
  Qed.

  Definition merge (k: KEY.t) o1 o2 :=
    match o1, o2 with
    | None,   None   => None
    | Some s, None   => Some (VAL.lub s VAL.bot)
    | None,   Some s => Some (VAL.lub VAL.bot s)
    | Some x, Some y => Some (VAL.lub x y)
    end.

  Theorem merge_compat:
    forall x y o1 o2,
      KEY.eq x y -> merge x o1 o2 = merge y o1 o2.
  Proof.
    reflexivity.
  Qed.

  Definition lub (m: t) (n: t): t :=
    M.map2i merge merge_compat m n.

  Ltac msimpl :=
    repeat (
      unfold not in *; try
        match goal with
        | H: M.find _ _ = Some _ |- _ =>
          apply FMF.find_mapsto_iff in H
        | H: M.find _ _ = None |- _ =>
         apply FMF.not_find_in_iff in H
        | H: M.MapsTo _ _ (M.empty _) |- _ => inversion H
        | H: M.MapsTo _ _ (M.add _ _ _) |- _ =>
         apply FMF.add_mapsto_iff in H; simpl in H; intuition; subst; auto
        | A: M.MapsTo ?x ?s0 ?m,
          B: M.MapsTo ?x ?s1 ?m |- _ =>
            assert (s0 = s1) by (
              apply FMF.find_mapsto_iff in A;
                apply FMF.find_mapsto_iff in B;
                  rewrite A in B; inversion_clear B; reflexivity
            ); subst; clear B
        | A: M.MapsTo ?x ?s ?m,
          B: M.In ?x (M.add _ _ ?m) -> False |- _ =>
            elim B; apply FMF.add_in_iff; right; exists s; exact A
        | A: M.MapsTo ?x ?s ?m,
          B: M.In ?x ?m -> False |- _ =>
            elim B; exists s; exact A
        | A: M.In ?x ?m -> False,
          B: M.MapsTo ?x ?s (M.add ?y _ ?m),
          C: ?x = ?y -> False |- _ =>
            apply FMF.add_neq_mapsto_iff in B;
              [elim A; exists s; exact B | ]
        | A: M.MapsTo ?x ?s ?m,
          B: M.In ?x (M.mapi _ ?m) -> False |- _ =>
            elim B; apply FMF.mapi_in_iff; exists s; exact A
        | A: M.In ?x ?m -> False,
          B: M.MapsTo ?x ?s (M.mapi _ ?m) |- _ =>
            elim A; rewrite <- FMF.mapi_in_iff; exists s; apply B
        end
    ).

  Theorem ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    repeat intro. unalias.
    destruct (M.find k (lub x y)) as []_eqn, (M.find k x) as []_eqn; msimpl; auto.
    unfold lub in Heqo.
    pose proof M.map2i_1. specialize (H _ _ _ merge merge_compat x y k).
    feed H. left. now exists t1.
    setoid_rewrite (proj1 (M.FMF.find_mapsto_iff _ _ _)) in H at 2; [|eauto]. simpl in H.
    destruct (M.find k y) as []_eqn; msimpl.
    apply VAL.ge_lub_left. apply VAL.ge_lub_left.
    elim Heqo. unfold lub.
    pose proof M.map2i_1. specialize (H _ _ _ merge merge_compat x y k).
    feed H. left. now exists t0.
    replace (M.find k x) with (Some t0) in H. simpl in H.
    destruct (M.find k y) as []_eqn; msimpl.
    destruct (M.find k x) as []_eqn; msimpl; reflexivity.
  Qed.

(*
  Lemma find_merge_some_left:
    forall k x y s,
    M.find k (M.map2i merge merge_compat x y) = merge k (Some s) (M.find k y) ->
    exists s', M.MapsTo k s' (M.map2i merge merge_compat x y) /\ VAL.ge s' s.
  Proof.
    intros. edestruct (merge_some_left _ _ _) as [s' M]. rewrite M in H. exists s'.
    split. now msimpl. pose proof ge_merge_left as GE. TODO. apply ge_merge_left.

    pose proof merge_some_left.
    edestruct H0 as [s' M]. rewrite M in H. pose proof ge_merge_left as ML. setoid_rewrite M in ML. apply ge_merge_left in M.
    setoid_rewrite (merge_some_left _ _ _) in H.

    erewrite merge_some_left in H.
*)

  Theorem ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    repeat intro. unalias.
    destruct (M.find k (lub x y)) as []_eqn, (M.find k y) as []_eqn; msimpl;
      auto.
    unfold lub in Heqo.
    pose proof M.map2i_1. specialize (H _ _ _ merge merge_compat x y k).
    feed H. right. now exists t1.
    replace (M.find k y) with (Some t1) in H.
    destruct (M.find k x) as []_eqn; simpl in H; msimpl; auto.
    apply VAL.ge_lub_right. apply VAL.ge_lub_right.
    destruct (M.find k y) as []_eqn; msimpl; reflexivity.
    elim Heqo. unfold lub.
    pose proof M.map2i_1. specialize (H _ _ _ merge merge_compat x y k).
    feed H. right. now exists t0.
    replace (M.find k y) with (Some t0) in H.
    destruct (M.find k x) as []_eqn; simpl in H; msimpl.
    destruct (M.find k y) as []_eqn; simpl in H; msimpl; reflexivity.
  Qed.

  Definition ge_k m j k :=
    match M.find j m, M.find k m with
    | None,   None   => True
    | Some a, Some b => VAL.ge a b
    | Some _, None   => True
    | None,   Some b => VAL.ge VAL.bot b
    end.
  Hint Unfold ge_k: unalias.

  Theorem lub_preserves_ge_k: forall m n x px
    (* TODO: possibly move these axioms in SEMILATTICE signature *)
    (LUB_INC_L: forall a b, VAL.ge a b ->
      forall c, VAL.ge (VAL.lub c a) (VAL.lub c b))
    (LUB_GE: forall a b c d,
      VAL.ge a b -> VAL.ge c d -> VAL.ge (VAL.lub a c) (VAL.lub b d))
    (LUB_BOT: forall a b,
      VAL.eq a VAL.bot -> VAL.eq b VAL.bot -> VAL.eq (VAL.lub a b) VAL.bot)
    (GE_BOT_EQ: forall x,
      VAL.ge VAL.bot x <-> VAL.eq VAL.bot x)
    ,
    ge_k m px x ->
    ge_k n px x ->
    ge_k (lub m n) px x.
  Proof.
    intros. unalias.

    pose proof M.map2i_1 as M2Ix.
    specialize (M2Ix _ _ _ merge merge_compat m n x).
    pose proof M.map2i_1 as M2Ipx.
    specialize (M2Ipx _ _ _ merge merge_compat m n px).

    destruct (M.find x (lub m n)) as []_eqn,
      (M.find px (lub m n)) as []_eqn,
      (M.find x m) as []_eqn, (M.find px m) as []_eqn,
      (M.find x n) as []_eqn, (M.find px n) as []_eqn;
      msimpl; auto; unfold lub in *;
    repeat (
      match goal with
      | I: M.In ?x ?m \/ _ -> _,
        M: M.MapsTo ?x ?v ?m |- _ =>
          feed I; [left; exists v; apply M|]; simpl in I; msimpl
      | I: _ \/ M.In ?x ?m -> _,
        M: M.MapsTo ?x ?v ?m |- _ =>
          feed I; [right; exists v; apply M|]; simpl in I; msimpl
      | Hm: M.In ?x ?m -> False,
        Hn: M.In ?x ?n -> False,
        MT: M.MapsTo ?x _ (M.map2i _ _ ?m ?n)
        |- _ =>
        apply M.FMF.find_mapsto_iff in MT; rewrite M.map2i_3 in MT;
          [ congruence|now simpl|now apply M.FMF.not_find_in_iff|now apply M.FMF.not_find_in_iff]
      end
    ); try solve
    [ now apply LUB_GE
    | apply LUB_GE; [easy | apply VAL.ge_bot]
    ].
    apply LUB_GE. apply VAL.ge_bot. easy.
    eapply VAL.ge_trans. apply VAL.ge_bot. apply VAL.ge_refl. apply VAL.eq_sym.
    apply LUB_BOT. apply VAL.eq_refl. apply VAL.eq_sym; now apply GE_BOT_EQ.
    now apply LUB_INC_L.
    apply GE_BOT_EQ. apply VAL.eq_sym. apply LUB_BOT; apply VAL.eq_sym; now apply GE_BOT_EQ.
    apply GE_BOT_EQ. apply VAL.eq_sym. apply LUB_BOT. apply VAL.eq_sym; now apply GE_BOT_EQ. apply VAL.eq_refl.
    apply GE_BOT_EQ. apply VAL.eq_sym. apply LUB_BOT. apply VAL.eq_refl. apply VAL.eq_sym; now apply GE_BOT_EQ.
  Qed.

  Theorem not_in_lub: forall m n x,
    ~ M.In x (lub m n) ->
    ~ M.In x m /\ ~ M.In x n.
  Proof.
    intros. unfold lub in H. pose proof M.map2i_1 as M2I.
    specialize (M2I _ _ _ merge merge_compat m n x). split; intro IN; apply H.
    apply M.FMF.in_find_iff. rewrite M2I; [|now left]. apply M.FMF.in_find_iff in IN.
    destruct (M.find x m), (M.find x n); simpl; congruence.
    apply M.FMF.in_find_iff. rewrite M2I; [|now right]. apply M.FMF.in_find_iff in IN.
    destruct (M.find x m), (M.find x n); simpl; congruence.
  Qed.

End MapSemiLattice.