Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListDec.
Require Import Coq.Lists.SetoidList.
Require Import Coq.Wellfounded.Inverse_Image.
Require Import Omega.

(*Helper Lemmas and tactics*)

Definition null {a} (l: list a) :=
  match l with
  | nil => true
  | _ => false
  end.

Ltac simplify' := try(rewrite andb_diag in *); try(rewrite andb_true_iff in *); try(rewrite negb_true_iff in *);
  try(rewrite andb_false_iff in *); try(rewrite negb_false_iff in *); intuition.

Ltac destruct_all :=
repeat(match goal with
            |[H: (exists _, _) |- _] => destruct H
            |[H: _ /\ _ |- _] => destruct H
            end; try(rewrite andb_true_iff in *)).

(*Solve trivial goals that can be solved by [assumption] and [reflexivity]*)
Ltac solve_assume := repeat(split; try(intros); try(assumption); try(reflexivity)).

(*Ltac for solving statements of the form: In x l, where l may be many lists appended together*)
Ltac solve_in :=
  match goal with
  | [ H : _ |- In ?x (?l ++ ?r)] => apply in_or_app; solve_in
  | [ H : _ |- In ?x ?s \/ In ?x ?s'] => first [ left; solve_in | right; solve_in ]
  | [ H : _ |- In ?x (?x :: ?l)] => simpl; left; reflexivity
  | [ H : _ |- In ?x (?a :: ?l)] => simpl; right; solve_in
  | [ H : _ |- _ ] => try(reflexivity); assumption
end.

(*Destruct if-then-else statments in either the goal or hypothesis*)
Ltac destruct_if :=
  match goal with
    | [H: (if ?b then _ else _) = _ |- _] => destruct b
    | [H: _ |- (if ?b then _ else _) = _ ] => destruct b
    end.

(*If [x] is in the list [l], we can find the first occurence of [x] in the list*)
Lemma in_split_app_fst: forall (A: Type) (l: list A) (x: A),
  (forall x y : A, {x = y} + {x <> y}) ->
  In x l ->
  exists l1 l2, l = l1 ++ (x :: l2) /\ forall y, In y l1 -> y <> x.
Proof.
  intros. induction l.
  - inversion H.
  - destruct (X x a). subst. exists nil. exists l. split. reflexivity. intros. inversion H0.
    simpl in H. destruct H. subst. contradiction.  apply IHl in H. destruct_all.
    exists (a :: x0). exists x1. split. rewrite H. reflexivity. intros. intro. subst.
    simpl in H1. destruct H1. subst. contradiction. apply H0 in H. contradiction.
Qed.

(*A list has a duplicate iff we can write l as l1 ++ w :: l2 ++ w :: l3 for some w*)
Lemma no_no_dup: forall (A: Type) (l: list A),
  (forall x y : A, {x = y} + {x <> y}) ->
  ~(NoDup l) <-> (exists w l1 l2 l3, l = l1 ++ w :: l2 ++ w :: l3).
Proof.
  intros. split; intros.
  - induction l.
    + assert (@NoDup A nil). constructor. contradiction.
    + destruct (NoDup_dec X l).
      * assert (In a l). destruct (In_dec X a l). apply i.
        assert (NoDup (a :: l)). constructor. apply n0. apply n. contradiction.
        apply in_split_app_fst in H0. destruct_all. exists a. exists nil. exists x. exists x0.
        rewrite H0. reflexivity. apply X.
      * apply IHl in n. destruct_all. exists x. exists (a :: x0). exists x1. exists x2. rewrite H0.
        reflexivity.
  -  intro. destruct_all.  subst. induction x0; simpl in *.
    + rewrite NoDup_cons_iff in H0. destruct_all. apply H.
    solve_in.
    + simpl in H0. rewrite NoDup_cons_iff in H0. destruct_all. apply IHx0. apply H0.
Qed.

Lemma In_InA_equiv: forall A (x : A) l,
    In x l <-> InA eq x l.
  Proof.
    intros. induction l.
    - simpl. split; intros.
      + destruct H.
      + apply InA_nil in H. destruct H.
    - simpl. split; intros.
      + apply InA_cons. destruct H. left. subst. reflexivity. right. apply IHl. assumption.
      + apply InA_cons in H. destruct H. left. subst. reflexivity. right. apply IHl. assumption.
  Qed.

Lemma NoDup_NoDupA: forall {a} (l: list a),
  NoDup l <-> NoDupA eq l.
Proof.
  intros; split; intros; induction H; try(constructor).
  - rewrite <- In_InA_equiv. assumption.
  - assumption.
  - rewrite In_InA_equiv. assumption.
  - assumption.
Qed.

Lemma contrapositive: forall (P Q : Prop), (P -> Q) -> (~Q -> ~P).
Proof.
  tauto.
Qed.

(*If (x,y) is the only occurrence of x in l, we can find the first occurrence of (x,y)*)
Lemma in_split_app_fst_map: forall {A B: Type} {Eq1: (forall x y : A, {x = y} + {x <> y})}
   {Eq2: forall x y : B, {x = y} + {x <> y}}  (l: list (A * B)) x y,
  In (x, y) l ->
  (forall y', In (x, y') l -> y = y') ->
  exists l1 l2, l = l1 ++ ((x, y) :: l2) /\ forall y, In y (map fst l1) -> y <> x.
Proof.
  intros. induction l.
  - inversion H.
  - destruct a. simpl. destruct (Eq2 y b). subst. destruct (Eq1 x a). subst. exists nil.
    exists l. split. reflexivity. intros. inversion H1.
    subst. simpl in H. destruct H. inversion H; subst. contradiction.
     apply IHl in H. destruct_all.
    exists ((a, b) :: x0). exists x1. split. rewrite H. reflexivity. intros. intro. subst.
    simpl in H2. destruct H2. subst. contradiction. apply H1 in H. contradiction.
    intros. apply H0. solve_in. destruct (Eq1 x a). subst. assert (y = b). apply H0.
    simpl. left. reflexivity. subst. contradiction. simpl in H. destruct H.
    inversion H; subst; contradiction. apply IHl in H.
    destruct_all. exists ((a, b) :: x0). exists x1. split. rewrite H. simpl. reflexivity.
    intros. simpl in H2. destruct H2. subst. intro. subst. contradiction. apply H1. assumption.
    intros. apply H0. solve_in.
Qed.

(*A more general form, if (x,y) is in l for some y, then there is a y' so that (x,y') is the first
  occurence of x*)
Lemma in_split_app_special:  forall {A B: Type} {Eq1: (forall x y : A, {x = y} + {x <> y})}
    (l: list (A * B)) x,
  In x (map fst l) ->
  exists y l1 l2, l = l1 ++ ((x, y) :: l2) /\ forall y, In y (map fst l1) -> y <> x.
Proof.
  intros. induction l.
  - destruct H.
  - simpl in *. destruct a. destruct (Eq1 x a). subst. destruct H. simpl in H. inversion H; subst. exists b.
    exists nil. exists l. split. reflexivity. intros. destruct H1.
    exists b. exists nil. exists l. split. reflexivity. intros. inversion H0.
    destruct H. simpl in H. inversion H. subst. contradiction.
    apply IHl in H. destruct_all. exists x0. exists ((a, b) :: x1). exists x2. split. rewrite H. reflexivity.
    intros. simpl in H1. destruct H1. subst. auto. apply H0. assumption.
Qed.

(*If l1 ++ l2 is sorted, anything in l1 is less than anything in l2*)
Lemma sort_app: forall {A : Type} (l1 l2 : list A) R,
  Sorted R (l1 ++ l2) ->
  Relations_1.Transitive R ->
  (forall x y, In x l1 -> In y l2 -> R x y).
Proof.
  intros. generalize dependent l2. induction l1; intros.
  - simpl in H. destruct H1.
  - simpl in H. apply Sorted_StronglySorted in H. inversion H. subst.
    rewrite Forall_forall in H6. simpl in H1.
    destruct H1. subst. apply H6. solve_in. eapply IHl1.
    assumption. apply StronglySorted_Sorted . apply H5.
    assumption. assumption.
Qed.

