Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Bool.Reflect.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Notations.

Declare Scope zrange_scope.
Delimit Scope zrange_scope with zrange.
Local Set Nonrecursive Elimination Schemes.
(* COQBUG(https://github.com/coq/coq/issues/7835) *)
(*
Local Set Boolean Equality Schemes.
Local Set Decidable Equality Schemes.
*)
Record zrange := { lower : Z ; upper : Z }.
Bind Scope zrange_scope with zrange.
Local Open Scope Z_scope.
Scheme Minimality for zrange Sort Type.

Definition ZToZRange (z : Z) : zrange := {| lower := z ; upper := z |}.

Ltac inversion_zrange :=
  let lower := (eval cbv [lower] in (fun x => lower x)) in
  let upper := (eval cbv [upper] in (fun y => upper y)) in
  repeat match goal with
         | [ H : _ = _ :> zrange |- _ ]
           => pose proof (f_equal lower H); pose proof (f_equal upper H); clear H;
              cbv beta iota in *
         | [ H : Build_zrange _ _ = _ |- _ ]
           => pose proof (f_equal lower H); pose proof (f_equal upper H); clear H;
              cbv beta iota in *
         | [ H : _ = Build_zrange _ _ |- _ ]
           => pose proof (f_equal lower H); pose proof (f_equal upper H); clear H;
              cbv beta iota in *
         end.

(** All of the boundedness properties take an optional bitwidth, and
    enforce the condition that the range is within 0 and 2^bitwidth,
    if given. *)
Section with_bitwidth.
  Context (bitwidth : option Z).

  Definition is_bounded_by' : zrange -> Z -> Prop
    := fun bound val
       => lower bound <= val <= upper bound
          /\ match bitwidth with
             | Some sz => 0 <= lower bound /\ upper bound < 2^sz
             | None => True
             end.

  Definition is_bounded_by {n} : Tuple.tuple zrange n -> Tuple.tuple Z n -> Prop
    := Tuple.fieldwise is_bounded_by'.

  Lemma is_bounded_by_repeat_In_iff {n} vs bound
    : is_bounded_by (Tuple.repeat bound n) vs <-> (forall x, List.In x (Tuple.to_list _ vs) -> is_bounded_by' bound x).
  Proof. apply fieldwise_In_to_list_repeat_l_iff. Qed.
End with_bitwidth.

Lemma is_bounded_by_None_repeat_In_iff {n} vs l u
  : is_bounded_by None (Tuple.repeat {| lower := l ; upper := u |} n) vs
    <-> (forall x, List.In x (Tuple.to_list _ vs) -> l <= x <= u).
Proof.
  rewrite is_bounded_by_repeat_In_iff; unfold is_bounded_by'; simpl.
  split; intro H; intros; repeat split; apply H; assumption.
Qed.

Lemma is_bounded_by_None_repeat_In_iff_lt {n} vs l u
  : is_bounded_by None (Tuple.repeat {| lower := l ; upper := u - 1 |} n) vs
    <-> (forall x, List.In x (Tuple.to_list _ vs) -> l <= x < u).
Proof.
  rewrite is_bounded_by_None_repeat_In_iff.
  split; intro H; (repeat let x := fresh in intro x; specialize (H x)); lia.
Qed.

Definition is_bounded_by_bool (v : Z) (x : zrange) : bool
  := ((lower x <=? v) && (v <=? upper x))%bool%Z.

Definition is_tighter_than_bool (x y : zrange) : bool
  := ((lower y <=? lower x) && (upper x <=? upper y))%bool%Z.

Global Instance dec_eq_zrange : DecidableRel (@eq zrange) | 10.
Proof.
  intros [lx ux] [ly uy].
  destruct (dec (lx = ly)), (dec (ux = uy));
    [ left; apply f_equal2; assumption
    | abstract (right; intro H; inversion_zrange; tauto).. ].
Defined.

Definition zrange_beq (x y : zrange) : bool
  := (Z.eqb (lower x) (lower y) && Z.eqb (upper x) (upper y)).
Lemma zrange_bl (x y : zrange) (H : zrange_beq x y = true) : x = y.
Proof.
  cbv [zrange_beq] in *; rewrite Bool.andb_true_iff, !Z.eqb_eq in *.
  destruct x, y, H; simpl in *; subst; reflexivity.
Qed.
Lemma zrange_lb (x y : zrange) (H : x = y) : zrange_beq x y = true.
Proof.
  cbv [zrange_beq] in *; rewrite Bool.andb_true_iff, !Z.eqb_eq in *.
  subst; split; reflexivity.
Qed.

Global Instance reflect_zrange_eq : reflect_rel (@eq zrange) zrange_beq | 10.
Proof. apply reflect_of_beq; auto using zrange_bl, zrange_lb. Qed.

Global Instance zrange_rect_Proper {P}
  : Proper (pointwise_relation _ (pointwise_relation _ eq) ==> eq ==> eq) (@zrange_rect (fun _ => P)) | 10.
Proof.
  cbv [pointwise_relation zrange_rect]; repeat intro; subst; break_innermost_match; eauto.
Qed.

Global Instance zrange_rect_Proper_dep {P}
  : Proper (forall_relation (fun _ => forall_relation (fun _ => eq)) ==> forall_relation (fun _ => eq))
           (@zrange_rect P) | 10.
Proof.
  cbv [forall_relation zrange_rect]; repeat intro; subst; break_innermost_match; eauto.
Qed.

Module Export Notations.
  Declare Scope zrange_scope.
  Delimit Scope zrange_scope with zrange.
  Notation "r[ l ~> u ]" := {| lower := l ; upper := u |} : zrange_scope.
  Infix "<=?" := is_tighter_than_bool : zrange_scope.
  Infix "=?" := zrange_beq : zrange_scope.
End Notations.


From mathcomp Require Import all_ssreflect.
From deriving Require Import deriving.

Record foo := Foo { foo1 : nat; foo2 : bool }.
Scheme foo_rect := Induction for foo Sort Type.

Definition foo_indDef := [indDef for foo_rect].
Canonical foo_indType := IndType foo foo_indDef.
Definition foo_eqMixin := [derive eqMixin for foo].
Canonical foo_eqType := EqType foo foo_eqMixin.
Definition foo_choiceMixin := [derive choiceMixin for foo].
Canonical foo_choiceType := Eval hnf in ChoiceType foo foo_choiceMixin.
Definition foo_countMixin := [derive countMixin for foo].
Canonical foo_countType := Eval hnf in CountType foo foo_countMixin.


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import ZArith.
Require Import List.
Require Import Psatz.

Require Import Misc.
Require Import Linalg.
Require Import VplInterface.

Require Import Vpl.Impure.

Open Scope Z_scope.

Module Type PolyCanonizer (Import Imp: FullImpureMonad).

  Parameter canonize : polyhedron -> imp polyhedron.

  Parameter canonize_correct :
    forall p, WHEN r <- canonize p THEN (forall k v, 0 < k -> in_poly v (expand_poly k r) = in_poly v (expand_poly k p)).

  Parameter canonize_no_new_var :
    forall k p, absent_var p k -> WHEN r <- canonize p THEN absent_var r k.

End PolyCanonizer.

Module NaiveCanonizer(Import Imp: FullImpureMonad) <: PolyCanonizer Imp.

  Definition canonize (p : polyhedron) := pure p.

  Theorem canonize_correct :
    forall p, WHEN r <- canonize p THEN (forall k v, 0 < k -> in_poly v (expand_poly k r) = in_poly v (expand_poly k p)).
  Proof.
    intros p r Hcanon k v Hk. unfold canonize in Hcanon.
    apply mayReturn_pure in Hcanon. rewrite Hcanon. reflexivity.
  Qed.

  Theorem canonize_no_new_var :
    forall k p, absent_var p k -> WHEN r <- canonize p THEN absent_var r k.
  Proof.
    intros k p H r Hcanon. unfold canonize in Hcanon.
    apply mayReturn_pure in Hcanon. rewrite Hcanon in H. exact H.
  Qed.

End NaiveCanonizer.

Require Import ImpureAlarmConfig.

Module VplCanonizer <: PolyCanonizer CoreAlarmed.

  Definition check_not_new n (l1 l2 : polyhedron) :=
    (negb (forallb (fun c => nth n (fst c) 0 =? 0) l1)) || (forallb (fun c => nth n (fst c) 0 =? 0) l2).

  Lemma check_not_new_correct :
    forall n l1 l2, check_not_new n l1 l2 = true -> absent_var l1 n -> absent_var l2 n.
  Proof.
    intros n l1 l2 H1 H2 c Hc.
    unfold check_not_new in H1. reflect. destruct H1 as [H1 | H1].
    - exfalso. eapply eq_true_false_abs; [|exact H1].
      rewrite forallb_forall. intros c1; specialize (H2 c1). reflect; auto.
    - rewrite forallb_forall in H1. specialize (H1 c). reflect; auto.
  Qed.

  Definition check_no_new_vars l1 l2 :=
    let n := poly_nrl l2 in
    forallb (fun n => check_not_new n l1 l2) (n_range n).

  Lemma check_no_new_vars_correct :
    forall n l1 l2, check_no_new_vars l1 l2 = true -> absent_var l1 n -> absent_var l2 n.
  Proof.
    intros n l1 l2 H.
    destruct (n <? poly_nrl l2)%nat eqn:Hn; reflect.
    - apply check_not_new_correct.
      unfold check_no_new_vars in H. rewrite forallb_forall in H.
      apply H. rewrite n_range_in. auto.
    - intros H1 c Hc. rewrite <- poly_nrl_def in Hn. specialize (Hn c Hc).
      eapply nth_eq in Hn; rewrite Hn. rewrite nth_resize.
      destruct (n <? n)%nat eqn:Hn2; reflect; auto; lia.
  Qed.

  Definition canonize l :=
    BIND r <- lift (canonize_Cs (poly_to_Cs l)) -;
    pure match Cs_to_poly_Q r with
    | None => l
    | Some l2 =>
        if check_no_new_vars l l2 then l2 else l
  end.

  Lemma canonize_correct :
    forall p, WHEN r <- canonize p THEN (forall k v, 0 < k -> in_poly v (expand_poly k r) = in_poly v (expand_poly k p)).
  Proof.
    intros l l2 Hl2 k v Hk.
    unfold canonize in Hl2. bind_imp_destruct Hl2 r Hr.
    apply mayReturn_lift in Hr. apply mayReturn_pure in Hl2.
    destruct (Cs_to_poly_Q r) as [u|] eqn:Hu; [|congruence].
    destruct (check_no_new_vars l u); [|congruence].
    apply eq_iff_eq_true.
    rewrite <- poly_to_Cs_correct_Q with (p := l) by auto.
    rewrite (canonize_Cs_correct _ _ Hr _).
    rewrite (Cs_to_poly_Q_correct _ _ _ _ Hk Hu).
    rewrite Hl2. reflexivity.
  Qed.

  Lemma canonize_no_new_var :
    forall k p, absent_var p k -> WHEN r <- canonize p THEN absent_var r k.
  Proof.
    intros k l H l2 Hl2.
    unfold canonize in Hl2. bind_imp_destruct Hl2 r Hr. apply mayReturn_pure in Hl2.
    destruct (Cs_to_poly_Q r) as [u|]; [|rewrite <- Hl2; auto].
    destruct (check_no_new_vars l u) eqn:Hchk; [|rewrite <- Hl2; auto].
    rewrite <- Hl2. eapply check_no_new_vars_correct; eauto.
  Qed.

End VplCanonizer.

Module VplCanonizerZ.

  Definition canonize_constraint_Z (c : list Z * Z) :=
    let g := list_gcd (fst c) in
    if (g =? 0) then c
    else (map (fun x => x / g) (fst c), (snd c / g)).

  Lemma canonize_constraint_Z_correct :
    forall c p, satisfies_constraint p (canonize_constraint_Z c) = satisfies_constraint p c.
  Proof.
    intros c p. unfold canonize_constraint_Z.
    remember (list_gcd (fst c)) as g. destruct (g =? 0) eqn:Hg; auto.
    reflect. unfold satisfies_constraint; rewrite eq_iff_eq_true; reflect.
    assert (Hpos : 0 < g) by (generalize (list_gcd_nonneg (fst c)); lia).
    simpl.
    rewrite div_ge_iff by auto. f_equiv.
    rewrite <- Z.mul_comm, <- dot_product_mult_right. f_equal.
    unfold mult_vector. rewrite map_map.
    erewrite map_ext_in; [apply map_id|]. intros x Hx. simpl.
    symmetry; apply Znumtheory.Zdivide_Zdiv_eq; [auto|].
    rewrite Heqg; apply list_gcd_div. auto.
  Qed.

  Lemma canonize_constraint_Z_no_new_var :
    forall k c, nth k (fst c) 0 = 0 -> nth k (fst (canonize_constraint_Z c)) 0 = 0.
  Proof.
    intros k c H. unfold canonize_constraint_Z.
    destruct (list_gcd (fst c) =? 0); auto. simpl.
    transitivity (nth k (fst c) 0 / (list_gcd (fst c))).
    - rewrite <- map_nth with (f := fun x => x / list_gcd (fst c)). auto.
    - rewrite H. auto.
  Qed.

  Definition canonize l :=
    BIND r <- VplCanonizer.canonize (map canonize_constraint_Z l) -;
    pure (map canonize_constraint_Z r).

  Lemma canonize_correct :
    forall p, WHEN r <- canonize p THEN (forall v, in_poly v r = in_poly v p).
  Proof.
    intros l l2 Hl2 v.
    unfold canonize in Hl2. bind_imp_destruct Hl2 r Hr.
    apply mayReturn_pure in Hl2. apply VplCanonizer.canonize_correct in Hr.
    specialize (Hr 1 v). rewrite !expand_poly_1 in Hr.
    rewrite <- Hl2. unfold in_poly in *. rewrite forallb_map in *.
    erewrite forallb_ext; [|intros; rewrite canonize_constraint_Z_correct; reflexivity].
    rewrite Hr by lia.
    apply forallb_ext. intros; apply canonize_constraint_Z_correct.
  Qed.

  Lemma canonize_no_new_var :
    forall k p, absent_var p k -> WHEN r <- canonize p THEN absent_var r k.
  Proof.
    intros k l H l2 Hl2.
    unfold canonize in Hl2. bind_imp_destruct Hl2 r Hr. apply mayReturn_pure in Hl2.
    apply VplCanonizer.canonize_no_new_var with (k := k) in Hr.
    - intros c Hc. rewrite <- Hl2 in Hc. rewrite in_map_iff in Hc.
      destruct Hc as [c1 [Hc1 Hin1]]; rewrite <- Hc1; apply canonize_constraint_Z_no_new_var; auto.
    - intros c Hc; rewrite in_map_iff in Hc.
      destruct Hc as [c1 [Hc1 Hin1]]; rewrite <- Hc1; apply canonize_constraint_Z_no_new_var; auto.
  Qed.

End VplCanonizerZ.

Module Canon := VplCanonizer.
Module CanonZ := VplCanonizerZ.


(** *)
(** * The concept of schedule *)
(** *)

Record Schedule : Type :=
  mk_Sched {
      actions       : MS_ActEx;
      st_fin_times  : Ensemble nat;
      anchors       : Ensemble nat;
      anchors_not_0 : forall n:nat, Ensembles.In nat anchors n -> n <> 0
    }.

Notation "⟨ x ';' y ';' z ⟩" := (fun t => mk_Sched x y z t)(at level 10, no associativity).

Lemma Schedule_anchors_not_0_union :
  forall a b : Schedule, forall n : nat,
      Ensembles.In nat (Union nat (anchors a) (anchors b)) n -> n <> 0.
Proof.
  intros; inversion_clear H; [ destruct a | destruct b]; simpl in *;
    (apply anchors_not_1; exact H0).
Qed.

Definition Schedule_Union (a b:Schedule) : Schedule :=
  ⟨ Union_MS_ActEx (actions a) (actions b) ;
    Union _ (st_fin_times a) (st_fin_times b) ;
    Union _ (anchors a) (anchors b) ⟩ (Schedule_anchors_not_0_union a b).

Definition Atom_Offset_Map (a:Schedule)(t:nat) : Schedule.
Proof.
  refine(⟨ Offset_MS_ActEx (actions a) t ;
           Im _ _ (st_fin_times a) (fun x:nat => x + t) ;
           Im _ _ (anchors a) (fun x:nat => x + t) ⟩ _).
  abstract(intros; destruct a; simpl in *; eapply Im_inv in H;
           destruct H as [x Hx]; destruct Hx; rewrite <- H0;
           apply anchors_not_1 in H;
           omega).
Defined.

Lemma Empty_not_in_0 :  forall n : nat, Ensembles.In nat (Empty_set nat) n -> n <> 0.
Proof. intros;inversion H. Qed.

(** *)
(** * Semantic model for the interpretation of schedule specifications *)
(** *)
(** Schedule specifications are interpreted as sets of [Schedule] types. *)
(** *)

Definition Schedules := Ensemble Schedule.

(** An empty schedule atom. *)
Definition empty_Schedule : Schedules :=
  Singleton Schedule
            (⟨ Emp_MS_ActEx ; (Singleton _ 0) ; (Empty_set nat) ⟩ Empty_not_in_0).

(** A single action scheduling atom. *)
Definition act_atom (a:Action)(t:nat) : Schedules :=
  Singleton Schedule
            (⟨ Singleton_MS_ActEx a t 0 ; Singleton _ 0 ; Empty_set nat ⟩ Empty_not_in_0).

Lemma Sequence_Atom (t:nat) :
  forall n : nat, Ensembles.In nat (Setminus nat (Singleton nat t) (Singleton nat 0)) n -> n <> 0.
Proof.
  intros n H;inversion H;intro H2;apply H1;
    rewrite H2;constructor.
Qed.

Definition SeqSchedule_act(a:Action)(t:nat) : Schedule :=
  ⟨ Singleton_MS_ActEx a t 0 ;
    Singleton _ 0 ;
    Setminus _ (Singleton _ t) (Singleton _ 0) ⟩ (Sequence_Atom t).

(** Sequence of actions, prefixed by a timed action atom. *)
Inductive Seq_Schedule (a:Action)(t:nat)(P:Schedules) : Schedules :=
| in_seq_act :
    Ensembles.In _ (Seq_Schedule a t P) (SeqSchedule_act a t)
| in_seq_offset : forall s,
    Ensembles.In _ P s -> Ensembles.In _ (Seq_Schedule a t P) (Atom_Offset_Map s t).

Inductive Offset_Schedule (t:nat)(P:Schedules) : Schedules :=
| in_offset_act :
    Ensembles.In _ (Offset_Schedule t P)
                 (⟨Emp_MS_ActEx ; Singleton _ 0 ; Setminus nat (Singleton nat t) (Singleton nat 0)⟩
                    (Sequence_Atom t))
| in_offset_seq : forall s,
    Ensembles.In _ P s -> Ensembles.In _ (Offset_Schedule t P) (Atom_Offset_Map s t).

Inductive Delay_Atom (P:Atom) : At :=
| delay_atom: forall t:nat,
    Ensembles.In
      _
      (Delay_Atom P)
      ⟨ Emp_MS_ActEx ; Singleton _ 0 ; Setminus nat (Singleton nat t) (Singleton nat 0) ⟩

Definition offset_atom (t:nat)(P:Atom) : At :=
  Singleton Atom (
              AtomUnion (mk_Atom Emp_MS_ActEx
                                 (Singleton _ 0)
                                 (Setminus nat (Singleton nat t) (Singleton nat 0))
                                 (Sequence_Atom t))
                        (Atom_Offset_Map P t)).
⟩

                 (AtomUnion (mk_Atom Emp_MS_ActEx
                                                      (Singleton _ 0)
                                                      (Empty_set nat)
                                                      Empty_not_in_0)
                                             (Atom_Offset_Map P t)).

Inductive Elim_Delay_Atom (P:At) : At :=
| elim_delay_atom :
    forall a, Ensembles.In _ P a -> Strict_Included _ (st_fin_times a) (anchors a) ->
         Ensembles.In _ (Elim_Delay_Atom P) a.

Definition union_atom (a b:At) : At :=
  Union Atom a b.


Require Import Coq.Lists.List.
Require Import Coq.Reals.RIneq.
Require Import Coquelicot.Coquelicot.

Section HybridAutomata.

  (* Hybrid automaton definition *)
  Variable vars : Type.
  Definition state := vars -> R.
  Variable mode : Type.

  Record HybridAutomaton : Type :=
    { flow : mode -> state -> (* derivatives *) state -> Prop;
      inv : mode -> state -> Prop;
      init : mode -> state -> Prop;
      jump : mode -> mode -> state -> state -> Prop;
    }.

  Definition trajectory : Type := list (mode * state).

  Definition open_invariant (l r : R) (f : R -> state)
             (inv : state -> Prop) :=
    forall t, (l < t < r)%R -> inv (f t).

  Definition valid_flow (l r : R) (f : R -> state)
             (flow : state -> state -> Prop) :=
    (* We use strict inequalities here because the HyTech paper does. *)
    forall t, l < t < r ->
              exists ds,
                (forall x, is_derive (fun r => f r x) t (ds x)) /\
                flow (f t) ds.

  Inductive step (A : HybridAutomaton)
    : mode -> state -> mode -> state -> Prop :=
  | Jump : forall m m' s s',
      A.(jump) m m' s s' ->
      step A m s m' s'
  | Flow : forall (d : nonnegreal) (f : R -> state)
                  (m : mode),
      open_invariant 0 d f (A.(inv) m) ->
      valid_flow 0 d f (A.(flow) m) ->
      step A m (f R0) m (f d).

  Inductive valid (A : HybridAutomaton) : trajectory -> Prop :=
  | Initial : forall m s, A.(init) m s -> valid A ((m, s) :: nil)
  | Step : forall m s m' s' tr, valid A ((m,s) :: tr) ->
                                step A m s m' s' ->
                                valid A ((m',s') :: (m,s) :: tr).

  Definition ModeStateProp : Type := mode -> state -> Prop.

  Definition reachable (A : HybridAutomaton) : ModeStateProp :=
    fun m s => exists tr, valid A ((m,s) :: tr).

  (* Model checking hybrid automata *)
  Record Post (A : HybridAutomaton) : Type :=
    { next : ModeStateProp -> ModeStateProp;
      correct : forall (P : ModeStateProp) m s m' s',
          P m s -> step A m s m' s' ->
          next P m' s' }.

  Arguments next {_} _ _ _ _.

  Require Import Coq.Program.Equality.
  Lemma model_check_done :
    forall (A : HybridAutomaton) (P : Post A),
      (forall m s, P.(next) A.(init) m s -> A.(init) m s) ->
      forall m s, reachable A m s -> A.(init) m s.
  Proof.
    intros A P Hdone m s Hreach. unfold reachable in Hreach.
    destruct Hreach as [tr Hreach].
    dependent induction Hreach generalizing m s tr.
    { assumption. }
    { eapply Hdone. destruct P as [P HP]. simpl in *.
      eapply HP.
      { eapply IHHreach. reflexivity. }
      { assumption. } }
  Qed.

  Definition nonneg_0 : nonnegreal :=
    mknonnegreal R0 (Rle_refl _).

  Require Import Coq.micromega.Psatz.
  Lemma step_reflexive :
    forall (A : HybridAutomaton) m s,
      step A m s m s.
  Proof.
    intros A m s. pose proof (Flow A nonneg_0 (fun _ => s)) as HFlow.
    simpl in *. apply HFlow.
    { unfold open_invariant. intros. psatzl R. }
    { unfold valid_flow. intros. psatzl R. }
  Qed.

  Lemma post_abstracts :
    forall (A : HybridAutomaton) (P : Post A) (Q : ModeStateProp) m s,
      Q m s -> P.(next) Q m s.
  Proof.
    intros A P Q m s HQ. destruct P as [P HP].
    simpl. eapply HP; eauto. apply step_reflexive.
  Qed.

  Lemma model_check_step :
    forall (A : HybridAutomaton) (P : Post A) (Q : ModeStateProp),
      (forall m s, reachable {| flow:=A.(flow);
                                inv:=A.(inv);
                                init:=P.(next) A.(init);
                                jump:=A.(jump) |} m s -> Q m s) ->
      forall m s, reachable A m s -> Q m s.
  Proof.
    intros A P Q Hstep m s Hreach. apply Hstep. clear Hstep.
    unfold reachable in *. destruct Hreach as [tr Hreach].
    exists tr.
    dependent induction Hreach generalizing m s tr.
    { constructor. simpl.
      apply post_abstracts; assumption. }
    { constructor.
      { apply IHHreach. reflexivity. }
      { inversion H; subst.
        { apply Jump; auto. }
        { apply Flow; auto. } } }
  Qed.

(*
  Definition PostFlow (P : ModeStateProp)
             (flow : mode -> state -> state -> Prop)
             (sol : state -> state -> nonnegreal -> state -> Prop)
             (inv : mode -> state -> Prop) : ModeStateProp :=
    fun m s' =>
      exists (s ds : state) d,
        P m s /\ flow m s ds /\ sol s ds d s' /\ inv m s'.

  Definition PostJump (P : ModeStateProp)
             (jump : mode -> mode -> state -> state -> Prop)
    : ModeStateProp :=
    fun m' s' => exists m s, P m s /\ jump m m' s s'.

  Definition Post (A : HybridAutomaton) (P : ModeStateProp)
    : ModeStateProp :=
    fun m' s' => (exists f, PostFlow P A.(flow) f A.(inv) m' s')
                 \/ PostJump P A.(jump) m' s'.
*)

End HybridAutomata.

(* Thermostat for HyTech paper*)
Inductive var : Type :=
| x : var (* Temperature *)
| y : var (* Global clock *)
| z : var (* Clock capturing time spent in on state *)
.

Inductive mode : Type :=
| on : mode
| off : mode.

Definition Thermostat : HybridAutomaton var mode :=
{| flow := fun m s ds =>
             match m with
             | on => 2 <= ds x <= 4 /\ ds y = 1 /\ ds z = 1
             | off => -3 <= ds x <= -1 /\ ds y = 1 /\ ds z = 0
             end;
   inv := fun m s =>
            match m with
            | on => 1 <= s x <= 3
            | off => 1 <= s x <= 3
            end;
   init := fun m s =>
             match m with
             | on => s x = 2
             | off => False
             end;
   jump := fun m m' s s' =>
             match m, m' with
             | on, off => s x = 3 /\ s' x = s x
             | off, on => s x = 1 /\ s' x = s x
             | _, _ => False
             end;
|}.


From mathcomp Require Import all_ssreflect.

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

Section Aux.

Definition update (T : finType) S (m : {ffun T -> S}) (x : T) (f : S -> S) : {ffun T -> S} :=
  [ffun i => if i == x then f (m i) else m i].

End Aux.

Variable (n : nat).

(* state per node *)
Record node_st :=
  { rcount : nat
  ; max : nat
  ; has_sent : {ffun 'I_n -> bool}
  }.

Definition set_send_node (s : node_st) i : node_st :=
  {| rcount := s.(rcount)
   ; max := s.(max)
   ; has_sent := update s.(has_sent) i (fun _ => true)
  |}.

Definition node_recv (s : node_st) m :=
  {| rcount := s.(rcount).+1
   ; max := maxn s.(max) m
   ; has_sent := s.(has_sent)
  |}.

(* Definition node_recv (s : node_st)  *)

Record cprotocol_st :=
 { cqueues : {ffun 'I_n -> seq nat}
 ; cnode_sts : {ffun 'I_n -> node_st}
 }.

Definition set_send (s : cprotocol_st) (i j : 'I_n) : cprotocol_st :=
  {| cqueues := update s.(cqueues) j (fun pq => [:: val i & pq])
   ; cnode_sts := update s.(cnode_sts) i (fun pst => set_send_node pst j)
  |}.

Definition do_recv (s : cprotocol_st) m i :=
  {| cnode_sts := update s.(cnode_sts) i (fun pst => node_recv pst m)
   ; cqueues := update s.(cqueues) i (fun pq => rem m pq)
   |}.

Definition get_max (s : cprotocol_st) i :=
  (s.(cnode_sts) i).(max).

Inductive label := Eps | Decided of nat.

Definition get_label s i :=
  if (s.(cnode_sts) i).(rcount) < n
  then Eps
  else Decided (get_max s i).

Reserved Notation "s1 --[ l ]-->_c s2" (at level 30).

Inductive concrete_step : cprotocol_st -> label -> cprotocol_st -> Prop :=
  | Send :
    forall s1 i j,
      (s1.(cnode_sts) i).(has_sent) j = false ->
      let s2 := set_send s1 i j in
   (* ---------------------------- *)
      s1 --[Eps]-->_c s2

  | Recv :
    forall s1 i (m : 'I_n),
      (* (s1.(node_sts) i).(rcount).+1 < n -> *)
      val m \in s1.(cqueues) i ->
      let s2 := do_recv s1 i m in
   (* ---------------------------- *)
      s1 --[get_label s2 i]-->_c s2

  (* | Decide : *)
  (*   forall s1 i (m : 'I_n), *)
  (*     (s1.(node_sts) i).(rcount).+1 = n -> *)
  (*     val m \in s1.(queues) i -> *)
  (*     let s2 := do_recv s1 i m in *)
  (*  (* ---------------------------- *) *)
  (*     s1 --[Decided (get_max s2 i) ]--> s2 *)

where "s1 --[ l ]-->_c s2" := (concrete_step s1 l s2).

Inductive Phase := SendP of nat | RecvP of nat.

Record aprotocol_st :=
 { phase : Phase
 (* ; step_i : nat *)
 (* ; step_j : nat *)
 ; aqueues : {ffun 'I_n -> seq nat}
 ; anode_sts : {ffun 'I_n -> node_st}
 }.

Definition set_phase s p :=
  {| phase := p
   ; aqueues := s.(aqueues)
   ; anode_sts := s.(anode_sts)
   |}.

Definition phase_next p (hsent : {ffun 'I_n -> bool}):=
  match p with
  | SendP i =>
      if [forall i, hsent i == true] then
        if i < n
        then SendP i.+1
        else RecvP 0
      else SendP i
  | RecvP i => RecvP i.+1
  end.

Definition set_asend (s : aprotocol_st) (i j : 'I_n) : aprotocol_st :=
  {| phase := phase_next s.(phase) (s.(anode_sts) i).(has_sent)
   ; aqueues := update s.(aqueues) j (fun pq => [:: val i & pq])
   ; anode_sts := update s.(anode_sts) i (fun pst => set_send_node pst j)
  |}.

Reserved Notation "s1 --[ l ]-->_a s2" (at level 30).

Inductive abs_step : aprotocol_st -> label -> aprotocol_st -> Prop :=
  | A_Send :
    forall s1 (i : 'I_n) j,
      s1.(phase) = SendP i ->
      (s1.(anode_sts) i).(has_sent) j = false ->
      let s2 := set_asend s1 i j in
   (* ---------------------------- *)
      s1 --[Eps]-->_a s2

where "s1 --[ l ]-->_a s2" := (abs_step s1 l s2).

(* Not sure how this should look *)
Lemma Send_left : forall s1 s2 s3 s4 l1 l2 l3 :
    s1 --[ l1 ]-->_c s2 ->
    s2 --[ l2 ]-->_c (Send ...) ->
    (Send ...) --[ l3 ]-->_c s4 ->
    exists l1' l2' l3' s2',
      s1 --[ l1' ]-->_c (Send ...) ->
      (Send ...) --[ l2' ]-->_c s2' ->
      s2' --[ l3' ]-->_c s4.


Locate "~".
Print not.
Locate "<->".
Print iff.

Fact Leibniz_symmetry X (x y: X) :
  (forall p: X -> Prop, p x -> p y) -> (forall p: X -> Prop, p y -> p x).
Proof.
  intros f p.
  refine (f _ (fun a => a)).
  Show Proof.
Abort.

Fact Leibniz_symmetry X (x y: X) :
  (forall p: X -> Prop, p x -> p y) -> (forall p: X -> Prop, p y -> p x).
Proof.
  intros f p.
  change ((fun z => p z -> p x) y).
  apply f.
  intros a. exact a.
  Show Proof.
Qed.

Locate "/\".
Print and.

Definition match_and (X Y: Prop) (Z: Type) (a: X /\ Y) (f: X -> Y -> Z) : Z :=
  match a with conj x y => f x y end.

Locate "\/".
Print or.

Definition match_or (X Y: Prop) (Z: Prop) (a: X \/ Y) (f: X -> Z) (g: Y -> Z) : Z :=
  match a with or_introl x => f x | or_intror y => g y end.

Fail
  Definition match_or (X Y: Prop) (Z: Type) (a: X \/ Y) (f: X -> Z) (g: Y -> Z) : Z :=
  match a with or_introl x => f x | or_intror y => g y end.

(* Universe Inconsistency *)

Check (fun X: Set => True) Set.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import Arith Lia.

Require Import subAll.
Require Import folReplace.
Require Import folProp.
Require Import folLogic3.
Require Import NN.
Require Import LNN2LNT.
Require Export PA.
Require Import NewNotations.

#[local] Arguments apply _ _ _ : clear implicits.

Lemma paZeroOrSucc (t : Term):
 SysPrf PA
 (t = Zero \/
     exH (newVar (0 :: freeVarTerm LNT t)),
       (t = Succ (v_ (newVar (0 :: freeVarTerm LNT t)))))%nt.
  Proof.
    set (nv := newVar (0 :: freeVarTerm LNT t)) in *.
  apply impE with
    (substituteFormula LNT
       (v_ 0 = Zero \/ exH nv, v_ 0 = Succ v_ nv)%nt
       0 t).
  - rewrite (subFormulaOr LNT), (subFormulaEqual LNT); simpl.
    apply iffE1, (reduceOr LNT).
    + apply iffRefl.
    + rewrite (subFormulaExist LNT).
      destruct (eq_nat_dec nv 0) as [a | b].
      * elim (newVar1 (0 :: freeVarTerm LNT t)).
        fold nv in |- *.
        rewrite a; simpl; auto.
      * destruct (In_dec eq_nat_dec nv (freeVarTerm LNT t))
          as [a | b0].
        -- elim (newVar1 (0 :: freeVarTerm LNT t)).
           fold nv in |- *; simpl in |- *; auto.
        -- rewrite (subFormulaEqual LNT).
           Opaque eq_nat_dec.
           simpl in |- *.
           Transparent eq_nat_dec.
           destruct (eq_nat_dec 0 nv) as [e | n ].
           ++ elim b; auto.
           ++ apply iffRefl.
  - apply forallE, induct.
    + rewrite (subFormulaOr LNT); apply orI1.
      rewrite (subFormulaEqual LNT); simpl; apply eqRefl.
    + apply forallI.
      * apply closedPA.
      * apply impI; rewrite (subFormulaOr LNT); apply orI2.
        rewrite (subFormulaExist LNT).
        induction (eq_nat_dec nv 0).
  -- elim (newVar1 (0 :: freeVarTerm LNT t)).
     fold nv; simpl; auto.
  -- induction (In_dec eq_nat_dec nv (freeVarTerm LNT (Succ (v_ 0))%nt))
       as [a | b0].
     ++ elim (newVar1 (0 :: freeVarTerm LNT t)).
        fold nv in |- *.
        simpl in a.
        induction a as [H| H].
        ** simpl in |- *.
           auto.
        ** elim H.
       ++ rewrite (subFormulaEqual LNT).
          Opaque eq_nat_dec.
          simpl in |- *.
          Transparent eq_nat_dec.
          induction
            (nat_rec (fun n : nat => {0 = n} + {0 <> n})
               (left (0 <> 0) (refl_equal 0))
               (fun (m : nat) (_ : {0 = m} + {0 <> m}) =>
                  right (0 = S m) (O_S m)) nv) as [a | b1].
          ** elim b; auto.
          ** fold (Succ (var nv)).
             apply sysWeaken;  apply existI with (var 0).
             rewrite (subFormulaEqual LNT).
             simpl in |- *.
             destruct (eq_nat_dec nv 0) as [e | n].
             { elim b1; auto. }
             change match nv as n return ({0 = n} + {0 <> n}) with
                  | 0 => left (0 <> 0) (refl_equal 0)
                  | S m => right (0 = S m) (O_S m)
                  end
               with (eq_nat_dec 0 nv).
             destruct (eq_nat_dec 0 nv) as [e | n0].
             { now elim b1. }
             simpl; destruct (eq_nat_dec nv nv) as [? | n1].
             { apply eqRefl. }
             now destruct n1.
Qed.

Lemma paPlusSym : forall a b : Term,
    SysPrf PA (a + b = b + a)%nt.
Proof.
  assert
    (H: SysPrf PA (allH 1 0, v_ 0 + v_ 1 = v_ 1 + v_ 0)%nt).
  { apply induct.
    - rewrite (subFormulaForall LNT).
      induction (eq_nat_dec 0 1) as [a | b].
      + discriminate a.
      + induction (In_dec eq_nat_dec 0 (freeVarTerm LNT Zero)) as [a | b0].
        * elim a.
        * apply induct.
          -- repeat rewrite (subFormulaEqual LNT).
             simpl in |- *; apply eqRefl.
          -- apply forallI.
             ++ apply closedPA.
             ++ repeat rewrite (subFormulaEqual LNT).
                simpl; apply impI.
                apply eqTrans with (Succ (v_ 0))%nt.
                ** apply sysWeaken.
                   apply pa3 with (a := (Succ (var 0))%nt).
                ** apply eqTrans with (Succ (Zero + v_ 0))%nt.
                   { apply eqSucc.
                     apply eqTrans with (v_ 0 + Zero)%nt.
                     - apply sysWeaken.
                       apply eqSym.
                       apply pa3.
                     - apply Axm; right; constructor.
                   }
                   apply eqSym.
                   apply sysWeaken.
                   apply pa4 with (a := Zero%nt) (b := (v_ 0)%nt).
    - apply forallI.
      + apply closedPA.
      + apply impI.
        rewrite (subFormulaForall LNT).
        induction (eq_nat_dec 0 1) as [a | b].
        * discriminate a.
        * induction (In_dec eq_nat_dec 0 (freeVarTerm LNT (Succ (v_ 1))%nt)).

          -- simpl in a.
             induction a as [H| H].
             ++ discriminate.
             ++ contradiction.
          -- rewrite (subFormulaEqual LNT).
             simpl; apply forallI.
             ++ intros [x [H H0]].
                destruct H0 as [x H0| x H0].
                ** elim closedPA with 0.
                   exists x; auto.
                ** induction H0; simpl in H.
                   decompose sum H.
                   discriminate H0.
                   discriminate H1.
             ++ apply eqTrans with (Succ (v_ 0 + v_ 1))%nt.
                ** apply sysWeaken.
                   apply pa4 with (a := var 0) (b := var 1).
                ** apply eqTrans with (Succ (v_ 1 + v_ 0))%nt.
                   { apply eqSucc.
                     apply forallSimp with 0.
                     apply Axm; right; constructor.
                   }
                   apply sysWeaken.
                   apply forallSimp with 0.
                   apply induct.
                   rewrite (subFormulaEqual LNT).
                   simpl in |- *.
                   apply eqTrans with (Succ (v_ 1))%nt.
                   {
                     fold
                       (Succ (v_ 1 + Zero))%nt.
                     apply eqSucc.
                     apply pa3 with (a := (v_ 1)%nt).
                   }
                   apply eqSym.
                   apply pa3 with (a := (Succ v_ 1)%nt).
                   apply forallI.
                   apply closedPA.
                   apply impI.
                   rewrite (subFormulaEqual LNT).
                   simpl in |- *.
                   apply eqTrans with  (Succ (Succ v_ 1 + v_ 0))%nt.
                   {
                     fold (Succ (v_ 1 + Succ v_ 0))%nt.
                     apply eqSucc.
                     apply eqTrans with (Succ (v_ 1 + v_ 0))%nt.
                     apply sysWeaken.
                     apply pa4 with (a := (v_  1)%nt) (b := (v_ 0)%nt).
                     apply Axm; right; constructor.
                   }
                   apply sysWeaken.
                   apply eqSym.
                   apply pa4 with (a := Succ (v_ 1)%nt) (b := (v_ 0)%nt).
  }
  intros a b;
  set (m := fun x : nat => match x with
                         | O => a
                         | S _ => b
                         end) in *.
  replace (a + b = b + a)%nt with
    (subAllFormula LNT (v_ 0 + v_ 1 = v_ 1 + v_ 0)%nt
       (fun x : nat =>
          match le_lt_dec 2 x with
          | left _ => var x
          | right _ => m x
          end)).
  + apply (subAllCloseFrom LNT).
    simpl; apply H.
  + simpl; destruct (le_lt_dec 2 0).
    * lia.
    * induction (le_lt_dec 2 1).
      -- lia.
      -- reflexivity.
Qed.

Lemma NN72PA : SysPrf PA (LNN2LNT_formula NN7).
Proof.
  simpl; apply forallI.
  - apply closedPA.
  - rewrite translateLT1.
    set (nv := newVar (0 :: 2 :: 1 :: 0 :: nil)) in *.
     fold Zero%nt; fold (Succ (v_ nv))%nt; fold (v_ 0 +  (Succ v_ nv))%nt.
    apply nnI, forallI.
    + apply closedPA.
    + apply impE with (Succ (v_ 0 + v_ nv) <> Zero)%nt.
      * apply cp2, impI; apply eqTrans with (v_ 0 + Succ (v_ nv))%nt.
        -- apply sysWeaken, eqSym, pa4.
        -- apply Axm; right; constructor.
      * apply pa1.
Qed.

Lemma NN82PA : SysPrf PA (LNN2LNT_formula NN8).
Proof.
  replace (LNN2LNT_formula NN8) with
    (allH 1 0,
      translateLT (Tcons v_ 0 (Tcons (S_ v_ 1) Tnil)) ->
      translateLT (Tcons v_ 0 (Tcons v_ 1 Tnil)) \/ v_ 0 = v_ 1)%nt; simpl.

  - repeat rewrite translateLT1; simpl.
    unfold newVar; simpl; fold (Succ (v_ 3))%nt.
    fold (Succ (v_ 1))%nt; fold (v_ 0 + Succ v_ 3)%nt.
    fold (exH 3, v_ 0 + Succ v_ 3 = Succ v_ 1)%nt.
    fold (exH 3, v_ 0 + Succ  v_ 3 = v_ 1)%nt.
    apply forallI.
    + apply closedPA.
    + apply forallI.
     * apply closedPA.
     * apply impI.
       apply existSys.
       -- apply closedPA.
       -- simpl; intro H.
          repeat (elim H; clear H; [ discriminate | intros ]); auto.
       -- eapply orE.
          ++ apply sysWeaken.
             apply paZeroOrSucc.
          ++ apply impI; apply orI2.
             apply impE with (Succ v_ 0 = Succ v_ 1)%nt.
             ** repeat simple apply sysWeaken.
                apply pa2.
             ** apply eqTrans with (v_ 0 + Succ v_ 3)%nt.
                apply eqTrans with (Succ (v_ 0 + v_ 3))%nt.
                apply eqSucc.
                apply eqTrans with (v_ 0 + Zero)%nt.
                apply eqSym.
                repeat simple apply sysWeaken.
                apply pa3.
                apply eqPlus.
                apply eqRefl.
                apply eqSym.
                apply Axm; right; constructor.
                apply eqSym.
                repeat simple apply sysWeaken.
                apply pa4.
                apply Axm; left; right; constructor.
          ++ unfold newVar in |- *; simpl; apply impI.
             apply existSys.
             intros (x, H); induction H as (H, H0).
             induction H0 as [x H0| x H0].
             elim closedPA with 4.
             exists x.
             auto.
             induction H0.
             simpl in H.
             repeat (elim H; clear H; [ discriminate | intros ]); auto.
             intros H; simpl in H.
             repeat (elim H; clear H; [ discriminate | intros ]); auto.
             apply orI1.
             apply existI with (var 4).
             rewrite (subFormulaEqual LNT).
             simpl; apply impE with
               (Succ (v_ 0 + Succ v_ 4) = Succ v_ 1)%nt.
             repeat simple apply sysWeaken.
             apply pa2.
             apply eqTrans with (v_ 0 + Succ v_ 3)%nt.
             apply eqTrans with (v_ 0 + Succ (Succ  v_ 4))%nt.
             repeat simple apply sysWeaken.
             apply eqSym.
             apply pa4.
             apply eqPlus.
             apply eqRefl.
             apply eqSucc.
             apply eqSym.
             apply Axm; right; constructor.
             apply Axm; left; right; constructor.
  - reflexivity.
Qed.

Lemma NN92PA : SysPrf PA (LNN2LNT_formula NN9).
Proof.
  replace (LNN2LNT_formula NN9) with
(allH 1 0,
     LNN2LNT_formula ((v_ 0)%nt < (v_ 1)%nt)%nn \/
     v_ 0 = v_ 1 \/ LNN2LNT_formula (v_ 1 < v_ 0)%nn)%nt;
    [ idtac | reflexivity ].
  simpl in |- *.
  repeat rewrite translateLT1.
  simpl in |- *.
  unfold newVar in |- *.
  simpl in |- *.
  fold (Succ v_ 3)%nt in |- *.
  fold (v_ 0 + Succ v_ 3)%nt.
  fold (v_ 1 + Succ v_ 3)%nt.
  fold (exH 3, v_ 0 + Succ v_ 3 = v_ 1)%nt.
  fold (exH 3, v_ 1 + Succ v_ 3 = v_ 0)%nt.
    apply induct.
  - rewrite (subFormulaForall LNT).
    induction (eq_nat_dec 0 1).
    + discriminate a.
    + induction (In_dec eq_nat_dec 0 (freeVarTerm LNT Zero)).
      * simpl in a.
        elim a.
      * rewrite (subFormulaOr LNT).
        apply forallI.
        apply closedPA.
        apply orI2.
        rewrite (subFormulaOr LNT).
        rewrite (subFormulaEqual LNT).
        simpl in |- *.
        eapply orE.
        -- apply paZeroOrSucc with (t := (v_ 0)%nt).
        -- apply impI.
           apply orI1.
           apply Axm; right; constructor.
        -- apply impI.
           apply orI2.
           unfold newVar in |- *.
           simpl in |- *.
           rewrite (subFormulaExist LNT).
           induction (eq_nat_dec 3 1).
           ++ discriminate a.
           ++ induction (In_dec eq_nat_dec 3 (freeVarTerm LNT Zero)).
              ** elim a.
              ** apply impE with (exH 3, v_ 0 = Succ v_ 3)%nt.
                 { apply sysWeaken.
                   apply impI.
                   apply existSys.
                   - apply closedPA.
                   - unfold not in |- *; intros.
                     simpl in H.
                     induction H as [H| H].
                     + discriminate H.
                     + contradiction.
                   - apply existI with (v_ 3)%nt.
                     repeat rewrite (subFormulaEqual LNT).
                     simpl in |- *.
                     apply eqTrans with (Succ v_ 3)%nt.
                     + apply sysWeaken.
                       apply eqTrans with (Succ v_ 3 + Zero)%nt.
                       * apply paPlusSym with (a := Zero) (b := (Succ v_ 3)%nt).
                       * apply pa3.
                     + apply eqSym.
                       apply Axm; right; constructor.
                 }
                 apply impE with (exH 1, v_ 0 = Succ v_ 1)%nt.
                 {
                   replace (v_ 0 = Succ v_ 3)%nt with
                     (substF LNT (v_ 0 = Succ v_ 1)%nt 1 (v_ 3)%nt).
                   - apply iffE1.
                     apply (rebindExist LNT).
                     simpl in |- *.
                     unfold not in |- *; intros.
                     induction H as [H| H].
                     + discriminate H.
                     + contradiction.
                   - rewrite (subFormulaEqual LNT).
                     reflexivity.
                 }
                 apply Axm; right; constructor.
  - apply forallI.
    + apply closedPA.
    + apply impI.
      rewrite (subFormulaForall LNT).
      induction (eq_nat_dec 0 1).
      * discriminate a.
      * induction (In_dec eq_nat_dec 0 (freeVarTerm LNT (Succ v_ 1)%nt)).
        -- simpl in a.
           induction a as [H| H].
           ++ discriminate H.
           ++ contradiction.
        -- rewrite (subFormulaOr LNT).
           apply sysWeaken.
           apply induct.
           ++ rewrite (subFormulaOr LNT).
              apply orI1.
              rewrite (subFormulaExist LNT).
              induction (eq_nat_dec 3 1).
              ** discriminate a.
              ** induction (In_dec eq_nat_dec 3
                              (freeVarTerm LNT (Succ v_ 1)%nt)).
                 { simpl in a.
                   induction a as [H| H].
                   - elim b1; auto.
                   - contradiction.
                 }
                 rewrite (subFormulaExist LNT).
                 induction (eq_nat_dec 3 0).
                 { discriminate a. }
                 induction (In_dec eq_nat_dec 3 (freeVarTerm LNT Zero)).
                 { simpl in a; contradiction. }
                 apply existI with (v_ 1)%nt.
                 repeat rewrite (subFormulaEqual LNT).
                 simpl in |- *.
                 apply eqTrans with (Succ v_ 1 + Zero)%nt.
                 { apply paPlusSym with (a := Zero) (b := (Succ v_ 1)%nt). }
                 apply pa3.
           ++ apply forallI.
              ** apply closedPA.
              ** apply impI; apply orSys.
                 { rewrite (subFormulaExist LNT).
                   induction (eq_nat_dec 3 1).
                   - discriminate a.
                   - induction (In_dec eq_nat_dec 3
                                  (freeVarTerm LNT (Succ (v_ 1))%nt)).
                     + simpl in a.
                       induction a as [H| H].
                       * elim b1; auto.
                       * contradiction.
                     + repeat rewrite (subFormulaOr LNT).
                       rewrite (subFormulaExist LNT).
                       induction (eq_nat_dec 3 0).
                       * discriminate a.
                       * induction (In_dec eq_nat_dec 3
                                      (freeVarTerm LNT (Succ (v_ 0))%nt)).
                         -- simpl in a.
                            induction a as [H| H].
                            ++ elim b3; auto.
                            ++ contradiction.
                         -- rewrite (subFormulaExist LNT).
                            induction (eq_nat_dec 3 1).
                            ++ elim b1; auto.
                            ++ induction (In_dec eq_nat_dec 3
                                            (freeVarTerm LNT (Succ (v_ 1))%nt)).
                               ** elim b2; auto.
                               ** rewrite (subFormulaExist LNT).
                                  induction (eq_nat_dec 3 0).
                                  { elim b3; auto. }
                                  induction (In_dec eq_nat_dec
                                               3
                                               (freeVarTerm LNT
                                                  (Succ (v_ 0))%nt)).
                                  { elim b4; auto. }
                                  repeat rewrite (subFormulaEqual LNT);
                                    simpl in |- *.
                                  apply existSys.
                                  { apply closedPA. }
                                  simpl in |- *.
                                  unfold not in |- *; intros.
                                  decompose sum H; auto.
                                  eapply orE.
                                  apply sysWeaken.
                                  apply paZeroOrSucc with (t := (v_ 3)%nt).
                                  apply impI.
                                  apply orI2.
                                  apply orI1.
                                  apply eqTrans with (v_ 0 + Succ v_ 3)%nt.
                                  apply eqTrans with (Succ (v_ 0 + v_ 3))%nt.
                                  apply eqSucc.
                                  apply eqTrans with (v_ 0 + Zero)%nt.
                                  apply eqSym.
                                  repeat simple apply sysWeaken.
                                  apply pa3.
                                  apply eqPlus.
                                  apply eqRefl.
                                  apply eqSym.
                                  apply Axm; right; constructor.
                                  apply eqSym.
                                  repeat simple apply sysWeaken.
                                  apply pa4.
                                  apply Axm; left; right; constructor.
                                  unfold newVar in |- *.
                                  simpl in |- *.
                                  apply impI.
                                  apply orI1.
                                  apply existSys.
                                  unfold not in |- *; intros.
                                  induction H as (x, H); induction H as (H, H0).
                                  induction H0 as [x H0| x H0].
                                  elim closedPA with 4.
                                  exists x.
                                  auto.
                                  induction H0.
                                  simpl in H.
                                  decompose sum H;
                                    discriminate H0 || discriminate H1.
                                  simpl in |- *.
                                  unfold not in |- *; intros.
                                  decompose sum H;
                                    discriminate H0 || discriminate H1.
                                  apply existI with (var 4).
                                  rewrite (subFormulaEqual LNT); simpl in |- *.
                                  apply eqTrans with (v_ 0 + Succ v_ 3)%nt.
                                  apply eqTrans with (v_ 0 + Succ (Succ v_ 4))%nt.
                                  apply eqTrans with (Succ (v_ 0 + Succ v_ 4))%nt.
                                  apply eqTrans with (Succ v_ 4 + Succ v_ 0)%nt.
                                  repeat simple apply sysWeaken.
                                  apply paPlusSym with
                                    (a := (Succ v_ 0)%nt) (b := (Succ v_ 4)%nt).
                                  repeat simple apply sysWeaken.
                                  eapply eqTrans.
                                  apply pa4.
                                  apply eqSucc.
                                  apply paPlusSym.
                                  repeat simple apply sysWeaken.
                                  apply eqSym.
                                  apply pa4.
                                  apply eqPlus.
                                  apply eqRefl.
                                  apply eqSucc.
                                  apply eqSym.
                                  apply Axm; right; constructor.
                                  apply Axm; left; right; constructor.
                 }
                 repeat rewrite (subFormulaOr LNT).
                 apply orSys.
                 apply orI2.
                 apply orI2.
                 rewrite (subFormulaExist LNT).
                 induction (eq_nat_dec 3 1).
                 { discriminate a. }
                 induction (In_dec eq_nat_dec 3
                              (freeVarTerm LNT (Succ v_ 1)%nt)).
                 induction a as [H| H].
                 { elim b1; auto. }
                 contradiction.
                 rewrite (subFormulaExist LNT).
                 induction (eq_nat_dec 3 0).
                 discriminate a.
                 induction (In_dec eq_nat_dec 3
                              (freeVarTerm LNT (Succ v_ 0)%nt)).
                 induction a as [H| H].
                 elim b3; auto.
                 contradiction.
                 apply existI with Zero.
                 repeat rewrite (subFormulaEqual LNT).
                 simpl in |- *.
                 apply eqTrans with  (Succ (Succ v_ 1 + Zero))%nt.
                 apply sysWeaken.
                 apply pa4 with (a := (Succ v_ 1)%nt) (b := Zero).
                 apply eqTrans with (Succ (Succ v_ 1))%nt.
                 apply eqSucc.
                 apply sysWeaken.
                 apply pa3.
                 fold (Succ (v_ 0))%nt.
                 apply eqSucc.
                 apply eqSym.
                 apply Axm; right; constructor.
                 do 2 rewrite (subFormulaExist LNT).
                 induction (eq_nat_dec 3 1).
                 discriminate a.
                 induction (In_dec eq_nat_dec 3
                              (freeVarTerm LNT (Succ v_ 1)%nt)).
                 induction a as [H| H].
                 elim b1; auto.
                 contradiction.
                 do 2 rewrite (subFormulaExist LNT).
                 induction (eq_nat_dec 3 0).
                 discriminate a.
                 induction (In_dec eq_nat_dec 3
                              (freeVarTerm LNT (Succ (v_ 0))%nt)).
                 induction a as [H| H].
                 elim b3; auto.
                 contradiction.
                 apply orI2.
                 apply orI2.
                 apply existSys.
                 apply closedPA.
                 simpl in |- *.
                 unfold not in |- *; intros.
                 decompose sum H; auto.
                 apply existI with (Succ v_ 3)%nt.
                 repeat rewrite (subFormulaEqual LNT).
                 simpl in |- *.
                 apply eqTrans with  (Succ (Succ v_ 1 + Succ v_ 3))%nt.
                 apply sysWeaken.
                 apply pa4 with (a := (Succ v_ 1)%nt) (b := (Succ v_ 3)%nt).
                 fold (Succ v_ 0)%nt in |- *.
                 apply eqSucc.
                 apply Axm; right; constructor.
Qed.


(***********************************************************************************

 Monads can be composed if we have a distributive law between them

 This results holds for monads in arbitrary bicategories. For monads of categories,
 this was already proved in Monads.Derivative.v (`monad_comp`)

 ***********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Monads.DistributiveLaws.

Local Open Scope cat.

Section ComposeMonad.
  Context {B : bicat}
          {x : B}
          (dm₁ dm₂ : disp_mnd B x)
          (α : distr_law dm₁ dm₂).

  Let m₁ : mnd B := x ,, dm₁.
  Let m₂ : mnd B := x ,, dm₂.

  Let f : x --> x := endo_of_mnd m₁.
  Let g : x --> x := endo_of_mnd m₂.

  Let η₁ : id₁ _ ==> f := unit_of_mnd m₁.
  Let η₂ : id₁ _ ==> g := unit_of_mnd m₂.

  Let μ₁ : f · f ==> f := mult_of_mnd m₁.
  Let μ₂ : g · g ==> g := mult_of_mnd m₂.

  Let ηc : id₁ x ==> f · g
    := linvunitor _ • (η₁ ▹ _) • (_ ◃ η₂).

  Let μc
    : f · g · (f · g) ==> f · g
    := rassociator _ _ _
       • (f ◃ lassociator _ _ _)
       • (f ◃ (α ▹ g))
       • (f ◃ rassociator _ _ _)
       • lassociator _ _ _
       • (μ₁ ▹ _)
       • (_ ◃ μ₂).

  Definition compose_mnd_unit_left
    : (linvunitor (f · g) • (ηc ▹ f · g)) • μc = id₂ (f · g).
  Proof.
    unfold ηc, μc.
    clear ηc μc.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      rewrite !vassocr.
      apply maponpaths.
      apply maponpaths_2.
      rewrite rwhisker_hcomp.
      rewrite lunitor_V_id_is_left_unit_V_id.
      rewrite <- rinvunitor_natural.
      apply idpath.
    }
    rewrite linvunitor_assoc.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker_alt.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite <- rassociator_rassociator.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rassociator_lassociator.
        rewrite lwhisker_id2.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite !rwhisker_vcomp.
      do 5 apply maponpaths_2.
      apply maponpaths.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- inverse_pentagon_2.
      rewrite <- rwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths_2.
      apply maponpaths.
      do 2 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        do 2 apply maponpaths_2.
        apply maponpaths.
        exact (!(unit_law_2_from_distr_law α)).
      }
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite !vassocr.
      rewrite linvunitor_lunitor.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths_2.
      apply maponpaths.
      do 2 apply maponpaths.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_lwhisker.
        rewrite !vassocl.
        rewrite <- vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rinvunitor_triangle.
      rewrite rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths_2.
      apply maponpaths.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      exact (pr12 dm₁).
    }
    rewrite id2_left.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      apply idpath.
    }
    rewrite vassocr.
    rewrite rwhisker_hcomp.
    rewrite !vassocr.
    rewrite <- triangle_r_inv.
    rewrite <- lwhisker_hcomp.
    rewrite !lwhisker_vcomp.
    refine (_ @ lwhisker_id2 _ _).
    apply maponpaths.
    exact (pr12 dm₂).
  Qed.

  Definition compose_mnd_unit_right
    : (rinvunitor (f · g) • (f · g ◃ ηc)) • μc = id₂ (f · g).
  Proof.
    unfold ηc, μc.
    clear ηc μc.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      rewrite !vassocr.
      apply maponpaths.
      apply maponpaths_2.
      rewrite rwhisker_hcomp.
      rewrite lunitor_V_id_is_left_unit_V_id.
      rewrite <- rinvunitor_natural.
      apply idpath.
    }
    rewrite <- rinvunitor_triangle.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite !lwhisker_vcomp.
    rewrite !vassocl.
    rewrite vcomp_whisker.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths_2.
      do 4 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths_2.
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite rinvunitor_triangle.
      rewrite rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- left_unit_inv_assoc.
      rewrite lwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        apply (pr122 dm₂).
      }
      apply lwhisker_id2.
    }
    rewrite id2_right.
    rewrite !vassocr.
    etrans.
    {
      do 2 apply maponpaths_2.
      apply maponpaths.
      exact (!(unit_law_1_from_distr_law α)).
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker.
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lwhisker_hcomp.
    rewrite triangle_l_inv.
    rewrite <- rwhisker_hcomp.
    rewrite rwhisker_vcomp.
    refine (_ @ id2_rwhisker _ _).
    apply maponpaths.
    rewrite vassocr.
    apply (pr122 dm₁).
  Qed.

  Definition compose_mnd_assoc
    : (rassociator (f · g) (f · g) (f · g) • (f · g ◃ μc)) • μc
      =
        (μc ▹ f · g) • μc.
  Proof.
    unfold μc.
    rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
    clear ηc μc.
    rewrite !vassocl.
    etrans.
    {
      do 7 apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite lwhisker_lwhisker.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- vcomp_whisker.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      do 2 apply maponpaths.
      pose (maponpaths (λ z, lassociator _ _ _ • z) (pr222 dm₂)
             : lassociator _ _ _ • (rassociator _ _ _ • (g ◃ μ₂) • μ₂)
               =
               lassociator _ _ _ • ((μ₂ ▹ g) • μ₂)) as p.
      cbn in p.
      rewrite !vassocr in p.
      rewrite lassociator_rassociator, id2_left in p.
      exact p.
    }
    etrans.
    {
      do 12 apply maponpaths.
      rewrite vcomp_whisker.
      apply idpath.
    }
    refine (!_).
    etrans.
    {
      do 5 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_whisker.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      pose (pr222 dm₁
             : rassociator _ _ _ • (f ◃ μ₁) • μ₁
               =
               (μ₁ ▹ f) • μ₁) as p.
      cbn in p.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        exact (!p).
      }
      clear p.
      rewrite vcomp_whisker.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 11 apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      rewrite <- vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    etrans.
    {
      do 5 apply maponpaths.
      rewrite !vassocr.
      do 4 apply maponpaths_2.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      etrans.
      {
        do 3 apply maponpaths.
        exact (!(mu_law_2_from_distr_law α)).
      }
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocl.
    etrans.
    {
      do 12 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      rewrite <- vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 6 apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rwhisker_lwhisker.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rwhisker_vcomp.
      etrans.
      {
        do 3 apply maponpaths_2.
        do 2 apply maponpaths.
        exact (!(mu_law_1_from_distr_law α)).
      }
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 5 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rwhisker_rwhisker_alt.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    do 4 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 11 apply maponpaths.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_hcomp.
        rewrite inverse_pentagon_4.
        rewrite <- rwhisker_hcomp.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        rewrite !vassocl.
        rewrite rwhisker_lwhisker_rassociator.
        apply maponpaths.
        rewrite !vassocr.
        rewrite !rwhisker_vcomp.
        rewrite rassociator_rassociator.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite rassociator_rassociator.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite !vassocl.
      rewrite rassociator_lassociator.
      rewrite id2_right.
      apply idpath.
    }
    etrans.
    {
      do 10 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rwhisker_rwhisker_alt.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- rwhisker_lwhisker_rassociator.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 5 apply maponpaths.
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite lassociator_lassociator.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rwhisker_rwhisker.
      apply idpath.
    }
    etrans.
    {
      do 4 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite lwhisker_lwhisker.
        rewrite <- lwhisker_vcomp.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite lwhisker_lwhisker.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- vcomp_whisker.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      apply idpath.
    }
    do 2 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn.
    etrans.
    {
      rewrite !vassocr.
      do 5 apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- rassociator_rassociator.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite !lwhisker_vcomp.
        rewrite rassociator_rassociator.
        rewrite !vassocl.
        rewrite lwhisker_lwhisker.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        apply id2_left.
      }
      rewrite <- lwhisker_vcomp.
      apply idpath.
    }
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker_alt.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      rewrite !vassocr.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply idpath.
    }
    apply maponpaths.
    do 5 (use vcomp_move_L_pM ; [ is_iso | ]) ; cbn.
    etrans.
    {
      rewrite !vassocr.
      do 4 apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_hcomp.
        rewrite inverse_pentagon_6.
        rewrite <- lwhisker_hcomp.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      rewrite !lwhisker_vcomp.
      do 2 apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite pentagon_6.
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite <- rassociator_rassociator.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite !vassocl.
      rewrite <- !lwhisker_vcomp.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !lwhisker_vcomp.
        rewrite rassociator_lassociator.
        rewrite !lwhisker_id2.
        apply idpath.
      }
      apply id2_right.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- lwhisker_lwhisker.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lwhisker_lwhisker_rassociator.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite !lwhisker_vcomp.
    rewrite lwhisker_lwhisker_rassociator.
    rewrite !vassocl.
    refine (!_).
    rewrite rwhisker_hcomp.
    rewrite inverse_pentagon_2.
    rewrite <- lwhisker_vcomp.
    rewrite !vassocl.
    apply maponpaths.
    use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
    rewrite !vassocr.
    rewrite <- lwhisker_lwhisker.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      apply id2_left.
    }
    rewrite lassociator_rassociator.
    rewrite id2_right.
    rewrite !lwhisker_vcomp.
    apply maponpaths.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_lassociator.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite lwhisker_lwhisker.
    apply idpath.
  Qed.

  Definition compose_mnd
    : mnd B.
  Proof.
    use make_mnd.
    - use make_mnd_data.
      + exact x.
      + exact (f · g).
      + exact ηc.
      + exact μc.
    - repeat split.
      + exact compose_mnd_unit_left.
      + exact compose_mnd_unit_right.
      + exact compose_mnd_assoc.
  Defined.
End ComposeMonad.


Require Import monad.

Inductive Maybe (A:Type) : Type :=
  | Just : A -> Maybe A
  | None : Maybe A.

(* Maybe is a monad.*)
Instance Maybe_Monad : Monad Maybe := {
  bind a b i f := match i with
               | Just c => (f c)
               | None => None b
              end;

  ret a := Just a
}.

(* Proofs of the monad laws. *)
Proof.
  reflexivity.

  intros a m'.
  destruct m'; auto.

  intros a b c i f g.
  destruct i; auto.
Defined.

(* Maybe is a functor. *)
Definition Maybe_Functor := Monad_Functor Maybe Maybe_Monad.
Definition maybe_fmap {a b : Type} {F : Functor Maybe} (f:a -> b) x := fmap f x.
Check maybe_fmap.


Require Import Coq.Program.Tactics.
Require Import Coq.Program.Wf.
Require Import Arith Bool.
Program Fixpoint div2 (n:nat) {measure n}: {x:nat | n=2*x \/ n=2*x+1} :=
  match n with
  | S (S p) => S (div2 p)
  | _ => O
  end.
Fixpoint leb (n m:nat) :=
  match n with
  | O => true
  | S n' => match m with
           | O => false
           | S m' => leb n' m'
           end
  end.

Program Definition id (n:nat) : { x:nat | x=n} :=
  if (leb n 0) then 0 else S (pred n).

Definition pplus :=
fun (n m:nat) => plus n m.

Extraction Language Haskell.
Extraction "id.hs" pplus.


Require Import Coq.Logic.ProofIrrelevance.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.find_not_in.
Require Import RamifyCoq.graph.path_lemmas.

Module ind.
Section ind.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.

Variable G : PreGraph V E.

Inductive reachable: V -> V -> Prop :=
  | reachable_nil: forall x, vvalid G x -> reachable x x
  | reachable_cons: forall x y z, edge G x y -> reachable y z -> reachable x z.

Lemma reachable_trans1: forall x y z,
  reachable x y -> reachable y z -> reachable x z.
Proof.
  intros.
  induction H.
  + auto.
  + apply reachable_cons with y; auto.
Qed.

End ind.
End ind.

Module ind2.
Section ind2.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Variable G : PreGraph V E.

Inductive reachable: V -> V -> Prop :=
  | reachable_nil: forall x, vvalid G x -> reachable x x
  | reachable_cons: forall x y z, reachable x y -> edge G y z -> reachable x z.

Lemma reachable_trans: forall x y z,
  reachable x y -> reachable y z -> reachable x z.
Proof.
  intros.
  induction H0.
  + auto.
  + apply reachable_cons with y; auto.
Qed.

End ind2.
End ind2.

Section ind_reachable.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context (G : PreGraph V E).

Lemma reachable_ind_reachable: forall x y, reachable G x y <-> ind.reachable G x y.
Proof.
  intros; split; intros.
  + destruct H as [[v p] [[? ?] ?]].
    simpl in H. subst. revert x H1. induction p; intros.
    - destruct H1. simpl in *. apply ind.reachable_nil. auto.
    - pose proof (good_path_tail _ _ _ H1). unfold ptail in H. specialize (IHp _ H).
      rewrite pfoot_cons. apply ind.reachable_cons with (dst G a); auto.
      clear H. destruct H1 as [? _]. apply valid_path_edge with p; auto.
  + induction H.
    - apply reachable_refl; auto.
    - apply edge_reachable with y; auto.
Qed.

Lemma reachable_ind2_reachable: forall x y, reachable G x y <-> ind2.reachable G x y.
Proof.
  intros.
  rewrite reachable_ind_reachable.
  split; intros.
  + induction H.
    - apply ind2.reachable_nil; auto.
    - apply ind2.reachable_trans with y; auto.
      apply ind2.reachable_cons with x; auto.
      apply ind2.reachable_nil.
      destruct H; tauto.
  + induction H.
    - apply ind.reachable_nil; auto.
    - apply ind.reachable_trans1 with y; auto.
      apply ind.reachable_cons with z; auto.
      apply ind.reachable_nil.
      destruct H0; tauto.
Qed.

Lemma reachable_ind_weak: forall x y,
    reachable G x y -> x = y \/ exists z, edge G x z /\ reachable G z y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H.
  induction H.
  + left; auto.
  + destruct_eq_dec x y.
    - subst y.
      apply IHreachable.
    - right.
      exists y. rewrite reachable_ind_reachable in *; auto.
Qed.

Lemma reachable_ind: forall x y,
    reachable G x y -> x = y \/ exists z, edge G x z /\ x <> z /\ reachable G z y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H.
  induction H.
  + left; auto.
  + destruct_eq_dec x y.
    - subst y.
      apply IHreachable.
    - right.
      exists y. rewrite reachable_ind_reachable in *; auto.
Qed.

Lemma reachable_same_or_edge: forall x y, vvalid G x -> reachable G x y <-> x = y \/ exists z, edge G x z /\ x <> z /\ reachable G z y.
Proof.
  intros. split; intros.
  - apply reachable_ind; auto.
  - destruct H0.
    + subst y. apply reachable_refl. auto.
    + destruct H0 as [z [? [? ?]]]. apply edge_reachable with z; auto.
Qed.

Lemma reachable_same_or_edge': forall x y,
    vvalid G x -> reachable G x y <->
                  x = y \/ exists z, edge G x z /\ reachable G z y.
Proof.
  intros. split; intros.
  - apply reachable_ind_weak; auto.
  - destruct H0.
    + subst y. apply reachable_refl. auto.
    + destruct H0 as [z [? ?]]. apply edge_reachable with z; auto.
Qed.

Lemma reachable_ind': forall x S y, vvalid G x -> step_list G x S -> (reachable G x y <-> x = y \/ reachable_through_set G S y).
Proof.
  intros.
  unfold reachable_through_set.
  split; intros.
  + apply reachable_ind in H1.
    destruct H1; [left; auto | right].
    destruct H1 as [z ?]; exists z.
    split; [| tauto].
    rewrite (H0 z).
    destruct H1 as [[? [? ?]] ?].
    auto.
  + destruct H1 as [? | [? [? ?]]].
    - subst; apply reachable_refl; auto.
    - rewrite (H0 x0) in H1.
      apply edge_reachable with x0; auto.
      split; [| split]; auto.
      apply reachable_head_valid in H2; auto.
Qed.

Lemma step_list_step_reachable: forall root s d l, reachable G root s -> reachable G root d -> G |= s ~> d -> step_list G root l -> reachable_through_set G l d.
Proof.
  intros. rewrite (reachable_ind' _ l) in H; auto. 2: apply reachable_head_valid in H0; auto. destruct H.
  + subst s. exists d. split.
    - hnf in H2. rewrite H2. destruct H1 as [? [? ?]]. auto.
    - apply reachable_by_refl; auto. apply reachable_foot_valid in H0. auto.
  + apply reachable_through_set_step with s; auto.
    - apply reachable_foot_valid in H0; auto.
    - destruct H1 as [? [? ?]]; auto.
Qed.

Lemma closed_edge_closed_reachable: forall l,
  (forall x y, In x l -> edge G x y -> In y l) ->
  (forall x y, In x l -> reachable G x y -> In y l).
Proof.
  intros.
  rewrite reachable_ind_reachable in H1.
  induction H1.
  + auto.
  + apply IHreachable.
    apply H with x; auto.
Qed.

Lemma reachable_list_bigraph_in:
  forall {l1 l2 x} l r,
    vvalid G x ->
    reachable_list G l l1 ->
    reachable_list G r l2 ->
    (forall y, step G x y <-> y = l \/ y = r) ->
    forall y, reachable G x y <-> x = y \/ In y l1 \/ In y l2.
Proof.
  intros. specialize (H0 y). specialize (H1 y). split; intro.
  + apply reachable_ind in H3. destruct H3 as [? | [z [[? [? ?]] [? ?]]]]; auto.
    rewrite H2 in *. destruct H5.
    - subst. rewrite <- H0 in H7. auto.
    - subst. rewrite <- H1 in H7. auto.
  + destruct H3 as [? | [? | ?]].
    - subst. apply reachable_by_refl; auto.
    - rewrite H0 in H3. apply edge_reachable_by with l.
      * auto.
      * split; auto. split. apply reachable_head_valid in H3; auto. rewrite H2; auto.
      * apply H3.
    - rewrite H1 in H3. apply edge_reachable_by with r.
      * hnf; auto.
      * split; auto. split. apply reachable_head_valid in H3; auto. rewrite H2; auto.
      * apply H3.
Qed.

Lemma reachable_general_ind: forall (P: V -> Prop),
  (forall x y, edge G x y -> P x -> P y) ->
  forall x y,
  reachable G x y ->
  P x ->
  P y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H0.
  induction H0.
  + auto.
  + firstorder.
Qed.

Lemma reachable_through_general_ind: forall (P: V -> Prop),
  (forall x y, edge G x y -> P x -> P y) ->
  forall S y,
  reachable_through_set G S y ->
  Forall P S ->
  P y.
Proof.
  intros.
  destruct H0 as [x [? ?]].
  rewrite Forall_forall in H1.
  specialize (H1 _ H0).
  eapply reachable_general_ind; eauto.
Qed.

Lemma edge_preserved_rev_foot: forall (P: V -> Prop),
  (forall x y, reachable G x y -> P x -> P y) ->
  forall x y,
  reachable G x y ->
  ~ P y ->
  reachable_by G x (Complement _ P) y.
Proof.
  intros.
  rewrite reachable_ind_reachable in H0.
  induction H0.
  + apply reachable_by_refl; auto.
  + apply edge_reachable_by with y; auto.
    rewrite <- reachable_ind_reachable in H2.
    intro.
    apply (H x z) in H3; [auto |].
    apply edge_reachable with y; auto.
Qed.

Lemma edge_preserved_rev_foot0: forall (P: V -> Prop),
  (forall x y, reachable G x y -> P x -> P y) ->
  forall l y,
  reachable_through_set G l y ->
  ~ P y ->
  reachable_by_through_set G l (Complement _ P) y.
Proof.
  intros.
  destruct H0 as [s [? ?]]; exists s; split; auto.
  apply edge_preserved_rev_foot; auto.
Qed.

End ind_reachable.

Section EQUIV.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.

Lemma edge_equiv_reachable_equiv: forall (g1 g2: PreGraph V E),
  (forall x, vvalid g1 x <-> vvalid g2 x) ->
  (forall x y, edge g1 x y <-> edge g2 x y) -> forall n, Same_set (reachable g1 n) (reachable g2 n).
Proof.
  cut (forall (g1 g2 : PreGraph V E), (forall x, vvalid g1 x <-> vvalid g2 x) -> (forall x y, edge g1 x y <-> edge g2 x y) -> forall n, Included (reachable g1 n) (reachable g2 n)).
  1: intros; split; intros; apply H; [auto | auto | symmetry; auto | symmetry; auto].
  intros; intro; intros.
  unfold Ensembles.In in *.
  rewrite @reachable_ind_reachable in *.
  induction H1.
  + constructor. rewrite H in H1; auto.
  + rewrite H0 in H1.
    apply ind.reachable_cons with y; auto.
Qed.

Lemma si_reachable: forall (g1 g2: PreGraph V E) n,  g1 ~=~ g2 -> Same_set (reachable g1 n) (reachable g2 n).
Proof.
  intros.
  apply edge_equiv_reachable_equiv.
  + destruct H; auto.
  + intros; apply edge_si.
    auto.
Qed.

Lemma si_reachable_direct: forall (g1 g2: PreGraph V E) x y,  g1 ~=~ g2 -> (reachable g1 x y <-> reachable g2 x y).
Proof.
  intros. apply (si_reachable _ _ x) in H. destruct H. split; intros.
  + apply (H y); auto.
  + apply (H0 y); auto.
Qed.

Lemma si_eq_as_set_reachable_through_set: forall (g1 g2: PreGraph V E) S1 S2 n, g1 ~=~ g2 -> eq_as_set S1 S2 -> (reachable_through_set g1 S1 n <-> reachable_through_set g2 S2 n).
Proof.
  cut (forall (g1 g2 : PreGraph V E) S1 S2 (n : V), g1 ~=~ g2 -> eq_as_set S1 S2 ->
         (reachable_through_set g1 S1 n -> reachable_through_set g2 S2 n)).
  1: intros; split; apply H; [| | symmetry | symmetry]; auto.
  intros.
  intros.
  unfold reachable_through_set in *.
  destruct H1 as [s [? ?]].
  exists s; split.
  + pose proof proj1 H0 s.
    auto.
  + destruct (si_reachable g1 g2 s H).
    apply H3; auto.
Qed.

Lemma si_reachable_through_set: forall (g1 g2: PreGraph V E) S n, g1 ~=~ g2 -> (reachable_through_set g1 S n <-> reachable_through_set g2 S n).
Proof.
  intros.
  apply si_eq_as_set_reachable_through_set; auto.
  reflexivity.
Qed.

Instance reachable_proper: Proper (structurally_identical ==> (@eq V) ==> (@eq V) ==> iff) reachable.
Proof.
  do 3 (hnf; intros); subst.
  apply si_reachable_direct.
  auto.
Defined.

Instance reachable_proper': Proper (structurally_identical ==> (@eq V) ==> Same_set) reachable.
Proof.
  do 2 (hnf; intros); subst.
  rewrite Same_set_spec in *.
  hnf; intros.
  apply si_reachable_direct.
  auto.
Defined.

Instance reachable_through_set_proper: Proper (structurally_identical ==> eq_as_set ==> (@eq V) ==> iff) reachable_through_set.
Proof.
  do 3 (hnf; intros); subst.
  apply si_eq_as_set_reachable_through_set; auto.
Defined.

Instance reachable_through_set_proper': Proper (structurally_identical ==> eq_as_set ==> @Same_set V) reachable_through_set.
Proof.
  do 2 (hnf; intros); subst.
  rewrite Same_set_spec in *.
  hnf; intros.
  apply si_eq_as_set_reachable_through_set; auto.
Defined.

End EQUIV.

Global Existing Instances reachable_proper reachable_proper' reachable_through_set_proper reachable_through_set_proper'.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B D C : Universe, ((wd_ A B /\ (wd_ A D /\ (col_ A B D /\ col_ D C A))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import HoTT.
From HoTT.Categories Require Import
     Category Functor NaturalTransformation FunctorCategory.
From GR.bicategories Require Import
     general_category
     bicategory.bicategory
     bicategory.locally_strict
     bicategory.strict
     adjoint
     adjoint_unique.
From GR.bicategories.bicategory.examples Require Import
     precat full_sub.

Definition StrictCat `{Funext} : BiCategory
  := full_sub PreCat (fun C => BuildhProp (IsStrictCategory C)).

Global Instance LocallyStrict_strict_cat `{Funext}
  : LocallyStrict StrictCat.
Proof.
  intros [C SC] [Y SY].
  apply _.
Qed.

Definition IsStrict_StrictCat `{Funext} : IsStrict StrictCat
  := full_sub_strict _ _ StrictPreCat.

Global Instance is_2category_StrictCat
       `{Funext}
  : is_2category StrictCat.
Proof.
  split.
  - apply _.
  - apply IsStrict_StrictCat.
Defined.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal57.

From lfind Require Import LFind.
Lemma lfind_state  (u:natural) (v:natural) (w:natural) (x:natural) (y:natural) (z:lst):@eq lst (drop u (drop v (drop (Succ (Succ w)) (Cons x (Cons y z)))))
  (drop u (drop (Succ v) (drop w (Cons x z)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal57_theorem0_38_lem/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (u:natural) (v:natural) (w:natural) (x:natural) (y:natural) (z:lst) :=
 let lfind_var := "u:" ++ "(" ++ show u ++ ")"++ "|" ++"v:" ++ "(" ++ show v ++ ")"++ "|" ++"w:" ++ "(" ++ show w ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print u lfind_var
 in lfind_state lfind_v  v w x y z.
QuickChick collect_data.
Success.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
induction l1.
- intros. simpl. rewrite <- IHl1. reflexivity.
- intros. reflexivity.
Qed.

Lemma lem: forall l1 l2, len (append l1 l2) = len (append l2 l1).
Proof. induction l1.
  - intros. simpl. rewrite IHl1. rewrite <- lem2. reflexivity.
  - intros. simpl. rewrite lem3. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (half (len (append x y))) (half (len (append y x))).
Proof.
intros. f_equal. lfind. Admitted.