Lemma NoDup_pairs: forall {a b} (l1 : list (a * b)) x y y',
  NoDup (map fst l1) ->
  In (x,y) l1 ->
  In (x, y') l1 ->
  y = y'.
Proof.
  intros. induction l1.
  - destruct H0.
  - simpl in *. destruct a0. simpl in H. inversion H. subst.
    destruct H0. inversion H0; subst. destruct H1. inversion H1; subst.
    reflexivity. assert (In x (map fst l1)). rewrite in_map_iff. exists (x, y').
    simpl. split. reflexivity. assumption. contradiction.
    destruct H1. inversion H1; subst. assert (In x (map fst l1)). rewrite in_map_iff.
    exists (x, y). simpl. split. reflexivity. assumption. contradiction.
    apply IHl1; assumption.
Qed.

Lemma NoDup_pairs': forall {a b} (l1 : list (a * b)) x y y',
  NoDup (map snd l1) ->
  In (y, x) l1 ->
  In (y', x) l1 ->
  y = y'.
Proof.
  intros. induction l1.
  - destruct H0.
  - simpl in *. destruct a0. simpl in H. inversion H. subst.
    destruct H0. inversion H0; subst. destruct H1. inversion H1; subst.
    reflexivity. assert (In x (map snd l1)). rewrite in_map_iff. exists (y', x).
    simpl. split. reflexivity. assumption. contradiction.
    destruct H1. inversion H1; subst. assert (In x (map snd l1)). rewrite in_map_iff.
    exists (y, x). simpl. split. reflexivity. assumption. contradiction.
    apply IHl1; assumption.
Qed.

(*Function to find the first two elements in a list (x,y) such that x satisfies f and y does not. This is used (
  in reverse) in the proof of Dijkstra's to assert that there is a first vertex in S such that its successor
  is not in S*)
Fixpoint split_function {A : Type} (f: A -> bool) (l: list A) :=
  match l with
  | nil => None
  | x :: l' =>
    match l' with
    | nil => None
    | y :: t =>  if (f x) then if negb (f y) then (Some (x,y)) else (split_function f l')
                                   else None
    end
  end.

Lemma rewrite_split_function: forall {A} (f: A -> bool) x y l,
  split_function f (x :: y :: l) = if (f x) then if negb (f y) then (Some (x,y)) else (split_function f (y :: l))
                                   else None.
Proof.
  intros. simpl. reflexivity.
Qed.

(*Correctness*)
Lemma split_function_some: forall {A} f (l: list A) x y,
  split_function f l = Some (x,y) <-> exists l1 l2, l = l1 ++ x :: y :: l2 /\
  f x = true /\ f y = false /\ forall z, In z l1 -> f z = true.
Proof.
  intros. revert x y. induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)); intros; split; intros.
  - destruct l. inversion H0. destruct l. inversion H0.
    rewrite rewrite_split_function in H0. remember (split_function f (a0 :: l)) as S.
    destruct (f a) eqn : F. destruct (f a0) eqn : F'. simpl in H0.
    rewrite HeqS in H0. apply H in H0. destruct_all.
    exists (a :: x0). exists x1.
    split. simpl. rewrite H0. reflexivity. repeat(split; try(assumption)).  intros.
    simpl in H4. destruct H4. subst. assumption. apply H3. assumption. simpl. omega.
    simpl in H0. inversion H0; subst. exists nil. exists l. split. reflexivity.
    repeat(split; try assumption). intros. inversion H1. inversion H0.
  - destruct H0 as [l1]. destruct H0 as [l2]. destruct_all. destruct l. destruct l1; inversion H0.
    destruct l. destruct l1; inversion H0. destruct l1; inversion H6.
    rewrite rewrite_split_function. destruct l1. simpl in H0. inversion H0; subst. rewrite H1. rewrite H2. simpl.
    reflexivity. assert (f a = true). apply H3. inversion H0; subst. left. reflexivity. rewrite H4.
    destruct l1. simpl in H0; inversion H0; subst. rewrite H1.
    destruct (negb true) eqn : N. inversion N. clear N. rewrite H. exists nil. exists l2.
    split. reflexivity. repeat(split; try assumption). intros. inversion H5. simpl. omega.
    assert (f a0 = true). apply H3. inversion H0; subst. right. left. reflexivity. rewrite H5.
    destruct (negb true) eqn : F. inversion F. clear F. rewrite H. inversion H0; subst.
    exists (a2 :: l1). exists l2. split. simpl. reflexivity. simplify'.
    simpl. omega.
Qed.

Definition rev_split_function {A : Type} (f: A -> bool) (l: list A) :=
  split_function f (rev l).

Lemma rev_split_function_def:  forall {A} f (l: list A) x y,
  rev_split_function f l = Some (x,y) <-> exists l1 l2, l = l1 ++ y :: x :: l2 /\
  f x = true /\ f y = false /\ forall z, In z l2 -> f z = true.
Proof.
  intros. unfold rev_split_function. rewrite split_function_some. split; intros; destruct_all.
  assert (rev (rev l) = rev (x0 ++ x :: y :: x1)). rewrite H. reflexivity. rewrite rev_involutive in H3.
  rewrite rev_app_distr in H3. simpl in H3. exists (rev x1). exists (rev x0). simplify'.
  rewrite H3. rewrite <- app_assoc. simpl. rewrite <- app_assoc. simpl. reflexivity.
  apply H2. rewrite in_rev. assumption.
  assert (rev l = rev (x0 ++ y :: x :: x1)). rewrite H. reflexivity.
  rewrite rev_app_distr in H3. simpl in H3. exists (rev x1). exists (rev x0). simplify'.
  rewrite H3. rewrite <- app_assoc. simpl. rewrite <- app_assoc. simpl. reflexivity. apply H2.
  rewrite in_rev. assumption.
Qed.

Lemma split_function_exists: forall {A} (f: A -> bool) h t,
  f h = true ->
  (exists x y, (split_function f (h :: t)) = Some (x,y)) <-> exists x, In x t /\ f x = false.
Proof.
  intros. remember (h :: t) as l. generalize dependent h. revert t.
  induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)); intros; split; intros.
  - subst. destruct t. simpl in H1. destruct_all. inversion H1.
    destruct H1 as [x]. destruct H1 as [y]. rewrite rewrite_split_function in H1.
    rewrite H0 in H1. destruct (f a) eqn : F.
     + destruct (negb true) eqn : N. inversion N. clear N.
       assert (exists x y, split_function f (a :: t) = Some (x,y)). exists x. exists y. assumption.
       rewrite H in H2. 3 : { apply F. } 3 : { reflexivity. } destruct_all. exists x0. simplify'.
       simpl. omega.
     + destruct (negb false) eqn : N. inversion H1; subst. exists y. simplify'.
       inversion N.
  - subst. destruct_all. destruct t. inversion H1. simpl in H1. destruct H1. subst.
    exists h. exists x. simpl. rewrite H0. rewrite H2. simpl. reflexivity.
    rewrite rewrite_split_function. rewrite H0.
    destruct (negb (f a)) eqn : N. exists h. exists a. reflexivity. assert (f a = true).
    destruct (f a) eqn : F. reflexivity. inversion N. clear N.
    rewrite H. 3 : { apply H3. } 3 : { reflexivity. } exists x. simplify'. simpl. omega.
Qed.

Lemma rev_split_function_exists: forall {A} (f: A -> bool) h t,
  f h = true ->
  (exists x y, (rev_split_function f (t ++ (h :: nil))) = Some (x,y)) <-> exists x, In x t /\ f x = false.
Proof.
  intros. unfold rev_split_function. rewrite rev_app_distr. unfold rev at 1.
  rewrite app_nil_l. setoid_rewrite in_rev. rewrite <- split_function_exists.
  assert ((h :: nil) ++ rev t = h :: rev t). reflexivity. rewrite H0.
  reflexivity. assumption.
Qed.

(*Function to find min value of a list according to a decidable lt relation *)
Section Min.

Variable A : Type.
Variable lt: A -> A -> Prop.
Variable eqb : A -> A -> Prop.
Variable lt_dec: forall x y, {lt x y} + {~lt x y}.
Variable eq_dec: forall x y, {eqb x y} + {~ eqb x y}.
Variable eqb_equiv: RelationClasses.Equivalence eqb.
Variable lt_trans: forall x y z, lt x y -> lt y z -> lt x z.
Variable lt_neq: forall x y, lt x y -> ~eqb x y.
Variable lt_total: forall x y, lt x y \/ eqb x y \/ lt y x.
Variable lt_antisym: forall x y, lt x y -> ~lt y x.
Variable lt_compat_r: forall x y z, lt x y -> eqb y z -> lt x z.

(*General function for finding minimum according to a decidable lt relation*)
Definition min_list (l: list A) : option A :=
  fold_right (fun x acc => match acc with
                           | Some y => if lt_dec x y then Some x else Some y
                           | None => Some x
                           end) None l.

(*Proof that this actually finds the minimum*)
Lemma min_list_empty: forall (l: list A) ,
  min_list l = None <-> l = nil.
Proof.
  intros. split; intros. unfold min_list in H. destruct l. reflexivity. simpl in H.
  destruct (fold_right
        (fun (x : A) (acc : option A) =>
         match acc with
         | Some y => if lt_dec x y then Some x else Some y
         | None => Some x
         end) None l). destruct (lt_dec a a0); inversion H. inversion H. subst. simpl. reflexivity.
Qed.

Lemma min_list_in: forall (l: list A) x,
  min_list l = Some x -> In x l.
Proof.
  intros. generalize dependent x. induction l; intros. simpl in H. inversion H. simpl in H.
  destruct (min_list l) eqn : M. destruct (lt_dec a a0). inversion H; subst. solve_in.
  inversion H. subst. right. apply IHl. reflexivity. inversion H; subst. solve_in.
Qed.

Lemma min_list_min: forall (l: list A) x,
  min_list l = Some x ->  forall y, ~eqb x y -> In y l -> lt x y.
Proof.
  intros. generalize dependent x. induction l; intros.
  - simpl in H. inversion H.
  - simpl in H. destruct (min_list l) eqn : M.
    + destruct (lt_dec a a0).
      * inversion H; subst.
        simpl in H1. destruct H1. subst. destruct eqb_equiv. unfold RelationClasses.Reflexive in Equivalence_Reflexive.
        specialize (Equivalence_Reflexive y). contradiction.
        destruct (eq_dec y a0). eapply lt_compat_r. apply l0. destruct eqb_equiv as [E1 E2 E3]. eapply E2.
        assumption.
        eapply lt_trans. apply l0. apply IHl. assumption. reflexivity.
        intro. destruct eqb_equiv as [E1 E2 E3]. apply E2 in H2. contradiction.
      * inversion H; subst. simpl in H1. destruct H1.
        subst. specialize (lt_total x y). destruct lt_total. assumption. destruct H1. contradiction.
        contradiction. apply IHl. assumption. reflexivity. assumption.
   + inversion H; subst. rewrite min_list_empty in M. subst. destruct H1. subst.
     destruct eqb_equiv as [E1 E2 E3]. pose proof (E1 y). contradiction. destruct H1.
Qed.

End Min.

Require GHC.List.

(*Rsults about [List.zip]*)

Lemma zip_spec: forall {A B} (l: list A) (l': list B) x y,
  length l = length l' ->
  In (x,y) (List.zip l l') ->
  exists l1 l2 l3 l4, l = l1 ++ x :: l2 /\ l' = l3 ++ y :: l4 /\
  length l1 = length l3 /\ length l2 = length l4.
Proof.
  intros. generalize dependent l'. induction l; intros.
  - simpl in H0. destruct H0.
  - destruct l'. simpl in H. omega. simpl in H. inversion H.
    simpl in H0. destruct H0. inversion H0; subst.
    exists nil. exists l. exists nil. exists l'. split. reflexivity.
    split. reflexivity. split. reflexivity. assumption.
    specialize (IHl _ H2 H0). destruct_all. exists (a :: x0).
    rewrite H1. exists x1. exists (b :: x2). rewrite H3. exists x3. split. reflexivity.
    split. reflexivity. split. simpl. rewrite H4. reflexivity. assumption.
Qed.

Lemma in_zip_map_weak: forall {A B C} (l: list A) (l': list B) x y (f: A -> C) f',
  length l = length l' ->
  In (x,y) (List.zip l l') ->
  map f l = map f' l' ->
  f x = f' y.
Proof.
  intros. generalize dependent l'. induction l; intros.
  - simpl in H0. inversion H0.
  - destruct l'. simpl in H. omega.
    simpl in H. inversion H. simpl in H1. simpl in H0. inversion H1.
    destruct H0. inversion H0; subst. assumption.
    eapply IHl. apply H3. assumption. assumption.
Qed.

Lemma map_length_rev: forall {A B C} (l: list A) (l' : list B) (f: A -> C) f',
  map f l = map f' l' ->
  length l = length l'.
Proof.
  intros. generalize dependent l'. induction l; intros.
  - simpl in H. destruct l'. reflexivity. inversion H.
  - destruct l'. inversion H. simpl in H. simpl. inversion H; subst.
    erewrite IHl. reflexivity. assumption.
Qed.

Lemma in_zip_map: forall {A B C} (l: list A) (l': list B) x y (f: A -> C) f',
  In (x,y) (List.zip l l') ->
  map f l = map f' l' ->
  f x = f' y.
Proof.
  intros. eapply in_zip_map_weak. eapply map_length_rev. apply H0. assumption. assumption.
Qed.

Lemma in_zip_reverse: forall {A} {B} (l: list A) (l' : list B) x,
  length l = length l' ->
  In x l ->
  exists y, In (x,y) (List.zip l l').
Proof.
  intros. generalize dependent l'. induction l; intros.
  - inversion H0.
  - simpl in H. destruct l'. simpl in H. omega.
    simpl in H. inversion H. simpl in H0. destruct H0. subst. exists b. simpl.
    left. reflexivity. specialize (IHl H0 _ H2). destruct_all. exists x0. simpl. right. assumption.
Qed.

Lemma in_zip_reverse_snd: forall {A} {B} (l: list A) (l' : list B) x,
  length l = length l' ->
  In x l' ->
  exists y, In (y, x) (List.zip l l').
Proof.
  intros. generalize dependent l. induction l'; intros.
  - inversion H0.
  - simpl in H. destruct l. simpl in H. omega.
    simpl in H. inversion H. simpl in H0. destruct H0. subst. exists a0. simpl.
    left. reflexivity. specialize (IHl' H0 _ H2). destruct_all. exists x0. simpl. right. assumption.
Qed.

Lemma zip_in: forall {a} {b} (l1 : list a) (l2: list b),
  (forall x y, In (x,y) (List.zip l1 l2) -> In x l1 /\ In y l2).
Proof.
  intros. generalize dependent l2. induction l1; intros.
  - simpl in H. destruct H.
  - simpl in H. destruct l2. destruct H.
    simpl in H.  destruct H. inversion H; subst.
    split; simpl; left; reflexivity. simpl. apply IHl1 in H. destruct H.
    split; right; assumption.
Qed.


Require Export MathClasses.theory.rings.
Require Export MathClasses.interfaces.abstract_algebra.
Require Import Ring.
Require Export MathClasses.interfaces.canonical_names.
Require Export MathClasses.interfaces.orders.
Require Export MathClasses.orders.rings.
Class BooleanRing (A:Type) `{Ring A} :=
  boolean_mult : ∀ x:A, x*x=x.

Section BooleanRingNotations.

Context `{BooleanRing R}.

Require Export SetNotations.

Global Instance BooleanAlgUnion : SetUnion R :=
    λ (a b : R), a + b + a*b .
Global Instance BooleanAlgIntersection : SetIntersection R :=
    mult.

Notation "b \ x " := (b + b * x) (at level 100).

Notation "x ᶜ  " := (1 \ x) (at level 100).

End BooleanRingNotations.

Section BooleanRingProps.
  Context `{BooleanRing R}.

Add Ring  stdlib_ring_theoryldsjfsd : (rings.stdlib_ring_theory R).

Lemma BooleanRingXplusX : ∀ (x : R), x + x = 0.
Proof.
  intros x.
  pose proof (boolean_mult (x + x)) as Hs.
  assert ((x + x) * (x + x) = 2 * (x * x + x * x)) as Hr by ring.
  rewrite Hr in Hs. clear Hr.
  rewrite boolean_mult in Hs.
  apply equal_by_zero_sum in Hs.
  ring_simplify in Hs.
  ring_simplify.
  assumption.
Qed.

Lemma BooleanRingMinusX : ∀ (x : R), - x = x.
Proof.
  intros x.
  apply equal_by_zero_sum.
  rewrite <- negate_plus_distr.
  rewrite BooleanRingXplusX.
  ring.
Qed.

Lemma BooleanRing1Max : ∀ (x : R), x ⊆ 1.
Proof.
  intros x.
  unfold setSubset.
  unfold setIntersection, BooleanAlgIntersection.
  ring.
Qed.

Lemma paperEq1 : ∀ (x y u v : R),
  (x + y) + (u + v) ⊆ (x + u) ∪ (y + v).
Proof.
  intros ? ? ? ?.
  unfold setSubset.
  unfold setUnion, BooleanAlgUnion.
  unfold setIntersection, BooleanAlgIntersection.
  ring_simplify.
  ring_simplify.
  rewrite BooleanRingXplusX.
  ring_simplify.
  repeat (rewrite boolean_mult).
  setoid_rewrite  <- (mult_assoc u v v).
  setoid_rewrite  <- (mult_assoc x v v).
  setoid_rewrite  <- (mult_assoc y u u).
  setoid_rewrite  <- (mult_assoc x y y).
  repeat (rewrite boolean_mult).
  ring_simplify.
  rewrite BooleanRingXplusX.
  ring.
Qed.

Lemma subsetUnionMeasure : ∀ a b: R,
  a ⊆ b →  (a ∪ b) = b.
Proof.
  intros ? ? Hs.
  unfold setSubset in Hs.
  unfold setUnion, BooleanAlgUnion.
  rewrite <- Hs.
  assert (a + b + a= b + (a + a)) as Hr by ring.
  rewrite Hr. clear Hr.
  rewrite BooleanRingXplusX.
  ring.
Qed.

(*
Global Instance subsetPO :  orders.PartialOrder setSubset.
  constructor.
- destruct H. destruct ring_group. destruct abgroup_group.
  destruct group_monoid.
  destruct monoid_semigroup.
  exact sg_setoid.
Abort.
*)

Lemma paperEq2 : ∀ (x y u v : R),
  x*y + u*v ⊆ (x + u) ∪ (y + v).
Proof.
  intros ? ? ? ?.
  unfold setSubset.
  unfold setUnion, BooleanAlgUnion.
  unfold setIntersection, BooleanAlgIntersection.
  ring_simplify.
  ring_simplify.
  rewrite BooleanRingXplusX.
  ring_simplify.
  repeat (rewrite boolean_mult).
  setoid_rewrite  <- (mult_assoc u v v).
  setoid_rewrite  <- (mult_assoc x y y).
  repeat (rewrite boolean_mult).
  ring_simplify.
  rewrite BooleanRingXplusX.
  ring_simplify.
  setoid_rewrite  <- (mult_assoc (x*u)).
  repeat (rewrite boolean_mult).
  ring_simplify.
  rewrite BooleanRingXplusX.
  ring_simplify.
  fold (plus).
  fold (one).
  ring_simplify.
  rewrite plus_0_r.
  rewrite mult_1_r.
  rewrite mult_1_r.
  reflexivity.
Qed.

Require Import tactics.

Lemma normalizeEq2 : forall (a b:R),
 (a = b) <-> a + b= 0.
Proof.
  split; intro Hyp.
- rewrite Hyp. rewrite BooleanRingXplusX. ring.
- fequivHyp Hyp (plus a).
  ring_simplify in Hype. rewrite BooleanRingXplusX in Hype.
  ring_simplify in Hype. auto.
Qed.

Lemma normalizeEq : forall (a b:R),
 (a = b) <-> a + b + 1 = 1.
Proof.
  split; intro Hyp.
- rewrite Hyp. rewrite BooleanRingXplusX. ring.
- rewrite normalizeEq2. fequivHyp Hyp (plus 1). clear Hyp.
  rewrite BooleanRingXplusX in Hype.
  ring_simplify in Hype. rewrite BooleanRingXplusX in Hype.
  ring_simplify in Hype. assumption.
Qed.

(* doesn't seem to hold for all boolean rings rings
Lemma elimEqHyp : forall (h c:R),
  (h = 1 -> c = 1) <-> (h * c + h + 1 = 1).
Proof.
  intros. rewrite <- normalizeEq.
  split; intro Hyp.
- SearchAbout mult Ring. Print RightCancellation.
*)

(* Require Export MathClasses.orders.rings. *)
End BooleanRingProps.


Definition Sn2_cf0 (n_ : int) : rat :=
let n : rat := n_%:~R in
(- rat_of_Z 1 * (n + rat_of_Z 1)^3) / ((n + rat_of_Z 2)^3).

Definition Sn2_cf1 (n_ : int) : rat :=
let n : rat := n_%:~R in
((rat_of_Z 2 * n + rat_of_Z 3) * (n^2 + rat_of_Z 3 * n + rat_of_Z 3)) / ((n + rat_of_Z 2)^3).

Definition Sn2 (z : int -> rat) := forall (n_ : int), precond.Sn2 n_ ->
z (int.shift 2 n_) = Sn2_cf0 n_ * z n_ + Sn2_cf1 n_ * z (int.shift 1 n_).


Add LoadPath "C:/Coq/buffer".
Require Export Lists.

Inductive list (X:Type) : Type :=
  |nil : list X
  |cons : X -> list X -> list X.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Fail Definition mynil := nil.
Compute (@nil nat).

 Notation "x :: l" := (cons x l)
   (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. ( cons y nil) .. ).

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Notation " l1 ++ l2 " := (app l1 l2).

(*
 Q: why doesnt this add coninual nil to the end of list
 A: app above peels off the nil from the left arg list
*)
Fixpoint rev {X : Type} (l : list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Theorem app_nil_r : forall (X:Type) (l : list X),
  l ++ [] = l.
Proof.
  intros X l. induction l as [| n l' Hl'].
  -reflexivity.
  -simpl. rewrite -> Hl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n : list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n. induction l as [| h l' Hl'].
  -reflexivity.
  -simpl. rewrite -> Hl'. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2. induction l1 as [| n l1' Hl'].
  -reflexivity.
  -simpl. rewrite -> Hl'. reflexivity.
Qed.

Theorem rev_app_distr : forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2. induction l1 as [| n l1' Hl1' ].
  -simpl. rewrite -> app_nil_r. reflexivity.
  -simpl. rewrite -> Hl1'. rewrite -> app_assoc.
  reflexivity.
Qed.

Theorem rev_involutive : forall (X : Type) (l : list X),
  rev (rev l) = l.
Proof.
  intros X l. induction l as [| n l' Hl'].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> Hl'.
    reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  |pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.
Notation "X * Y" := (prod X Y) : type_scope.
Notation "( x , y )" := (pair x y).

Definition fst  {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd  {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X * Y) :=
  match lx, ly with
  | _ , nil => nil
  | nil, _ => nil
  | hx :: tx, hy :: ty => (hx, hy) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (l : list (X * Y))
                : (list X) * (list Y) :=
  match l with
  | nil => (nil, nil)
  | h :: t =>
      match (split t) with
      | r => (fst h :: fst r, snd h :: snd r)
      end
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Inductive option (X : Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n 0 then Some a else nth_error l' (pred n)
  end.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

Definition doit3times {X : Type} (f: X -> X) (n : X) : X :=
  f (f (f  n)).

Fixpoint filter {X : Type} (test : X -> bool) (l : list X) : list X :=
  match l with
  | nil => nil
  | a :: l' => if test a then a :: filter test l' else filter test l'
  end.

Compute (fun n => 2 * n) 2.
Compute doit3times (fun n => n * n) 2.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (evenb n) (leb 8 n)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;7;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type} (test: X -> bool) (l : list X)
                     : list X * list X :=
  (filter test l, filter (fun n => negb (test n)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Compute partition evenb [1;2;3;4;5;6].

Fixpoint map {X Y : Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | nil => nil
  | h :: t => (f h) :: (map f t)
  end.

Lemma map_distr : forall (X Y : Type) (f : X -> Y) (l1 l2: list X),
  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2. induction l1 as [| n' l1' Hl1'].
    -reflexivity.
    -simpl. rewrite -> Hl1'. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l. induction l as [| n l' Hl'].
  -reflexivity.
  -simpl. rewrite -> map_distr. rewrite -> Hl'.
   reflexivity.
Qed.

Fixpoint flat_map {X Y : Type} (f : X -> list Y) (l : list X)
                  : (list Y) :=
  match l with
  | nil => nil
  | h :: t => f h ++ flat_map f t
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Fixpoint fold {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y)
              : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Definition constfun {X : Type} (x : X) : nat -> X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Module Excercises.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.
Compute fold_length [1;2;3;4;5].

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof. intros X l. induction l as [| n l' Hl'].
  -reflexivity.
  -simpl. rewrite <- Hl'. reflexivity.
Qed.

Definition fold_map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun (x : X) (ly : list Y) => f x :: ly) l nil.

Compute fold_map (fun n => 2 * n) [1;2;3;4].

Theorem fold_map_correct : forall (X Y : Type) (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof. intros X Y f l. induction l as [| n l' Hl'].
  -reflexivity.
  -simpl. rewrite <- Hl'. reflexivity.
Qed.

Definition prod_curry {X Y Z : Type} (f : X * Y -> Z) (x : X) (y : Y) : Z :=
    f (x, y).
Check prod_curry.

Definition prod_uncurry {X Y Z : Type} (f : X -> Y -> Z) (p : X*Y) : Z :=
    f (fst p) (snd p).
Check prod_uncurry.
Check prod_uncurry (fun (x y : nat) => x + y).

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
   intros X Y Z f x y. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof. intros X Y Z f p. destruct p as (x,y). reflexivity. Qed.

Module Church.
Definition nat := forall (X : Type), (X -> X) -> X -> X.
Definition zero : nat :=
  fun (X : Type) (f : X -> X) (x : X) => x.
Definition one : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.
Definition two : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).
Definition three : nat := @doit3times.

Definition succ (n : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Check succ.

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

Compute (succ (succ (three)) (list Datatypes.nat) (cons 1) nil).

Definition plus (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) =>
      (n X f (m X f x)).
Compute (plus three three) (list Datatypes.nat) (cons 1) nil.

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition fnat_to_nat (n : nat) : Datatypes.nat :=
  n Datatypes.nat S 0.

(* is there a better way? *)
Definition mult (n m : nat) : nat :=
  fun (X : Type) (f: X -> X) (x : X) =>
       ((fold plus (repeat n (fnat_to_nat m))) zero) X f x.

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

(* is there a better way? *)
Definition exp (n m : nat) : nat :=
  fun (X : Type) (f: X -> X) (x : X) =>
       ((fold mult (repeat n (fnat_to_nat m))) one) X f x.

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

Example exp_3 : exp three zero = one.
Proof. reflexivity. Qed.

End Church.
End Excercises.


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

Set Printing Depth 1000.
Definition lfind_eval  n x:=
append (append (rev x) (Cons n Nil)) Nil.

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

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

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

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

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

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

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

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

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

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

Compute lfind_eval  (Succ Zero) (Nil).

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

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

Compute lfind_eval  (Zero) (Cons Zero Nil).

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

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

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

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

Compute lfind_eval  (Zero) (Nil).


(**
プログラミング Coq 停止性が明らかでない関数を定義するには
http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt7.html

練習問題をSSReflectに書き直した。
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Print All.

Definition tail (A : Type) (l : list A) :=
  match l with
    | nil => nil
    | a :: m => m
  end.

Check head 0 : seq nat -> nat.
Check last 0 : seq nat -> nat.
Check map (head 0) : seq (seq nat) -> seq nat.
Check @tail nat : seq nat -> seq nat.
Check map (@tail nat) : seq (seq nat) -> seq (seq nat).
Check @tail (seq nat) : seq (seq nat) -> seq (seq nat).
Check map (@tail (seq nat)) : seq (seq (seq nat)) -> seq (seq (seq nat)).
Check (fun (l : seq (seq nat)) => length (head nil l)).

Require Import Program.Wf.
(* measure の次の括弧が要る。 *)
Program Fixpoint transpose (l : seq (seq nat))
        {measure ((fun l => length (head nil l)) l)} : seq (seq nat) :=
  match l with
    | nil => nil
    | nil :: _ => nil
    | (x :: xs) :: xss =>
      map (head 0) l :: transpose (map (@tail nat) l)
  end.
(* No obligations *)

Check transpose : seq (seq nat) -> seq (seq nat).
Eval compute in transpose [:: [::11; 12; 13];
                            [:: 21; 22; 23; 24];
                            [:: 31; 32]].
(*  [:: [:: 11; 21; 31]; [:: 12; 22; 32]; [:: 13; 23; 0]] *)

Require Import Recdef.
(* measure の次の括弧がいらない。 *)
Function transpose' (l : seq (seq nat))
         : seq (seq nat) :=
  match l with
    | nil => nil
    | nil :: _ => nil
    | (x :: xs) :: xss =>
      map (head 0) l :: transpose (map (@tail nat) l)
  end.
(*
Proof.
  move=> l l' xss x xs //= H1 H2.
  subst.
  elim: xs => [| a l //= H].
  - by [].
  - apply/ltP.
    by rewrite ltnS ltnSn.
Defined.
*)

Check transpose' : seq (seq nat) -> seq (seq nat).
Eval compute in transpose' [:: [::11; 12; 13];
                            [:: 21; 22; 23; 24];
                            [:: 31; 32]].
(*  [:: [:: 11; 21; 31]; [:: 12; 22; 32]; [:: 13; 23; 0]] *)

(* END *)


From Tealeaves.Classes Require Export
  Functor
  Applicative
  Monoid.

Import Monoid.Notations.

(** * Cartesian product of functors *)
(******************************************************************************)
Inductive ProductFunctor (G1 G2 : Type -> Type) (A : Type) :=
| product : G1 A -> G2 A -> ProductFunctor G1 G2 A.

#[global] Arguments product {G1 G2}%function_scope {A}%type_scope _ _.

#[local] Notation "G1 ◻ G2" := (ProductFunctor G1 G2) (at level 50) : tealeaves_scope.

Definition pi1 {F G A} : (F ◻ G) A -> F A :=
  fun '(product x _) => x.

Definition pi2 {F G A} : (F ◻ G) A -> G A :=
  fun '(product _ y) => y.

Theorem product_eta G1 G2 A : forall (x : (G1 ◻ G2) A),
    x = product (pi1 x) (pi2 x).
Proof.
  intros. now destruct x.
Qed.

(** ** Cartesian product of applicative functors *)
(******************************************************************************)
Section product_applicative.

  Context
    (F G : Type -> Type)
    `{Applicative F}
    `{Applicative G}.

  #[export] Instance Fmap_Product : Fmap (F ◻ G) :=
    fun A B (f : A -> B) (p : (F ◻ G) A) =>
      match p with product x y => product (fmap F f x) (fmap G f y) end.

  #[export] Instance Functor_Product : Functor (F ◻ G).
  Proof.
    constructor.
    - introv. ext [?]. cbn. now rewrite 2(fun_fmap_id _).
    - introv. ext [?]. cbn. now rewrite <- 2(fun_fmap_fmap _).
  Qed.

  #[export] Instance Pure_Product : Pure (F ◻ G) :=
    fun A (a : A) => product (pure F a) (pure G a).

  #[export] Instance Mult_Product : Mult (F ◻ G) :=
    fun A B (p : (F ◻ G) A * (F ◻ G) B) =>
      match p with
      | (product fa ga , product fb gb) =>
        product (mult F (fa, fb)) (mult G (ga, gb))
      end.

  #[export] Instance Applicative_Product : Applicative (F ◻ G).
  Proof.
    constructor; try typeclasses eauto.
    - introv. cbn. now rewrite 2(app_pure_natural _).
    - introv. unfold transparent tcs. destruct x, y.
      now rewrite 2(app_mult_natural _).
    - introv. unfold transparent tcs. destruct x, y, z.
      now rewrite 2(app_assoc _).
    - introv. unfold transparent tcs. destruct x.
      now rewrite 2(app_unital_l _).
    - introv. unfold transparent tcs. destruct x.
      now rewrite 2(app_unital_r _).
    - introv. unfold transparent tcs. cbn.
      now rewrite 2(app_mult_pure _).
  Qed.

  Theorem ApplicativeMorphism_pi1 : ApplicativeMorphism (F ◻ G) F (@pi1 _ _).
  Proof.
    intros. constructor; try typeclasses eauto.
    - intros. now destruct x.
    - intros. reflexivity.
    - intros. now destruct x, y.
  Qed.

  Theorem ApplicativeMorphism_pi2 : ApplicativeMorphism (F ◻ G) G (@pi2 _ _).
  Proof.
    intros. constructor; try typeclasses eauto.
    - intros. now destruct x.
    - intros. reflexivity.
    - intros. now destruct x, y.
  Qed.

End product_applicative.

(** * Notations *)
(******************************************************************************)
Module Notations.
  Notation "F ◻ G" := (ProductFunctor F G) (at level 50) : tealeaves_scope.
End Notations.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form phase_sem.

Set Implicit Arguments.

Section Rules.

  Variable (P : list ill_form -> ill_form -> Prop).

  Notation "Γ ⊨ A" := (P Γ A) (at level 70, no associativity).

  Implicit Types (X Y : list ill_form -> Prop).

  Definition cl_ctx X Δ := forall Γ A, (forall ϴ, X ϴ -> ϴ++Γ ⊨ A)
                                     ->                  Δ++Γ ⊨ A.

  Definition comp_ctx (Γ Δ ϴ : list ill_form) := Γ++Δ ~p ϴ.

  Notation cl := cl_ctx.
  Notation comp := comp_ctx.

  Infix "∘" := (Composes comp_ctx) (at level 50, no associativity).

  Notation J := (fun Γ => cl (sg ∅) Γ /\ cl (sg Γ ∘ sg Γ) Γ).
  Notation K := (fun Γ => ∃ Δ, Γ = ‼Δ).

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

  Fact cl_ctx_increase X : X ⊆ cl X.
  Proof. intros ? ? ? ?; auto. Qed.

  Fact cl_ctx_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof.
    intros H1 de Hde ga x HY.
    apply Hde.
    intros; apply HY, H1; auto.
  Qed.

  Fact cl_ctx_idem X : cl (cl X) ⊆ cl X.
  Proof.
    intros de Hde ga x HX.
    apply Hde.
    intros th Hth.
    apply Hth, HX.
  Qed.

  Hint Resolve cl_ctx_increase cl_ctx_mono cl_ctx_idem.

  Hypothesis P_perm : forall Γ Δ A, Γ ~p Δ -> Γ ⊨ A -> Δ ⊨ A.

  Local Fact cl_comm Γ Δ : sg Γ ∘ sg Δ ⊆ cl (sg Δ ∘ sg Γ).
  Proof.
    intros _ [ ga de th ? ? Hth ]; subst Γ Δ.
    intros rho x H; apply H.
    constructor 1 with de ga; auto.
    revert Hth; unfold comp.
    apply perm_trans, Permutation_app_comm.
  Qed.

  Local Fact cl_neutral_1 : forall Γ, cl (sg ∅ ∘ sg Γ) Γ.
  Proof.
    intros ga th x H.
    apply H.
    constructor 1 with nil ga; auto.
    red; simpl; auto.
  Qed.

  Local Fact cl_neutral_2 : forall Γ, sg ∅ ∘ sg Γ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho x G; subst th de.
    cbv in H1.
    generalize (G _ eq_refl).
    apply P_perm, Permutation_app; auto.
  Qed.

  Fact cl_ctx_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho x HXY.
    red in H1; red in H3.
    apply P_perm with (ga++(de++rho)).
    1: rewrite <- app_ass; apply Permutation_app; auto.
    apply H1.
    intros ka Hka.
    rewrite <- app_ass.
    apply HXY.
    constructor 1 with ka de; auto.
    red; auto.
  Qed.

  Local Fact cl_assoc : forall Γ Δ ϴ, sg Γ ∘ (sg Δ ∘ sg ϴ) ⊆ cl ((sg Γ ∘ sg Δ) ∘ sg ϴ).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H3 as [ de' th' to ]; subst ga' de' th'.
    intros u x Hu.
    specialize (Hu ((ga++de)++th)).
    spec all in Hu.
    constructor 1 with (ga++de) th; auto.
    constructor 1 with ga de; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, Permutation_app; auto.
    rewrite app_ass.
    apply Permutation_trans with (2 := H4).
    apply Permutation_app; auto.
  Qed.

  Local Fact sub_monoid_1 : cl K ∅.
  Proof.
    intros ga A H.
    apply H; exists ∅; auto.
  Qed.

  Local Fact sub_monoid_2 : K ∘ K ⊆ K.
  Proof.
    intros _ [ a b c [ga Ha] [de Hb] H ]; subst a b.
    red in H; simpl in H.
    unfold ill_lbang in H.
    rewrite <- map_app in H.
    apply Permutation_map_inv in H.
    destruct H as (th & H1 & H2); subst c.
    exists th; auto.
  Qed.

  Section sub_J_cs.

    Hypothesis P_weak : ∀ Γ Δ A, Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Hypothesis P_cntr : ∀ Γ Δ A, ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A.

    Local Fact sub_J_1 : K ⊆ J.
    Proof.
      intros x (de & Hde); subst x.
      constructor; red.
      + intros ga A H.
        specialize (H _ eq_refl); simpl in H.
        apply P_weak; auto.
      + intros ga A H.
        specialize (H (‼de++‼de)).
        spec all in H.
        { constructor 1 with (‼de) (‼de); auto; red; auto. }
        rewrite app_ass in H.
        apply P_cntr; auto.
    Qed.

    Definition rules_sound := ill_Form_sem_sound _ cl_ctx_increase
                                                   cl_ctx_mono
                                                   cl_ctx_idem
                                                   cl_comm
                                                   cl_ctx_stable_l
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_assoc
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  End sub_J_cs.

  Section sub_J_cn.

    Hypothesis K_inc_J : K ⊆ J.

    Let J_banged Γ : J (‼Γ).
    Proof. apply K_inc_J; exists Γ; auto. Qed.

    Let weak Γ : cl (sg nil) (‼Γ).
    Proof. apply J_banged. Qed.

    Let cntr Γ : cl (sg (‼Γ) ∘ sg (‼Γ)) (‼Γ).
    Proof. apply J_banged. Qed.

    Local Fact sub_J_2 Γ Δ A : Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H; apply weak; intros _ []; apply H.
    Qed.

    Local Fact sub_J_3 Γ Δ A : ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H; apply cntr.
      intros _ [ x y th [] [] H1 ].
      revert H; apply P_perm.
      rewrite <- app_ass; apply Permutation_app; auto.
    Qed.

  End sub_J_cn.

  Fact sub_J_eq : K ⊆ J <-> (∀ Γ Δ A, Δ ⊨ A -> ‼Γ++Δ ⊨ A)
                         /\ (∀ Γ Δ A, ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A).
  Proof.
    split.
    + split.
      * apply sub_J_2; auto.
      * apply sub_J_3; auto.
    + intros; apply sub_J_1; tauto.
  Qed.

  Notation "↓" := (fun A Γ => Γ ⊨ A).

  Fact dc_closed A : cl (↓A) ⊆ ↓A.
  Proof.
    intros ga Hga; red in Hga.
    rewrite (app_nil_end ga); apply Hga.
    intro; rewrite <- app_nil_end; auto.
  Qed.

  Notation sg := (@eq _).
  Infix "⊸" := (Magicwand comp) (at level 51, right associativity).

  Section equivalences.

    (* We show that each rule has an algebraic counterpart *)

    (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

    Fact rule_ax_eq A : ↓A (A::∅)
                    <-> A::∅ ⊨ A.
    Proof. split; auto. Qed.

    Fact rule_limp_l_eq A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅)
                          <-> ∀ Γ Δ C, Γ ⊨ A -> B::Δ ⊨ C -> A -o B::Γ++Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De C H1 H2.
        specialize (H (A -o B::Ga)).
        spec all in H.
        constructor 1 with (A -o B :: nil) Ga; auto; red; simpl; auto.
        change (A -o B :: Ga ++ De) with ((A -o B :: Ga) ++ De).
        apply H; intros _ []; auto.
      + intros H0 th Hth de C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst rho; red in H3; simpl in H3.
        apply P_perm with (A -o B::ga++de).
        { apply Permutation_app with (1 := H3); auto. }
        apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_limp_r_eq A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B)
                          <-> ∀ Γ, A::Γ ⊨ B -> Γ ⊨ A -o B.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1).
        apply Permutation_app_comm with (l := _::nil).
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with th (A :: nil); auto.
        apply Permutation_app_comm.
    Qed.

    Fact rule_times_l_eq A B : cl (sg (A::B::nil)) (A⊗B::nil)
                           <-> ∀ Γ C, A::B::Γ ⊨ C -> A ⊗ B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_times_r_eq A B : ↓A ∘ ↓B ⊆ ↓(A⊗B)
                           <-> ∀ Γ Δ, Γ ⊨ A -> Δ ⊨ B -> Γ++Δ ⊨ A ⊗ B.
    Proof.
      split.
      + intros H Ga De H1 H2.
        apply H.
        constructor 1 with Ga De; auto; red; auto.
      + intros H _ [ Ga Gb Gc HGa HGb HGc ].
        apply P_perm with (1 := HGc).
        apply H; auto.
    Qed.

    Fact rule_with_l1_eq A B : cl (sg (A::∅)) (A&B::∅)
                           <-> ∀ Γ C, A::Γ ⊨ C -> A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_l2_eq A B : cl (sg (B::∅)) (A&B::∅)
                           <-> ∀ Γ C, B::Γ ⊨ C -> A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_r_eq A B : ↓A ∩ ↓B ⊆ ↓(A & B)
                          <-> ∀ Γ, Γ ⊨ A -> Γ ⊨ B -> Γ ⊨ A﹠B.
    Proof.
      split.
      + intros H Ga H1 H2.
        apply H; auto.
      + intros H ? []; apply H; auto.
    Qed.

    Fact rule_plus_l_eq A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅)
                          <-> ∀ Γ C, A::Γ ⊨ C -> B::Γ ⊨ C -> A⊕B::Γ ⊨ C.
    Proof.
      split.
      + intros H Ga C H1 H2.
        apply H; intros _ [ [] | [] ]; auto.
      + intros H0 ? ? H; apply H0; apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_plus_r1_eq A B : ↓A ⊆ ↓(A⊕B)
                           <-> ∀ Γ, Γ ⊨ A -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_plus_r2_eq A B : ↓B ⊆ ↓(A⊕B)
                           <-> ∀ Γ, Γ ⊨ B -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_bang_l_eq A : cl (sg (A::∅)) (!A::∅)
                        <-> ∀ Γ B, A::Γ ⊨ B -> !A::Γ ⊨ B.
    Proof.
      split.
      + intros H Ga B H1; apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_bang_r_eq A : K ∩ ↓A ⊆ ↓(!A)
                        <-> ∀ Γ, ‼ Γ ⊨ A -> ‼ Γ ⊨ !A.
    Proof.
      split.
      + intros H Ga H1.
        apply H; split; auto.
        exists Ga; auto.
      + intros H0 Ga [ (De & H1) H2 ]; subst.
        apply H0; auto.
    Qed.

    Fact rule_unit_l_eq : cl (sg ∅) (𝝐::nil)
                      <-> ∀ Γ A, Γ ⊨ A -> 𝝐 :: Γ ⊨ A.
    Proof.
      split.
      + intros H Ga A H1; apply H; intros _ []; auto.
      + intros H0 ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_unit_r_eq : sg ∅ ⊆ ↓𝝐  <-> ∅ ⊨ 𝝐.
    Proof.
      split.
      + intros H; apply H; auto.
      + intros H x []; apply H.
    Qed.

    Fact rule_bot_l_eq : cl (fun _ => False) (⟘::∅)
                     <-> ∀ Γ A, ⟘ :: Γ ⊨ A.
    Proof.
      split.
      + intros H Ga A; apply H; tauto.
      + intros H0 ? ? _; apply H0.
    Qed.

    Fact rule_top_r_eq : (fun _ => True) ⊆ ↓⟙ <-> ∀ Γ, Γ ⊨ ⟙.
    Proof.
      split.
      + intros H Ga; apply H; auto.
      + intros H ? _; apply H.
    Qed.

  End equivalences.

End Rules.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Initial.
Require Import Category.Construction.Comma.
Require Import Category.Functor.Diagonal.

Generalizable All Variables.

Section UniversalArrow.

Context `{C : Category}.
Context `{D : Category}.

(* A universal arrow is an initial object in the comma category (=(c) ↓ F). *)
Class UniversalArrow (c : C) (F : D ⟶ C) := {
  arrow_initial : @Initial (=(c) ↓ F);

  arrow_obj := snd (`1 (@initial_obj _ arrow_initial));
  arrow : c ~> F arrow_obj := `2 (@initial_obj _ arrow_initial)
}.

Notation "c ⟿ F" := (UniversalArrow c F) (at level 20) : category_theory_scope.

(* The following UMP follows directly from the nature of initial objects in a
   comma category. *)
Corollary ump_universal_arrows `(c ⟿ F) `(h : c ~> F d) :
  ∃! g : arrow_obj ~> d, h ≈ fmap[F] g ∘ arrow.
Proof.
  unfold arrow_obj, arrow; simpl.
  destruct (@zero _ arrow_initial ((ttt, d); h)), x.
  simpl in *.
  rewrite id_right in e.
  exists h1.
  - assumption.
  - intros.
    rewrite <- id_right in e.
    rewrite <- id_right in X.
    exact (snd (@zero_unique _ arrow_initial ((ttt, d); h)
                             ((ttt, h1); e) ((ttt, v); X))).
Qed.

End UniversalArrow.


Require Import SparseMatrix.
Require Import SeqSet.
Require Import Coq.Sets.Powerset.
Require Import Coq.Numbers.BinNums.
Require Import Coq.MSets.MSetRBT.

Require Export Coq.Bool.Bool.
Require Export Coq.Arith.Arith.
Require Export Coq.Arith.EqNat.
Require Export Coq.omega.Omega.
Require Export Coq.Lists.List.
Require Export Coq.ZArith.BinInt.

Set Implicit Arguments.
Require Import mathcomp.ssreflect.ssrnat.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.all_ssreflect.
From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Export ListNotations.

Import ListNotations.

(* Create ideal inequalities for one fixed set n2, for all sets 1,..,setA*)
Definition ideal_ineq_helper (n1 n2 : nat) : smat :=
  let s := rev(iota 1 n1.+1) in
  filter (predC1 []) (map (fun l  => if SeqSet.subset (list_nat l)(list_nat n2) then [::(0,0%Z);(l,(-1)%Z);(n2,1%Z)]
             else []) s).
(**Create ideal inequalities for all combinations of sets in [n] *)
Definition ideal_ineq (n : nat) : smat :=
  let theset := pow2_min1 n in
  let s:= rev(iota 1 theset.+1) in
  flatten (map (ideal_ineq_helper theset) s).

(**Creat intersection inequalities for fixed n2 and all elements in [n1]*)
Definition inter_ineq_helper (nps n1 n2: nat) : smat :=
  let s := rev( iota 1 (pow2_min1 n1)) in
  filter (predC1 []) (map (fun l => if  intersect (list_nat l) (list_nat n2) then []
                     else [(0, (1)%Z);(l + nps,1%Z);(n2 + nps,1%Z)]) s).

(**Create inter inequalities for all combinations of sets in [n]*)
Definition inter_ineq  (n : nat) : smat :=
  let theset := pow2_min1 n in
  let s := rev (iota 1 theset) in
  flatten (map (inter_ineq_helper theset n) s).

(*Create contrainment inequalitites for all elements in [n]*)
Definition containment_ineq (n : nat) : smat :=
  let cardinality := pow2_min1 n in
  let s := rev(iota 1 cardinality) in
  map (fun (l : nat) => [(0,0%Z); (l + cardinality, 1%Z); (l, (-1)%Z)] ) s.

(*Create all star inequalities for one element of [n]*)
Fixpoint star_ineq_helper (n i : nat) : svec :=
  let nps := pow2_min1 n in
  let s := rev (iota 1 nps) in
  (0, (-1)%Z) :: flatten (map (fun l => if i \in list_nat l then [(l,1%Z);(l + nps, (-1)%Z)]
      else  [(l + nps, (-1)%Z)]) s).

(*Create all star inequalitites*)
Definition star_ineq (n : nat)  : smat :=
  let cardinality := pow2_min1 n in
  let s := rev (iota 0 n) in
  map (star_ineq_helper n) s.

(*Create bounding inequalitites *)
Fixpoint bounds (n : nat) : smat :=
  let cPower := pow2_min1 n in
  let s := rev(iota 1 cPower) in
  flatten(  map (fun (l : nat) => [[(0, 1%Z); (l , 1%Z)];  [(0, 1%Z); (l + cPower , 1%Z)];  [(0, 0%Z); (l, (-1)%Z)];  [(0, 0%Z); (l + cPower , (-1)%Z)]]) s).

(*Concatenate all sparse matrices for a specifif n *)
Definition create_mat (n : nat ) : smat :=
  let mat :=           (inter_ineq  n) ++
                       (ideal_ineq  n) ++
                       (star_ineq   n)  ++
                       (containment_ineq n) ++
                       (bounds n) in
  [seq ordervec s | s <- mat].


(* Experiment with Church *)
(*
Definition Nat := forall n : Prop, n -> (n -> n) -> n.
Definition z : Nat := fun (n : Prop) (z : n) (s : n -> n) => z.
Definition s : Nat -> Nat :=
  fun (m : Nat) =>
    fun (n : Prop) (z : n) (s : n -> n) => s (m n z s).
*)

(* Encoding of Types *)
Definition Zero := forall (a : Prop), a.
Notation "'0" := Zero (at level 1).

Lemma Zero_uninhabited : forall t : '0, False.
  intros.
  unfold Zero in t. apply t.
Defined.

Definition One := forall (a : Prop), a -> a.
Notation "'1" := One (at level 1).
Definition unit : '1 := (fun (a : Prop) (x : a) => x).
Implicit Arguments unit [a].
Notation "'()" := unit (at level 1).

Definition And (a : Prop) (b : Prop) := forall (z : Prop), (a -> b -> z) -> z.
Notation "a |*| b" := (And a b) (at level 90, b at next level).

Definition pair : forall (a b : Prop), a -> b -> And a b :=
    fun (a b : Prop) =>
      fun (x : a) (y : b) =>
        fun (z : Prop) (f : a -> b -> z) => f x y.
Implicit Arguments pair [a b].
Notation "[ x , y ]" := (pair x y) (at level 1, y at next level).

Definition fst : forall (a b : Prop), a |*| b -> a :=
  fun (a b : Prop) =>
    fun (p : forall (z : Prop), (a -> b -> z) -> z) =>
      p a (fun (x : a) (y : b) => x).
Implicit Arguments fst [a b].

Definition snd : forall (a b : Prop), a |*| b -> b :=
  fun (a b : Prop) =>
    fun (p : forall (z : Prop), (a -> b -> z) -> z) =>
      p b (fun (x : a) (y : b) => y).
Implicit Arguments snd [a b].

Definition Or (a : Prop) (b : Prop) := forall (z : Prop), (a -> z) -> (b -> z) -> z.
Notation "a |+| b" := (Or a b) (at level 90, b at next level).

Definition inl : forall (a b : Prop), a -> a |+| b :=
    fun (a b : Prop) =>
      fun (x : a) =>
        fun (z : Prop) (left : a -> z) (right : b -> z) => left x.
Implicit Arguments inl [a].
Definition inr : forall (a b : Prop), b -> a |+| b :=
    fun (a b : Prop) =>
      fun (y : b) =>
        fun (z : Prop) (left : a -> z) (right : b -> z) => right y.
Implicit Arguments inr [b].

(* extraneous *)
Definition case : forall (a b c: Prop), a |+| b -> (a -> c) -> (b -> c) -> c :=
  fun (a b c : Prop) =>
    fun (x : a |+| b) (f : a -> c) (g : b -> c) =>
      x c f g.

Lemma or_inl : forall (a b c : Prop) (f : a -> c) (g : b -> c) (x : a),
  case a b c (inl b x) f g = f x.
Proof.
  unfold case.
  unfold inl. auto.
Defined.

Lemma or_inr : forall (a b c : Prop) (f : a -> c) (g : b -> c) (x : a),
  case a b c (inl b x) f g = f x.
Proof.
  unfold case.
  unfold inl. auto.
Defined.

Definition bool := '1 |+| '1.
Definition true := inl '1 '().
Definition false := inr '1 '().

Definition natF := (fun x : Prop => x |+| '1).
Definition mu (F: Prop -> Prop) := all (fun (x : Prop) => (F x -> x) -> x).

Definition foldmu (F : Prop -> Prop) : forall (x : Prop), (F x -> x) -> mu (fun x => F x) -> x.
  intros.
  unfold mu in H0.  unfold all in H0. apply (H0 x H).
Defined.

Print fold.

Definition outmu (F : Prop -> Prop) (FM : forall (a b : Prop), (a -> b) -> (F a -> F b))
  : F (mu (fun z => F z)) -> mu (fun z => F z).
intros F FM s.
unfold mu. unfold all.
intro x. intro k.
apply k. apply (FM (mu  (fun z : Prop => F z)) x).
(* alternative *)
unfold mu. unfold all.
intros H0. apply (H0 x k). auto.
(* apply fold.   apply k. apply s.*)
Defined.

Definition NatF := fun n : Prop => '1 |+| n.
Definition NatFM : forall a b : Prop, (a -> b) -> NatF a -> NatF b.
Proof.
  unfold NatF. intros a b f n. unfold Or in n. apply n.
  intros. apply inl. auto.
  intros. apply inr. apply f. exact H.
Defined.
(* Definition NatFM := fun (n m : Prop) (f : n -> m) => NatF (f n) *)
Definition Nat := mu (fun n : Prop => '1 |+| n).
Definition z : Nat := out NatF NatFM (inl Nat '()).
Definition s : Nat -> Nat := fun n : Nat => out NatF NatFM (inr '1 n).

Definition ex (F : Prop -> Prop) := forall y: Prop, (forall x : Prop, F x -> y) -> y.

Definition pack (F : Prop -> Prop) : forall (x : Prop), F x -> ex F :=
  fun (x : Prop) =>
    fun (e : F x) =>
      fun (y: Prop) =>
        fun (f : forall (z : Prop), F z -> y) => f x e.

Definition unpack (F : Prop -> Prop)
  : ex F -> forall (y : Prop), (forall (x : Prop), F x -> y) -> y :=
    fun (u : ex F) (y : Prop) (f : forall (x : Prop), F x -> y) =>
      u y f.

Definition nu (F : Prop -> Prop) := ex (fun (x : Prop) => (x -> F x) |*| x).
Definition unfold (F : Prop -> Prop)
  : forall (x : Prop), (x -> F x) -> (x -> nu (fun x => F x)) :=
    fun (x : Prop) =>
      fun (f : x -> F x) =>
        fun (e : x) =>
          pack (fun x => (x -> F x) |*| x) x [f,e].

Definition out (F : Prop -> Prop) (FM : forall (a b : Prop), (a -> b) -> (F a -> F b))
  : nu (fun z => F z) -> F (nu (fun z => F z)).
Proof.
  intros F FM.
  refine
    (fun (u : nu (fun z => F z)) =>
      unpack _ u (F (nu (fun z => F z)))
      (fun (x : Prop) (w : (x -> F x) |*| x) =>
        FM _ _ (unfold _ x (fst w)) ((fst w) (snd w)))).
Defined.

Definition inn (F : Prop -> Prop) (FM : forall (a b : Prop), (a -> b) -> (F a -> F b))
  : F (nu (fun z => F z)) -> nu (fun z => F z).
Proof.
  intros F FM.
  refine (unfold _ (F (nu (fun z => F z))) (FM _ _ (out F FM))).
Defined.

Definition compose (a b c : Prop) (f : b -> c) (g : a -> b)
  := (fun (x : a) => f (g x)).
Implicit Arguments compose [a b c].
Notation "f ; g" := (compose f g) (at level 40).

Definition id := fun (a : Prop) (x : a) => x.

(* Conaturals *)

Definition FN := (fun N => '1 |+| N).
Definition Conat := nu FN.

Definition FMN : forall (a b : Prop), (a -> b) -> (FN a -> FN b).
Proof.
  unfold FN.
  intros a b f c.
  apply (c ('1 |+| b) (fun x : '1 => inl b '()) (fun x : a => inr '1 (f x))).
Defined.

Definition out_FN := out FN FMN.
Definition inn_FN := inn FN FMN.

Definition cz : Conat.
Proof.
  unfold Conat. unfold FN.
  cut '1. apply unfold. intros. apply inl. auto.
  exact '().
Defined.

Definition cs : Conat -> Conat.
Proof.
  unfold Conat.
  intros.
  apply (fun (c : nu FN) => inr '1 c) in H.
  change (FN (nu FN)) in H.
  apply inn_FN.
  unfold FN at 2.
  change (FN (nu FN)). auto.
Defined.

Definition inf : Conat := unfold FN Conat (fun x : Conat => inr '1 x) cz.

Definition clt (n : nat) (c : Conat) : bool.
Proof.
  refine
    (fix clt (n : nat) (c : Conat) : bool :=
      match n with
        | 0 => true
        | S n' => (out_FN c) bool (fun x : '1 => false) (fun y => clt n' y)
      end).
Defined.

Lemma inf_infinity : forall (n : nat), clt n inf = true.
Proof.
  induction n.
  simpl. auto.
  simpl.
  unfold out_FN.
  unfold out. unfold unpack.
  unfold inf at 1.
  unfold unfold at 1. unfold pack at 1.
  unfold FMN. unfold fst at 1.
  unfold pair at 1. unfold inr at 1.
  unfold inr at 1.
  unfold fst at 1. unfold pair at 1.
  unfold snd at 1. unfold pair at 1. unfold inf in IHn.
  auto.
Defined.

(* Cleaner proof using normalisation *)
Lemma inf_infinity2 : forall (n : nat), clt n inf = true.
Proof.
  induction n ; compute in * ; auto.
Defined.

Lemma cthree_lt : clt 3 (cs (cs cz)) = false.
Proof.
  compute in * ; auto.
Defined.

(* Nat Streams *)

Definition FL := (fun N => '1 |+| (Nat |*| N)).
Definition CoList := nu FL.

Definition FML : forall (a b : Prop), (a -> b) -> (FL a -> FL b).
Proof.
  unfold FL.
  intros a b f c.
  refine (c ('1 |+| (Nat |*| b)) (fun x : '1 => inl (Nat |*| b) '()) (fun x : (Nat |*| a) => inr _ _)).
  refine [_,_].
  exact (fst x).
  exact (f (snd x)).
Defined.

Definition List (A : Prop) := forall (X : Prop), X -> (A -> X -> X) -> X.
Definition nil := fun (A : Prop) (X : Prop) (n : X) (c : A -> X -> X) => n.
Definition cons := fun (A : Prop) (a : A) (l : List A) =>
  fun (X : Prop) (n : X) (c : A -> X -> X) => c a (l X n c).
Implicit Arguments cons [A].
Eval compute in cons z (cons z (nil Nat)).
Definition mapl : forall (a b : Prop), (a -> b) ->  List a -> List b.
Proof.
  refine
    (fun (a b : Prop) =>
      (fun (f : a -> b) (foldr : List a) =>
        foldr (List b) (nil b) (fun (x : a) (l : List b) => cons (f x) l))).
Defined.

Definition foldr : forall (a b : Prop), (a -> b -> b) -> b -> List a -> b.
Proof.
  refine
    (fun (a b : Prop) =>
      fun (f : a -> b -> b) (n : b) (l : List a) =>
        l b n (fun (x : a) (y : b) => f x y)).
Defined.

(* Non strictly positive types *)       (* Var *)     (* Fun *)       (* mu *)
Definition LamMu := forall (X : Prop),
  (Nat -> X) ->
  (Nat -> List X -> X) ->
  ((forall (Y : Prop), ((X -> Y) -> Y)) -> X) -> X.

Definition var : Nat -> LamMu :=
  fun (n : Nat) =>
    fun (X : Prop)
      (v : Nat -> X)
      (f : Nat -> List X -> X)
      (m : (forall (Y : Prop), ((X -> Y) -> Y)) -> X) =>
      v n.
Definition func : Nat -> List LamMu -> LamMu :=
  fun (n : Nat) =>
    fun (t : List LamMu) =>
      fun (X : Prop)
        (v : Nat -> X)
        (f : Nat -> List X -> X)
        (m : (forall (Y : Prop), ((X -> Y) -> Y)) -> X) =>
        f n (t (List X) (nil X) (fun (x : LamMu) (y : List X) => cons (x X v f m) y)).
Definition mu : (forall (Y : Prop), (LamMu -> Y) -> Y) -> LamMu.
Proof.
  unfold LamMu.
  refine
    (fun (zi : (forall (Y : Prop), (LamMu -> Y) -> Y)) =>
      fun (X : Prop)
        (v : Nat -> X)
        (f : Nat -> List X -> X)
        (m : (forall (Y : Prop), ((X -> Y) -> Y)) -> X) =>
        m (fun (Y : Prop) (g : X -> Y) =>
          g (zi X (fun e : LamMu => e X v f m)))).
Defined.

Inductive LamMu2 : Type :=
| Var : Nat -> LamMu2
| Fun : Nat -> LamMu2 -> LamMu2
| Mu : ((forall Y, ((LamMu2 -> Y) -> Y)) -> LamMu2) -> LamMu2.


  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*							         *)
  (*   File : m_list.v					         *)
  (*   Authors : S. Coupet-Grimal, W. Delobel 		         *)
  (*   Content : instanciation of pred_list to list of elements  *)
  (*             of nat*Alpha, where first elements of the       *)
  (*   	         couples are less than a certain bound	         *)
  (***************************************************************)

Unset Standard Proposition Elimination Names.
Local Unset Injection On Proofs.

Section m_list.

  Require Export nat_bounded_list.
  (* bound *)
  Variable n : nat.
  (* base set *)
  Variable A : Set.
  Hypothesis eq_A_dec : forall (a a':A), {a=a'} + {a<>a'}.
  Variable r : relation A.

  Lemma eq_prod_dec : forall (a b : nat*A), {a=b}+{a<>b}.
  Proof.
    intros a b; elim a; elim b; clear a b; intros b1 b2 a1 a2.
    elim (eq_nat_dec a1 b1); intro comp.
    subst a1.
    elim (eq_A_dec a2 b2); intro comp'.
    subst a2.
    left; trivial.
    right.
    injection.
    assumption.
    right; injection.
    intro h; assumption.
  Qed.

  Definition Q := fun (e:nat*A)=>lt (fst e) n.
  Definition m_list := pred_list (nat*A) Q.
  Definition m_nil := pred_nil Q.
  Definition m_cons := pred_cons Q.

  Definition m_list_add_element := pred_list_add_element eq_prod_dec (P:=Q).
  Definition m_list_belong := pred_list_belong (P:=Q).
  Definition m_list_belong_dec := pred_list_belong_dec eq_prod_dec (P:=Q).
  Definition m_list_get_witness := pred_list_get_witness (P:=Q).
  Definition m_list_remove := pred_list_remove eq_prod_dec (P:=Q).
  Definition m_length := pred_length (P:=Q).
  Definition lt_m_length := lt_pred_length (P:=Q).
  Definition m_list_equiv := pred_list_equiv (P:=Q) (Q:=Q).

  Notation "e 'INm' l" := (m_list_belong l e) (at level 50).

  (* returns true if there exists a element a of A such that (p,a)
     belongs to the m_list : *)

  Fixpoint m_list_belong_fst (l:m_list) (p:nat) {struct l} : Prop :=
    match l with
      | pred_nil=> False
      | pred_cons (hn,ha) C t => hn = p \/ m_list_belong_fst t p
    end.

  Notation "e 'INfst' l" := (m_list_belong_fst l e) (at level 50).

  (* returns true if there exists a natural p such that (p,a)
     belongs to the m_list : *)
  Fixpoint m_list_belong_snd (l:m_list) (a:A) {struct l} : Prop :=
    match l with
      | pred_nil=> False
      | pred_cons (hn,ha) C t => ha = a \/ m_list_belong_snd t a
    end.

  Notation "e 'INsnd' l" := (m_list_belong_snd l e) (at level 50).

  Lemma m_list_belong_fst_dec : forall (l : m_list) (p : nat),
    {p INfst l} + {~ (p INfst l)}.
  Proof.
    intro l; elim l; simpl.
    intro; right; unfold not; trivial.
    intro a; elim a; clear a; intros a b C d Hrec p.
    elim (Hrec p); intro case.
    left; right; assumption.
    compare a p; intro comp.
    left; left; assumption.
    right; intro H.
    unfold not in *; elim H; assumption.
  Qed.

  (* auxiliary facts needed to specify combination *)
  Lemma combaux1 : forall (q : nat) (C : P n q) (tn : nb_list n),
    nb_length (nb_cons q C tn) = length (A:=A) nil -> False.
  Proof.
    intros; simpl in H; inversion H.
  Qed.

  Lemma combaux2 : forall (a : A) (ta : list A),
    nb_length (nb_nil (n:=n)) = length (a::ta) -> False.
  Proof.
    intros; simpl in H; inversion H.
  Qed.

  Lemma tail_length : forall (q : nat) (C : P n q) (tn : nb_list n) (a : A) (ta : list A),
    nb_length (nb_cons q C tn) = length (a :: ta)-> nb_length tn = length ta.
  Proof.
    simpl; intros; auto with arith.
  Qed.

  (* combines a nb_list and a list of elements of A into a m_list,
     given a proof the two argument lists are of same length  *)
  Fixpoint combine (ln:nb_list n) (la:list A) {struct ln} : (nb_length ln = length la)->m_list :=
    match ln, la return (nb_length ln = length la)->m_list with
      | pred_nil,nil =>
        fun (H:(nb_length (pred_nil (P n))) = length (A:=A) nil) => m_nil
      | pred_nil, a :: ta =>
        fun (H:nb_length (pred_nil (P n)) = length (a::ta)) => False_rec m_list (combaux2 a ta H)
      | pred_cons q C tn, nil =>
        fun (H:(nb_length (pred_cons (P n) q C tn) = length (A:=A) nil)) => False_rec m_list (combaux1 q C tn H)
      | pred_cons q C tn, a::ta =>
        fun (H:(nb_length (pred_cons (P n) q C tn) = length (a::ta))) => m_cons (q,a) C (combine tn ta (tail_length q C tn a ta H))
    end.

  (* combination results : *)
  Lemma in_fst_combine_in_fst : forall (l : nb_list n) (la : list A) (H : nb_length l = length la) (q : nat),
    q INfst (combine l la H) -> q INnb l.
  Proof.
    intro l; elim l; simpl.
    intro la; destruct la; simpl.
    trivial.
    intro H.
    inversion H.
    intros a p d Hrec.
    intro la; destruct la; simpl.
    intro H.
    inversion H.
    intros H q H'.
    elim H'; intro case; [left | right].
    symmetry; assumption.
    apply (Hrec la (tail_length  a p d a0 la H) q).
    assumption.
  Qed.

  Lemma in_fst_in_fst_combine : forall (l : nb_list n) (la : list A) (H : nb_length l = length la) (q : nat),
    q INnb l -> q INfst (combine l la H).
  Proof.
    intro l; elim l; simpl.
    intro la; destruct la; simpl.
    trivial.
    intro H.
    inversion H.
    intros a p d Hrec.
    intro la; destruct la; simpl.
    intro H.
    inversion H.
    intros H q H'.
    elim H'; intro case; [left | right].
    symmetry; assumption.
    apply (Hrec la (tail_length  a p d a0 la H) q).
    assumption.
  Qed.

  Lemma in_snd_combine_in_snd : forall (l : nb_list n) (la : list A) (H : nb_length l = length la) (t : A),
    t INsnd (combine l la H) -> In t la.
  Proof.
    intro l; elim l; simpl.
    intro la; destruct la; simpl.
    trivial.
    intro H.
    inversion H.
    intros a p d Hrec.
    intro la; destruct la; simpl.
    intro H.
    inversion H.
    intros H t H'.
    elim H'; intro case; [left | right].
    assumption.
    apply (Hrec la (tail_length  a p d a0 la H) t).
    assumption.
  Qed.

  Lemma in_snd_in_snd_combine : forall (l : nb_list n) (la : list A) (H : nb_length l = length la) (t : A),
    In t la -> t INsnd (combine l la H).
  Proof.
    intro l; elim l; simpl.
    intro la; destruct la; simpl.
    trivial.
    intro H.
    inversion H.
    intros a p d Hrec.
    intro la; destruct la; simpl.
    intro H.
    inversion H.
    intros H t H'.
    elim H'; intro case; [left | right].
    assumption.
    apply (Hrec la (tail_length  a p d a0 la H) t).
    assumption.
  Qed.

  (* belong / belong_fst / belong_snd results : *)
  Lemma belong_and_fst :  forall (l : m_list) (q:nat) (t:A),
    (q, t) INm l -> q INfst l.
  Proof.
    intro l; elim l.
    simpl; trivial.
    intro a; elim a; clear a.
    intros a b p d Hrec q t.
    simpl.
    intro h; elim h; [left | right].
    replace a with (fst (a,b)).
    rewrite <- H.
    simpl; trivial.
    simpl; trivial.
    apply Hrec with t.
    assumption.
  Qed.

  Lemma belong_and_snd : forall (l : m_list) (q:nat) (t:A),
    (q, t) INm l -> t INsnd l.
  Proof.
    intro l; elim l.
    simpl; trivial.
    intro a; elim a; clear a.
    intros a b p d Hrec q t.
    simpl.
    intro h; elim h; [left | right].
    replace b with (snd (a,b)).
    rewrite <- H.
    simpl; trivial.
    simpl; trivial.
    apply Hrec with q.
    assumption.
  Qed.

  Lemma m_list_get_first_element : forall (l:m_list) (t:A),
    t INsnd l -> {q : nat | (q,t) INm l}.
  Proof.
    intro l; elim l; simpl.
    intros t H; inversion H.
    intro a; elim a; clear a; intros a b p d Hrec.
    intros t h.
    elim (eq_A_dec b t); intro comp.
    exists a; subst b; left; trivial.
    elim (Hrec t).
    intros x H.
    exists x; right; assumption.
    inversion h; [contradiction | assumption].
  Qed.

  Lemma m_list_get_second_element : forall (l:m_list) (q:nat),
    q INfst l -> {t : A | (q,t) INm l}.
  Proof.
    intro l; elim l; simpl.
    intros q H; inversion H.
    intro a; elim a; clear a; intros a b p d Hrec.
    intros q h.
    elim (eq_nat_dec a q); intro case.
    subst a; exists b; left; trivial.
    elim (Hrec q).
    intros x H.
    exists x; right; assumption.
    inversion h; [contradiction | assumption].
  Qed.

  Lemma remove_compat : forall (ln : nb_list n) (la:list A) (H : nb_length ln = length la) (p q : nat) (dummy:A),
    (forall (q : nat), q INnb ln -> ~ (q INnb (nb_list_remove ln q))) ->
    (forall (t:A), p INfst (m_list_remove (combine ln la H) (q,t))) -> p INnb (nb_list_remove ln q).
  Proof.
    induction ln; intros la H; destruct la; simpl.
    intros p q dummy H0 H1; apply (H1 dummy).
    inversion H.
    inversion H.
    intros p' q dummy set H'.
    elim (eq_nat_dec q a); intro comp.
    apply (in_fst_combine_in_fst ln la (tail_length a p ln a0 la H)).
    cut {t : A | m_list_belong (combine ln la (tail_length a p ln a0 la H)) (p', t)}.
    intro Hex; elim Hex; clear Hex.
    intros t Ht.
    generalize (H' a0).
    subst a.
    elim (eq_prod_dec (q, a0) (q, a0)); intro case.
    trivial.
    elim case.
    trivial.
    apply m_list_get_second_element.
    generalize (H' a0).
    subst a.
    elim (eq_prod_dec (q, a0) (q, a0)); intro case.
    trivial.
    elim case.
    trivial.
    simpl.
    compare p' a; intro comp'.
    left; assumption.
    right.
    apply (IHln la (tail_length a p ln a0 la H) p' q dummy).
    intro q'.
    generalize (set q').
    elim (eq_nat_dec q' a); intro case.
    subst a.
    intros H0 H1 h.
    apply H0.
    left; trivial.
    assumption.
    simpl.
    intros H0 H1 h.
    apply H0.
    right; assumption.
    right; assumption.
    intro t.
    generalize (H' t).
    elim (eq_prod_dec (q, t) (a, a0)); intro case.
    elim comp.
    replace q with (fst (q, t)); [ rewrite case; auto | auto ].
    simpl.
    intro H0; elim H0.
    intro h; symmetry  in h; contradiction.
    trivial.
  Qed.

  (* pointwise order on m_list, ignoring the nat part of elements : *)
  Inductive m_list_pointwise : m_list -> m_list -> Prop :=
    | m_list_pointwise_nil  : m_list_pointwise m_nil m_nil
    | m_list_pointwise_cons : forall (p:nat) (a a' : A) (C : Q (p,a)) (C' : Q (p,a')) (l l' : m_list),
      r a a' -> m_list_pointwise l l' -> m_list_pointwise (m_cons (p,a) C l) (m_cons (p,a') C' l').

  Inductive list_pointwise : list A -> list A -> Prop :=
    | list_pointwise_nil : list_pointwise nil nil
    | list_pointwise_cons : forall (a a' : A) (l l' : list A),
      r a a' -> list_pointwise l l' -> list_pointwise (a::l) (a'::l').

  Lemma list_pointwise_to_m_list_pointwise : forall (ln : nb_list n) (la1 la2 : list A)
    (H1 : nb_length ln = length la1) (H2 : nb_length ln = length la2),
    list_pointwise la1 la2 -> m_list_pointwise (combine ln la1 H1) (combine ln la2 H2).
  Proof.
    induction ln.
    intros la1 la2 H1 H2.
    destruct la1.
    destruct la2.
    simpl; constructor.
    inversion H2.
    inversion H1.
    intros la1 la2 H1 H2.
    destruct la1.
    inversion H1.
    destruct la2.
    inversion H2.
    simpl.
    intro depr.
    constructor.
    inversion depr.
    subst; assumption.
    apply IHln.
    inversion depr.
    assumption.
  Qed.

  Lemma alt_monostep_aux1 : forall (l l' : m_list),
    m_list_pointwise l l' ->
    (forall (i : nat) (a a' : A), (i,a) INm l -> (i,a') INm l -> a = a') ->
    (forall (i : nat) (a a' : A), (i,a) INm l' -> (i,a') INm l' -> a = a') ->
    forall (i : nat) (a a' : A), (i,a) INm l -> (i,a') INm l' -> r a a'.
  Proof.
    intro l; induction l as [ | h C t IHl]; simpl; intros l' r_l_l' fcn_l fcn_l' i a a' ia_in_l ia_in_l'.
    inversion ia_in_l.
    destruct l' as [ | h' C' t'].
    inversion ia_in_l'.
    destruct h as [ih ah]; destruct h' as [ih' ah'].
    elim ia_in_l; clear ia_in_l; intro ia_in_l.
    inversion ia_in_l; subst i a.
    elim ia_in_l'; clear ia_in_l'; intro ia_in_l'.
    inversion ia_in_l'; subst a'.
    inversion r_l_l'; subst; trivial.
    assert (H : ah' = a').
    apply (fcn_l' ih ah' a'); [left | right]; trivial.
    inversion r_l_l'; subst; trivial.
    inversion r_l_l'; subst; trivial.
    elim ia_in_l'; clear ia_in_l'; intro ia_in_l'.
    inversion ia_in_l'; subst i a'.
    assert (H : ah = a).
    apply (fcn_l ih' ah a); [left | right]; trivial.
    inversion r_l_l'; subst; trivial.
    inversion r_l_l'; subst; trivial.
    apply (IHl t') with i; try right; trivial.
    inversion r_l_l'; subst; trivial.
    intros; apply fcn_l with i0; right; trivial.
    intros; apply fcn_l' with i0; right; trivial.
  Qed.

  Lemma alt_monostep_aux2 : forall (st : A -> m_list),
    (forall (s t : A), r s t -> m_list_pointwise (st s) (st t))  ->
    (forall (s : A) (q : nat) (t u : A),  m_list_belong (st s) (q,t) ->
      m_list_belong (st s) (q,u) -> t = u) ->
    (forall (q : nat) (s t c d : A), r s t -> m_list_belong (st s) (q,c) ->
      m_list_belong (st t) (q,d) -> r c d).
  Proof.
    intros st mono fcn q s t c d rst Hb1 Hb2.
    intros; apply (alt_monostep_aux1 (st s) (st t)) with q; try assumption.
    apply (mono s t); try assumption.
    intros q0 t0 u; apply (fcn s q0 t0 u); try assumption.
    intros q0 t0 u; apply (fcn t q0 t0 u); try assumption.
  Qed.

End m_list.

Implicit Arguments m_nil [A n].
Implicit Arguments m_cons [A n].
Implicit Arguments m_list_add_element [A n].
Implicit Arguments m_list_belong [A n].
Implicit Arguments m_list_belong_fst [A n].
Implicit Arguments m_list_belong_snd [A n].
Implicit Arguments m_list_belong_dec [A n].
Implicit Arguments m_list_get_witness [A n].
Implicit Arguments m_length [A n].
Implicit Arguments lt_m_length [A n].
Implicit Arguments combine [A n].
Implicit Arguments m_list_remove [A n].
Implicit Arguments m_list_equiv [A n].

  Notation "e 'INm' l" := (m_list_belong l e) (at level 50).
  Notation "e 'INfst' l" := (m_list_belong_fst l e) (at level 50).
  Notation "e 'INsnd' l" := (m_list_belong_snd l e) (at level 50).
  Notation "l '=m=' m" := (m_list_equiv l m) (at level 50).

  (* equivalence results : *)

Lemma m_list_equiv_combine :  forall (A : Set) (n m : nat)
  (ln : nb_list n) (lm : nb_list m) (la la':list A)
  (H : nb_length ln = length la) (H' : nb_length lm = length la'),
  ln =p= lm -> la = la'-> (combine ln la H) =p= (combine (n:=m) lm la' H').
Proof.
  induction ln; intro lm; destruct lm; intro la; destruct la; intro la'; destruct la'; simpl.
  unfold pred_list_equiv; trivial.
  intros H H'; inversion H'.
  intro H; inversion H.
  intro H; inversion H.
  intros H H'; inversion H'.
  intros H H' H''; inversion H''.
  intro H; inversion H.
  intro H; inversion H.
  intro H; inversion H.
  intro H; inversion H.
  intros H H' H''; inversion H''.
  intros H H'; inversion H'.
  intro H; inversion H.
  intro H; inversion H.
  intros H H'; inversion H'.
  intros H H' H1 H2.
  inversion H1; inversion H2.
  subst.
  apply (pred_list_split_equiv (a0,a2) (a0,a2)
    (combine ln la' (tail_length n A a0 p ln a2 la' H))
    (combine lm la' (tail_length m A a0 p0 lm a2 la' H'))
    p p0).
  split.
  trivial.
  apply IHln; trivial.
Qed.

Lemma m_list_belong_convert : forall (n : nat) (A : Set)
  (la : list A) (m :nat) (lm : nb_list m) (q : nat) (t : A)
  (Hlm : nb_length lm = length la) (Hconv : (forall p : nat, p INp lm -> p < n))
  (Hlconv : nb_length (nb_list_convert m n lm Hconv) = length la),
  (q,t) INm (combine lm la Hlm) -> (q,t) INm (combine (nb_list_convert m n lm Hconv) la Hlconv).
Proof.
  intros n A la m lm q t Hlm Hconv Hlconv.
  unfold m_list_belong.
  apply pred_list_equiv_belong.
  apply m_list_equiv_combine.
  unfold nb_list_convert.
  apply pred_list_convert_equiv.
  trivial.
Qed.

Lemma m_list_convert_belong : forall (n : nat) (A : Set)
  (la : list A) (m :nat) (lm : nb_list m) (q : nat) (t : A)
  (Hlm : nb_length lm = length la) (Hconv : (forall p : nat, p INp lm -> p < n))
  (Hlconv : nb_length (nb_list_convert m n lm Hconv) = length la),
  (q,t) INm (combine (nb_list_convert m n lm Hconv) la Hlconv) -> (q,t) INm (combine lm la Hlm).
Proof.
  intros n A la m lm q t Hlm Hconv Hlconv.
  unfold m_list_belong.
  apply pred_list_equiv_belong.
  apply m_list_equiv_combine.
  unfold nb_list_convert.
  apply pred_list_equiv_sym.
  apply pred_list_convert_equiv.
  trivial.
Qed.

  (* m_list inclusion : l1 is included in l2 if there exists l and l' such that :
     - l2 = l++l'
     - l' is equivalent to l1 *)
Inductive m_list_inc (Sigma : Set) (n n' : nat) : m_list n Sigma -> m_list n' Sigma -> Prop :=
  | m_equiv_inc : forall (l : m_list n Sigma) (l' : m_list n' Sigma), l =p= l' -> m_list_inc Sigma n n' l l'
  | m_cons_inc : forall (pt : nat * Sigma) (Cpt : Q n' Sigma pt) (l : m_list n Sigma) (l' : m_list n' Sigma),
    m_list_inc Sigma n n' l l' -> m_list_inc Sigma n n' l (m_cons pt Cpt l').

Notation "l 'INC' L" := (m_list_inc _ _ _ l L) (at level 50).

Lemma m_list_inc_equiv : forall (Sigma : Set) (n n' n'' : nat) (l : m_list n Sigma)
  (l' : m_list n' Sigma) (l'' : m_list n'' Sigma),
  l' =p= l'' -> l INC l' -> l INC l''.
Proof.
  intros Sigma n n' n'' l l' l''; generalize n n' l l'; clear n n' l l'.
  (induction l''); intros n n' l l' Heq Hinc.
  replace l with (pred_nil (Q n Sigma)).
  constructor; unfold pred_list_equiv; trivial.
  inversion Heq.
  (induction l'); simpl; trivial.
  inversion Hinc.
  subst.
  inversion H.
  induction l; simpl; trivial.
  inversion H2.
  inversion H0.
  inversion Heq.
  destruct l'; inversion H0.
  subst.
  inversion Hinc.
  subst.
  destruct l; simpl; inversion H; subst.
  apply m_equiv_inc.
  unfold m_list_equiv; unfold pred_list_equiv; simpl.
  rewrite H4.
  rewrite H2; trivial.
  subst.
  apply (m_cons_inc Sigma n n'' a p l l'').
  apply (IHl'' n n' l l').
  apply H2.
  assumption.
Qed.

Lemma m_list_inc_trans : forall (Sigma : Set) (n : nat) (l'' l l' : m_list n Sigma),
  l INC l' -> l' INC l'' ->  l INC l''.
Proof.
  induction l''; intros l l'; simpl.
  intros h1 h2.
  inversion h2; subst.
  cut (l' = (pred_nil (Q n Sigma))); [intro h; rewrite h in h1; apply h1 | induction l'; simpl].
  trivial.
  inversion H.
  intros h1 h2.
  inversion h2.
  subst.
  apply (m_list_inc_equiv Sigma n n n l l' (pred_cons (Q n Sigma) a p l'')); trivial.
  subst.
  apply (m_cons_inc Sigma n n a p l l'').
  apply (IHl'' l l'); trivial.
Qed.

Lemma m_list_inc_refl : forall (Sigma : Set) (n : nat) (l : m_list n Sigma), l INC l.
Proof.
  induction l.
  constructor.
  apply pred_list_equiv_refl.
  constructor.
  apply pred_list_equiv_refl.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Theory.Monad.
Require Import Category.Structure.Monoid.
Require Import Category.Structure.Monoidal.Compose.
Require Import Category.Instance.Fun.

Generalizable All Variables.

Section MonoidMonad.

Context {C : Category}.
Context {M : C ⟶ C}.

(* Monads are monoid (objects) in the (monoidal) category of endofunctors
   which is monoidal with respect to functor composition. *)

Definition Endofunctors `(C : Category) := ([C, C]).

Theorem Monoid_Monad :
  @MonoidObject (Endofunctors C) Compose_Monoidal M ↔ Monad M.
Proof.
  split; intros m.
  - refine {| join := transform[mappend[m]]
            ; ret  := transform[mempty[m]] |}; intros.
    + symmetry.
      apply (@naturality _ _ _ _ (@mempty _ _ _ m)).
    + pose proof (@mappend_assoc _ _ _ m x) as X; simpl in X.
      autorewrite with categories in X.
      symmetry; assumption.
    + pose proof (@mempty_right _ _ _ m x) as X; simpl in X.
      autorewrite with categories in X.
      assumption.
    + pose proof (@mempty_left _ _ _ m x) as X; simpl in X.
      autorewrite with categories in X.
      assumption.
    + symmetry.
      apply (@naturality _ _ _ _ (@mappend _ _ _ m)).
  - unshelve (refine {| mempty  := _
                      ; mappend := _ |}).
    + transform; intros.
      * exact ret.
      * simpl.
        symmetry.
        apply fmap_ret.
      * simpl.
        apply fmap_ret.
    + transform; intros.
      * exact join.
      * simpl.
        symmetry.
        apply join_fmap_fmap.
      * simpl.
        apply join_fmap_fmap.
    + simpl; intros; cat.
      apply join_ret.
    + simpl; intros; cat.
      apply join_fmap_ret.
    + simpl; intros; cat.
      symmetry.
      apply join_fmap_join.
Defined.

End MonoidMonad.


From Coq Require Import ssreflect ssrbool Lists.Streams.

(* Implementation *)

Definition composite (n : nat) : Prop := exists a b, n = S (S a) * S (S b).

CoFixpoint counter (n i : nat) : Stream bool :=
    match i with
    | 0 => Cons true (counter n n)
    | S i => Cons false (counter n i)
    end.

CoFixpoint sieve (n : nat) (stream : Stream bool) : Stream bool :=
    Cons (hd stream) (sieve (S n) (zipWith orb (tl stream) (counter n n))).

Definition composites := sieve 1 (const false).

Definition compositeb (n : nat) : bool :=
    match n with
    | 0 => false
    | 1 => false
    | S (S n) => Str_nth n composites
    end.

(* Correctness Proof *)

Lemma Str_nth_S {A} n (stream : Stream A) : Str_nth (S n) stream = Str_nth n (tl stream).
Proof.
    rewrite /Str_nth /Str_nth_tl.
    reflexivity.
Qed.

Lemma Str_nth_const {A} n (a : A) : Str_nth n (const a) = a.
Proof.
    by elim: n.
Qed.

Lemma counter_spec n i k : reflect (exists a, k = i + a * S n) (Str_nth k (counter n i)).
Proof.
    move: i; elim: k => [|k IH] i.
    - case: i => [|i].
        + left. by exists 0.
        + right. move=> [a //].
    - rewrite Str_nth_S; simpl.
        case: i => [|i].
        + apply /(iffP (IH n)).
            * move=> [a ->]. by exists (S a).
            * move=> [a].
                case: a => [// | a].
                move /(f_equal Nat.pred); simpl.
                by exists a.
        + apply /(iffP (IH i)).
            * move=> [a ->]. by exists a.
            * move=> [a /(f_equal Nat.pred)]. by exists a.
Qed.

Lemma sieve_spec P n stream k :
    reflect P (Str_nth k stream) ->
    reflect (P \/ exists a b, k = b + S a * S (b + n)) (Str_nth k (sieve n stream)).
Proof.
    move: P n stream; elim: k => [|k IH] P n stream H.
    - apply /(iffP H).
        + by left.
        + case=> [// | [a [b]]].
            rewrite -plus_n_Sm => //.
    - apply /(iffP (IH _ _ _ _)).
        + rewrite Str_nth_zipWith. apply /orP.
        + case; first case.
            * move /H. by left.
            * move /counter_spec => [a ->]. right. by exists a, 0.
            * move=> [a [b ->]]. right. exists a, (S b).
                by rewrite -(plus_n_Sm b n).
        + case.
            * move /H. by left; left.
            * move=> [a [b]].
                move /(f_equal Nat.pred); case: b => [|b]; simpl=>->.
                -- left; right. apply /counter_spec. by exists a.
                -- right. exists a, b.
                    by rewrite -(plus_n_Sm b n).
Qed.

Theorem compositeP n : reflect (composite n) (compositeb n).
Proof.
    case: n => [|n]; last case: n => [|n].
    - right. move=> [a [b //]].
    - right. move=> [a [b //]].
    - apply /(iffP (sieve_spec False 1 (const false) n _)).
        + rewrite Str_nth_const. by right.
        + case=>[// | [a [b ->]]].
            rewrite -(plus_n_Sm b 0) -(plus_n_O).
            by exists a, b.
        + move=> [a [b]].
            do 2 move /(f_equal Nat.pred); simpl=>->.
            right; exists a, b.
            by rewrite -(plus_n_Sm b 0) -(plus_n_O).
Qed.