Definition polymorphic_identity (T : Type) (x : T) : T :=
  x.

Definition polymorphic_uncurry (T1 T2 T3 : Type) (f: T1 -> T2 -> T3) (p: T1 * T2) : T3 :=
  match p with
  | (x1, x2) =>
    f x1 x2
  end.

Definition polymorphic_uncurry' (T1 T2 T3 : Type) (f: T1 -> T2 -> T3) :=
  fun (p: T1 * T2) =>
    match p with
    | (x1, x2) =>
      f x1 x2
    end.

Definition polymorphic_uncurry'' :=
  fun (T1 T2 T3 : Type)
      (f: T1 -> T2 -> T3)
      (p: T1 * T2) =>
    match p with
    | (x1, x2) =>
      f x1 x2
    end.

Proposition uncurry :
  forall (T1 T2 T3 : Prop),
    (T1 -> T2 -> T3) ->
    (T1 /\ T2) ->
    T3.
Proof.
  intros T1 T2 T3 f p.
  destruct p as [x1 x2].
  exact (f x1 x2).
  Show Proof.
  Qed.

Definition polymorphic_curry (T1 T2 T3 : Type) (f: T1 * T2 -> T3) :=
  fun x1 => fun x2 => f (x1, x2).

Definition apply (T1 T2 : Type) (f : T1 -> T2) (x : T1) :=
  f x.

(**********)

Proposition modus_ponens :
  forall (A B : Prop),
    (A -> B) -> A -> B.
Proof.
  intros A B H_A_implies_B H_A.
  apply H_A_implies_B.
  exact H_A.

  Restart.
  intros A B H_A_implies_B H_A.
  exact (H_A_implies_B H_A).
  Show Proof.(*(fun (A B : Prop) (H_A_implies_B : A -> B) (H_A : A) => H_A_implies_B H_A)*)
Qed.

Proposition modus_ponens' :
  forall (A B : Prop),
    (A -> B) -> A -> B.
Proof.
  intros A B f a.
  apply f.
  exact a.
  Show Proof.
  (*
    (fun (A B : Prop) (f : A -> B) (a : A) => f a)
   *)
  Restart.
  intros A B f a.
  apply f in a.
  exact a.
  Show Proof.
  (*
    (fun (A B : Prop) (f : A -> B) (a : A) => let a0 := f a : B in a0)
*)
Qed.

Proposition trivial :
  forall (A : Prop),
    A -> A.
Proof.
  intros A H_A.
  exact H_A.
  Show Proof.
  Restart.
  intros T x.
  exact x.
  Show Proof.
  Proof fun (A : Prop) (a : A) => a.

Proposition foo :
  forall A B C : Prop,
    (A -> B) -> (B -> C) -> A -> C /\ C.
Proof.
  intros A B C f g a.
  split.
    apply g; apply f; apply a.
  apply g; apply f; apply a.
  Show Proof.
  (*
    (fun (A B C : Prop) (f : A -> B) (g : B -> C) (a : A) => conj (g (f a)) (g (f a)))
   *)

  Restart.
  intros A B C f g a.
  assert (x := a).
  apply f in x.
  apply g in x.
  split; exact x.
  Show Proof.
  (*
(fun (A B C : Prop) (f : A -> B) (g : B -> C) (a : A) =>
 let x := a : A in let x0 := f x : B in let x1 := g x0 : C in conj x1 x1)
   *)

Lemma baz :
  forall n : nat,
  exists m : nat,
    m = S n.
Proof.
  intro n.
  exists (S n).
  reflexivity.
Show Proof.
Qed.

Lemma baz' :
  forall n : nat,
  exists m : nat,
    n < m.
Proof.
  intro n.
  exists (S n).
  Show Proof.


Require Import TM.Prelim.
Require Import TM.Basic.Mono.
Require Import TM.Combinators.Combinators.
Require Import TM.Compound.TMTac TM.Compound.Multi.
Require Import TM.Lifting.LiftTapes.

Require Import FunInd.
Require Import Recdef.

(** * Copy Symbols from t0 to t1 *)

(** This two-tape Turing machine copies the symbols from tape 0 to tape 1, until it reads a symbol x on tape 0 such that f(x)=true. This machine is similar to MoveToSymbol, with the only difference, that it copies the read symbols to another tape (without translating it). *)

Section CopySymbols.

  Variable sig : finType.
  (** Termination check *)
  Variable f : sig -> bool.

  Definition CopySymbols_Step : pTM sig (option unit) 2 :=
    Switch (ReadChar_at Fin0)
          (fun b : option sig =>
             match b with
             | Some x =>
               (* First write the read symbol to tape 1 *)
               if f x
               then (* found the symbol: write it to tape 1; break and return *)
                 Return (LiftTapes (Write x) [|Fin1|]) (Some tt)
               else (* wrong symbol: write it to tape 1 and move both tapes right and continue *)
                 Return (LiftTapes (Write x) [|Fin1|];;
                         MovePar R R) (None)
             | _ => Return Nop (Some tt) (* there is no such symbol, break and return *)
             end).

  Definition CopySymbols_Step_Rel : pRel sig (option unit) 2 :=
    fun tin '(yout, tout) =>
      match current tin[@Fin0] with
      | Some x =>
        if (f x)
        then tout[@Fin0] = tin[@Fin0] /\
             tout[@Fin1] = tape_write tin[@Fin1] (Some x) /\
             yout = Some tt (* break *)
        else tout[@Fin0] = tape_move_right tin[@Fin0] /\
             tout[@Fin1] = doAct tin[@Fin1] (Some x, R) /\
             yout = None (* continue *)
      | _ => tout = tin /\
            yout = Some tt
      end.

  Lemma CopySymbols_Step_Sem :
    CopySymbols_Step ⊨c(7) CopySymbols_Step_Rel.
  Proof.
    eapply RealiseIn_monotone.
    {
      unfold CopySymbols_Step. eapply Switch_RealiseIn. cbn. eapply LiftTapes_RealiseIn; [vector_dupfree| eapply ReadChar_Sem].
      instantiate (2 := fun o : option sig => match o with Some x => if f x then _ else _ | None => _ end).
      intros [ | ]; cbn.
      - destruct (f e); swap 1 2.
        + apply Return_RealiseIn. eapply Seq_RealiseIn. eapply LiftTapes_RealiseIn; [vector_dupfree | eapply Write_Sem]. eapply MovePar_Sem.
        + apply Return_RealiseIn, LiftTapes_RealiseIn; [vector_dupfree | eapply Write_Sem].
      - cbn. eapply RealiseIn_monotone'. apply Return_RealiseIn. eapply Nop_Sem. omega.
    }
    { cbn. reflexivity. }
    {
      intros tin (yout, tout) H. TMCrush destruct_tapes; TMSolve 6.
    }
  Qed.

  (*
   * The main loop of the machine.
   * Execute CopySymbols_Step in a loop until CopySymbols_Step returned [Some tt]
   *)
  Definition CopySymbols : pTM sig unit 2 := While CopySymbols_Step.

  Definition rlength (t : tape sig) := length (tape_local t).

  Definition rlength' (tin : tape sig * tape sig) : nat := rlength (fst tin).

  (* Function of CopySymbols *)
  Function CopySymbols_Fun (tin : tape sig * tape sig) { measure rlength' tin } : tape sig * tape sig :=
    match current (fst tin) with
    | Some s =>
      if f s
      then (fst tin, tape_write (snd tin) (Some s))
      else CopySymbols_Fun (tape_move_right (fst tin), doAct (snd tin) (Some s, R))
    | _ => tin
    end.
  Proof.
    intros (t1,t2) m HC Hs. unfold rlength', rlength. cbn.
    destruct t1; cbn in *; inv HC. simpl_tape. omega.
  Qed.

  Definition CopySymbols_Rel : Rel (tapes sig 2) (unit * tapes sig 2) :=
    ignoreParam (fun tin tout => (tout[@Fin0], tout[@Fin1]) = CopySymbols_Fun (tin[@Fin0], tin[@Fin1])).

  Lemma CopySymbols_false s t1 t2 :
    current t1 = Some s ->
    f s = false ->
    CopySymbols_Fun (t1, t2) = CopySymbols_Fun (tape_move_right t1, doAct t2 (Some s, R)).
  Proof. intros HCurrent Hs. rewrite CopySymbols_Fun_equation. cbn. now rewrite HCurrent, Hs. Qed.

  Lemma CopySymbols_true s t1 t2 :
    current t1 = Some s ->
    f s = true ->
    CopySymbols_Fun (t1,t2) = (t1, tape_write t2 (Some s)).
  Proof. intros HCurrent Hs. rewrite CopySymbols_Fun_equation. cbn. now rewrite HCurrent, Hs. Qed.

  Lemma tape_destruct2 (t : tapes sig 2) t1 t2 :
    t[@Fin0] = t1 ->
    t[@Fin1] = t2 ->
    t = [|t1; t2|].
  Proof. intros <- <-. now destruct_tapes. Qed.

  Lemma tape_destruct2' (t : tapes sig 2) t1 t2 :
    t = [|t1; t2|] ->
    t[@Fin0] = t1 /\
    t[@Fin1] = t2.
  Proof. destruct_tapes; now intros (-> & (-> & _) % Vector.cons_inj) % Vector.cons_inj. Qed.

  Lemma CopySymbols_Realise :
    CopySymbols ⊨ CopySymbols_Rel.
  Proof.
    eapply Realise_monotone.
    {
      unfold CopySymbols. eapply While_Realise. eapply RealiseIn_Realise. eapply CopySymbols_Step_Sem.
    }
    {
      apply WhileInduction; intros; TMSimp.
      - destruct (current tin[@Fin0]) eqn:E.
        + destruct (f e) eqn:Ef; TMSimp. erewrite CopySymbols_true; eauto. f_equal.
        + destruct HLastStep as (->&_). rewrite CopySymbols_Fun_equation. cbn. now rewrite E.
      - destruct (current tin[@Fin0]) eqn:E.
        + destruct (f e) eqn:Ef; TMSimp. symmetry. erewrite CopySymbols_false; eauto. cbn. auto.
        + destruct HStar as (->&_). rewrite CopySymbols_Fun_equation. cbn. now rewrite E.
    }
  Qed.

  (** Termination *)

  Function CopySymbols_steps (t : tape sig) { measure rlength t } : nat :=
    match current t with
    | Some m => if f m then 8 else 8 + CopySymbols_steps (tape_move_right t)
    | _ => 8
    end.
  Proof.
    intros tin m HC Hs. unfold rlength', rlength. cbn.
    destruct tin; cbn in *; inv HC. simpl_tape. omega.
  Qed.

  Lemma CopySymbols_Terminates :
    projT1 CopySymbols ↓ (fun tin k => CopySymbols_steps (tin[@Fin0]) <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold CopySymbols. TM_Correct.
      1-2: eapply Realise_total; eapply CopySymbols_Step_Sem.
    }
    {
      apply WhileCoInduction; intros. exists 7. repeat split.
      - reflexivity.
      - intros ymid tmid H. cbn in *. destruct ymid as [()| ]; cbn in *.
        + destruct (current tin[@Fin0]) eqn:E; TMSimp.
          * destruct (f e) eqn:Ef; TMSimp. rewrite CopySymbols_steps_equation, E, Ef in HT. omega.
          * rewrite CopySymbols_steps_equation, E in HT. omega.
        + destruct (current tin[@Fin0]) eqn:E; TMSimp. destruct (f e) eqn:Ef; TMSimp.
          rewrite CopySymbols_steps_equation, E, Ef in HT.
          exists (CopySymbols_steps (tape_move_right tin[@Fin0])). split; auto.
    }
  Qed.

  (** Move to left *)

  Definition CopySymbols_L := Mirror CopySymbols.

  Definition llength (t : tape sig) := length (tape_local_l t).

  Definition llength' (tin : tape sig * tape sig) : nat := llength (fst tin).

  Function CopySymbols_L_Fun (tin : tape sig * tape sig) { measure llength' tin } : tape sig * tape sig :=
    match current (fst tin) with
    | Some s =>
      if f s
      then (fst tin, tape_write (snd tin) (Some s))
      else CopySymbols_L_Fun (tape_move_left (fst tin), doAct (snd tin) (Some s, L))
    | _ => tin
    end.
  Proof.
    intros (t1,t2) m HC Hs. unfold llength', llength. cbn.
    destruct t1; cbn in *; inv HC. simpl_tape. omega.
  Qed.

  Lemma CopySymbols_mirror t t1' t2' :
    CopySymbols_Fun (mirror_tape (fst t), mirror_tape (snd t)) = (mirror_tape t1', mirror_tape t2') ->
    CopySymbols_L_Fun t = (t1', t2').
  Proof.
    functional induction CopySymbols_L_Fun t; intros H; cbn in *; try reflexivity;
      rewrite CopySymbols_Fun_equation in H; cbn in *; auto.
    - simpl_tape in *. rewrite e, e0 in H. cbn in *.
      symmetry in H; inv H.
      apply mirror_tape_injective in H1.
      apply mirror_tape_inv_midtape in H2.
      cbn in *. simpl_tape in *. f_equal; eauto.
    - simpl_tape in *. rewrite e, e0 in H. cbn in *. apply IHp. rewrite <- H. f_equal. unfold mirror_tapes. cbn.
      do 2 (f_equal; simpl_tape; auto).
    - simpl_tape in H. destruct (current (fst tin)) eqn:E; auto. inv H. simpl_tape in *.
      apply mirror_tape_injective in H1 as <-. apply mirror_tape_injective in H2 as <-. now destruct tin.
  Qed.

  Lemma CopySymbols_mirror' t t1' t2' :
    CopySymbols_L_Fun (mirror_tape (fst t), mirror_tape (snd t)) = (mirror_tape t1', mirror_tape t2') ->
    CopySymbols_Fun t = (t1', t2').
  Proof.
    functional induction CopySymbols_Fun t; intros H; cbn in *; try reflexivity;
      rewrite CopySymbols_L_Fun_equation in H; cbn in *; auto.
    - simpl_tape in *. rewrite e, e0 in H. cbn in *.
      symmetry in H; inv H.
      apply mirror_tape_injective in H1.
      apply mirror_tape_inv_midtape in H2.
      cbn in *. simpl_tape in *. f_equal; eauto.
    - simpl_tape in *. rewrite e, e0 in H. cbn in *. apply IHp. rewrite <- H. f_equal. unfold mirror_tapes. cbn.
      do 2 (f_equal; simpl_tape; auto).
    - simpl_tape in H. destruct (current (fst tin)) eqn:E; auto. inv H. simpl_tape in *.
      apply mirror_tape_injective in H1 as <-. apply mirror_tape_injective in H2 as <-. now destruct tin.
  Qed.

  Definition CopySymbols_L_Rel : Rel (tapes sig 2) (unit * tapes sig 2) :=
    ignoreParam (fun tin tout => (tout[@Fin0], tout[@Fin1]) = CopySymbols_L_Fun (tin[@Fin0], tin[@Fin1])).

  Lemma CopySymbols_L_Realise : CopySymbols_L ⊨ CopySymbols_L_Rel.
  Proof.
    eapply Realise_monotone.
    { eapply Mirror_Realise. eapply CopySymbols_Realise. }
    { intros tin ((), tout) H. cbn in *.
      symmetry in H; symmetry. simpl_tape in H.
      apply CopySymbols_mirror; eauto.
    }
  Qed.

  Function CopySymbols_L_steps (t : tape sig) { measure llength t } : nat :=
    match current t with
    | Some s => if f s then 8 else 8 + CopySymbols_L_steps (tape_move_left t)
    | _ => 8
    end.
  Proof.
    intros tin m HC Hs. unfold llength', llength. cbn.
    destruct tin; cbn in *; inv HC. simpl_tape. omega.
  Qed.

  Lemma CopySymbols_steps_mirror t :
    CopySymbols_L_steps t = CopySymbols_steps (mirror_tape t).
  Proof.
    functional induction CopySymbols_L_steps t; cbn; auto;
      simpl_tape in *; cbn in *;
        rewrite CopySymbols_steps_equation; simpl_tape.
    - now rewrite e, e0.
    - rewrite e, e0. omega.
    - destruct (current t); cbn; auto.
  Qed.

  Lemma CopySymbols_L_Terminates :
    projT1 CopySymbols_L ↓ (fun tin k => CopySymbols_L_steps (tin[@Fin0]) <= k).
  Proof.
    eapply TerminatesIn_monotone.
    - eapply Mirror_Terminates. eapply CopySymbols_Terminates.
    - cbn. intros tin k Hk. destruct_tapes; cbn. rewrite <- Hk. unfold mirror_tapes.
      rewrite CopySymbols_steps_mirror. cbn. auto.
  Qed.

End CopySymbols.

Ltac smpl_TM_CopySymbols :=
  lazymatch goal with
  | [ |- CopySymbols _ ⊨ _ ] => eapply CopySymbols_Realise
  | [ |- projT1 (CopySymbols _) ↓ _ ] => eapply CopySymbols_Terminates
  | [ |- CopySymbols_L _ ⊨ _ ] => eapply CopySymbols_L_Realise
  | [ |- projT1 (CopySymbols_L _) ↓ _ ] => eapply CopySymbols_L_Terminates
  end.

Smpl Add smpl_TM_CopySymbols : TM_Correct.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
Set Implicit Arguments.

Require Import List.
Require Import fcf.Fold.

Section In_gen.
  Variable A : Type.
  Variable ea : A -> A -> Prop.

  Hypothesis ea_symm :
    forall a1 a2, ea a1 a2 -> ea a2 a1.

  Hypothesis ea_trans :
    forall a1 a2 a3,
      ea a1 a2 ->
      ea a2 a3 ->
      ea a1 a3.

  Fixpoint In_gen(a : A)(ls : list A) : Prop :=
    match ls with
      | nil => False
      | a' :: ls' =>
        ea a a' \/ In_gen a ls'
    end.

  Theorem In_gen_equiv_compat :
    forall (ls : list A)(a1 a2 : A),
      ea a1 a2 ->
      In_gen a1 ls ->
      In_gen a2 ls.

    induction ls; intuition; simpl in *.
    intuition.
    left.
    eapply ea_trans.
    eapply ea_symm.
    eauto.
    trivial.

    right.
    eauto.

  Qed.

End In_gen.

Theorem In_gen_eq :
  forall (A : Type)(a : A)(ls : list A),
    In a ls <-> In_gen eq a ls.

  induction ls; intuition; simpl in *.
  intuition.
  intuition.

Qed.

Section NoDup_gen.

  Variable A : Type.
  Variable ea : A -> A -> Prop.

  Inductive NoDup_gen : list A -> Prop :=
  | NoDup_gen_nil : NoDup_gen nil
  | NoDup_gen_cons :
      forall (a : A)(ls : list A),
        (~In_gen ea a ls) ->
        NoDup_gen ls ->
        NoDup_gen (a :: ls).

End NoDup_gen.

Theorem NoDup_gen_eq :
  forall (A : Type)(ls : list A),
    NoDup ls <-> NoDup_gen eq ls.

  induction ls; intuition; simpl in *.
  econstructor.
  econstructor.

  inversion H1; clear H1; subst.
  econstructor.
  intuition.
  eapply H4.
  eapply  In_gen_eq.
  trivial.
  intuition.

  inversion H1; clear H1; subst.
  econstructor.
  intuition.
  eapply H4.
  eapply In_gen_eq.
  trivial.
  intuition.

Qed.

Section NoDup_gen_map.

  Variable A B : Type.
  Variable ea : A -> A -> Prop.
  Variable eb : B -> B -> Prop.
  Variable f : A -> B.

  Hypothesis ea_symm :
    forall a1 a2,
      ea a1 a2 -> ea a2 a1.

  Hypothesis ea_trans :
    forall a1 a2 a3,
      ea a1 a2 ->
      ea a2 a3 ->
      ea a1 a3.

  Hypothesis ea_func :
    forall a1 a2, ea a1 a2 -> eb (f a1) (f a2).

  Hypothesis eb_symm :
    forall b1 b2,
      eb b1 b2 -> eb b2 b1.

  Hypothesis eb_trans :
    forall b1 b2 b3,
      eb b1 b2 ->
      eb b2 b3 ->
      eb b1 b3.

  Hypothesis ea_refl :
    forall a y,
      eb (f a) y ->
      ea a a .

  Hypothesis eb_func :
    forall a1 a2,
      eb (f a1) (f a2) -> ea a1 a2.

  Theorem In_gen_map_iff
  : forall (l : list A) (y : B),
      (In_gen eb y (map f l) <-> (exists x : A, eb (f x) y /\ In_gen ea x l)).

    induction l; intuition; simpl in *.
    intuition.
    destruct H.
    intuition.
    intuition.
    econstructor.
    intuition.
    eapply eb_symm.
    eauto.

    left.
    eapply ea_refl.
    eapply eb_symm.
    eauto.

    specialize (IHl y).
    intuition.
    destruct H2.
    intuition.
    econstructor.
    split.
    eauto.
    intuition.

    destruct H.
    intuition.
    left.
    eapply eb_trans.
    eapply eb_symm.
    eauto.
    eapply ea_func.
    trivial.

    right.
    specialize (IHl y).
    intuition.
    eapply H2.
    econstructor.
    intuition.
    eauto.
    trivial.
  Qed.

  Theorem map_NoDup_gen :
    forall (ls : list A),
      NoDup_gen ea ls ->
      NoDup_gen eb (map f ls).

    induction ls; intuition; simpl in *.
    econstructor.

    inversion H; clear H; subst.
    econstructor.
    intuition.
    eapply H2.
    eapply In_gen_map_iff in H.
    destruct H.
    intuition.
    eapply In_gen_equiv_compat; [ eauto | eauto | idtac | idtac].
    eapply eb_func.
    eauto.
    trivial.

    eauto.

  Qed.

End NoDup_gen_map.

Require Import fcf.RepeatCore.

Lemma flatten_NoDup_gen :
  forall (A : Set)(ls : list (list A)),
    NoDup_gen (fun a b => a <> nil /\ a = b) ls ->
    (forall x, In x ls -> NoDup x) ->
    (forall x1 x2, In x1 ls -> In x2 ls -> x1 <> x2 -> NoDup (x1 ++ x2)) ->
    NoDup (flatten ls).

  induction ls; intuition; simpl in *.
  econstructor.

  inversion H; clear H; subst.
  eapply app_NoDup; intuition.

  eapply in_flatten in H3.
  destruct H3.
  intuition.
  eapply app_NoDup_inv.
  eapply H1.
  right.
  eapply H6.
  left.
  reflexivity.
  intuition.
  subst.

  Theorem In_gen_weaken :
    forall (A : Type)(e1 e2 : A -> A -> Prop) ls a,
      In_gen e1 a ls ->
      (forall a', e1 a a' -> e2 a a') ->
      In_gen e2 a ls.

    induction ls; intuition; simpl in *.
    intuition.

  Qed.

  eapply H4.
  eapply In_gen_weaken.
  eapply In_gen_eq.
  trivial.
  intuition.
  subst.
  subst.
  simpl in *.
  intuition.
  eauto.
  eauto.

  eapply in_flatten in H2.
  destruct H2.
  intuition.
  eapply app_NoDup_inv.
  eapply H1.
  right.
  eapply H6.
  left.
  reflexivity.
  intuition.
  subst.
  eapply H4.
  eapply In_gen_weaken.
  eapply In_gen_eq.
  trivial.
  intuition.
  subst.
  subst.
  simpl in *.
  intuition.
  eauto.
  eauto.

Qed.

Theorem NoDup_gen_weaken :
  forall (A : Type)(e1 e2 : A -> A -> Prop) ls,
    NoDup_gen e1 ls ->
    (forall a1 a2, e2 a1 a2 -> e1 a1 a2) ->
    NoDup_gen e2 ls.

  induction ls; intuition; simpl in *.
  econstructor.

  inversion H; clear H; subst.
  econstructor.
  intuition.
  eapply H3.
  eapply In_gen_weaken; eauto.

  eauto.

Qed.

Theorem In_gen_zip_fst :
  forall (A B : Set)(ea : A -> A -> Prop)(lsa : list A)(lsb : list B) a b,
    In_gen (fun a b => ea (fst a) (fst b)) (a, b) (zip lsa lsb) ->
    In_gen ea a lsa.

  induction lsa; intuition; simpl in *.
  destruct lsb;
    simpl in *;
    intuition.

  right.
  eauto.
Qed.

Theorem NoDup_gen_zip_fst :
  forall (A B : Set)(ea : A -> A -> Prop)(lsa : list A)(lsb : list B),
    NoDup_gen ea lsa ->
    NoDup_gen (fun a b => ea (fst a) (fst b)) (zip lsa lsb).

  induction lsa; intuition; simpl in *.
  econstructor.

  inversion H; clear H; subst.
  destruct lsb; intuition; simpl in *.
  econstructor.

  econstructor.
  intuition.
  eapply H2.
  eapply In_gen_zip_fst.
  eauto.
  eauto.

Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import Cat.Cat.
From Categories Require Import NatTrans.NatTrans.

Local Open Scope nattrans_scope.

(** The opposite of a natural transformation N : F -> F' is a nattrans
    N^op : F'^op -> F^op. It has the same arrow family as the original
    natural transformation. *)
Section Opposite_NatTrans.
  Context {C D : Category} {F F' : (C –≻ D)%functor} (N : (F –≻ F')%nattrans).

  Program Definition Opposite_NatTrans : F'^op –≻ F^op :=
    {|
      Trans := Trans N;
      Trans_com := fun c c' h => (Trans_com_sym N h);
      Trans_com_sym := fun c c' h => (Trans_com N h)
    |}.

End Opposite_NatTrans.

Notation "N '^op'" := (Opposite_NatTrans N) : nattrans_scope.

(** Composition of opposite natural transformations is just the same as the
    opposite natural transformation of the composition. *)
Section Compose_NOP.
  Context {C D : Category} {F F' F'' : (C –≻ D)%functor}
          (N : F –≻ F') (N' : F' –≻ F'').

  Theorem NatTrans_compose_Op : ((N' ∘ N)^op = N^op ∘ (N'^op))%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    trivial.
  Qed.

End Compose_NOP.

(** Opposite of NatTrans_id is just NatTrans_id of the opposite functor *)
Section NatTrans_id_Op.
  Context {C D : Category} (F : (C –≻ D)%functor).

  Theorem NatTrans_id_Op
    : ((NatTrans_id F)^op)%nattrans = NatTrans_id (F^op)%functor.
  Proof.
    apply NatTrans_eq_simplify.
    trivial.
  Qed.

End NatTrans_id_Op.

(** Horizontal composition of natural transformations:

Let C, D and E be categories, F: C -> D G : C -> D, F' : D -> E and
G' : D -> E be functors and N : F -> G and N' : F' -> G' be natural
transformations. Then, the horizontal composition of N and N',
denoted by N ∘_h N' : F' ∘ F -> G' ∘ G is defined as follows:
 *)
Program Definition NatTrans_hor_comp {C D E : Category} {F G : (C –≻ D)%functor}
        {F' G' : (D –≻ E)%functor} (tr : F –≻ G) (tr' : F' –≻ G')
  : (F' ∘ F) –≻ (G' ∘ G) :=
{|
  Trans := fun c : Obj => ((G' _a (Trans tr c)) ∘ (Trans tr' (F _o c)))%morphism
|}.

Next Obligation. (* Trans_com*)
Proof.
  rewrite assoc.
  rewrite Trans_com.
  rewrite assoc_sym.
  rewrite <- F_compose.
  rewrite Trans_com.
  rewrite F_compose.
  auto.
Qed.

Next Obligation. (* Trans_com*)
Proof.
  symmetry.
  apply NatTrans_hor_comp_obligation_1.
Qed.

(**
Graphically:
#

    C      C             C              C
    |  N   |             |              |
  F | ===> | G           |              |
    |      |             |              |
    ∨      ∨             |   N' ∘_h N   |
    D      D        F'∘F | ===========> |G'∘G
    |  N'  |             |              |
 F' | ===> | G'          |              |
    |      |             |              |
    ∨      ∨             ∨              ∨
    E      E             E              E

#
*)

Notation "N ∘_h N'" := (NatTrans_hor_comp N' N) : nattrans_scope.

(** Horizontal composition of NatTrans_ids is just the NatTrans_id of
    the composition of underlying functors. *)
Section Hor_Compose_ids.
  Context {C D E : Category} (F : (C –≻ D)%functor) (G : (D –≻ E)%functor).

  Theorem NatTrans_hor_comp_ids
    : ((NatTrans_id G) ∘_h (NatTrans_id F))%nattrans = NatTrans_id  (G ∘ F).
  Proof.
    apply NatTrans_eq_simplify.
    cbn.
    extensionality c.
    rewrite F_id; simpl_ids; trivial.
  Qed.

End Hor_Compose_ids.

(** Horizontal composition of opposite of two natural transformations is just
    the opposite of the horizontal composition of those two natural
    transformations. *)
Section Hor_Compose_NOP.
  Context {C D E : Category} {F G : (C –≻ D)%functor} {F' G' : (D –≻ E)%functor}
          (N : F –≻ G) (N' : F' –≻ G').

  Theorem NatTrans_hor_comp_Op : ((N' ∘_h N)^op = N'^op ∘_h N^op)%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    cbn.
    extensionality c.
    rewrite Trans_com.
    trivial.
  Qed.

End Hor_Compose_NOP.

Section NatTransCompID.
  Context {C D : Category} (F : (C –≻ D)%functor).

  (** Natural transformation from a functor to itself composed with id on
      the right. *)
  Program Definition NatTrans_to_compose_id : F –≻ ((Functor_id D) ∘ F) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation to a functor from itself composed with id on
      the right. *)
  Program Definition NatTrans_from_compose_id : ((Functor_id _) ∘ F) –≻ F :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation from a functor to itself composed with id on
      the left. *)
  Program Definition NatTrans_to_id_compose : F –≻ (F ∘ (Functor_id _)) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation to a functor from itself composed with id on
      the left. *)
  Program Definition NatTrans_from_id_compose : (F ∘ (Functor_id _)) –≻ F :=
    {|
      Trans := fun c => id
    |}.

End NatTransCompID.

Section NatTransAssoc.
  Context {C1 C2 C3 C4 : Category}
          (F : (C1 –≻ C2)%functor)
          (G : (C2 –≻ C3)%functor)
          (H : (C3 –≻ C4)%functor)
  .

  (** Natural transformation corresponding to associativity of
      functor composition *)
  Program Definition NatTrans_Functor_assoc
    : ((H ∘ G) ∘ F) –≻ (H ∘ (G ∘ F)) :=
    {|
      Trans := fun c => id
    |}.

  (** Natural transformation corresponding to the symmetric form of
      associativity of functor composition *)
  Program Definition NatTrans_Functor_assoc_sym
    : (H ∘ (G ∘ F)) –≻ ((H ∘ G) ∘ F) :=
    {|
      Trans := fun c => id
    |}.

End NatTransAssoc.

(**
The following theorem states that the two natural transformations of
the diagram in the middle are equal.
#

    F                       G ∘ F                      G
 C —————––>D   D —————————–—————————————————–—–—–> E   D —–————–> E
     ||           ||                           ||          ||
     ||N1         ||                           ||          ||N2
     ||           ||                           ||          ||
     \/           ||                           ||          \/
     F'           ||                           ||          G'
 C ————–—–>D      ||(N4 ∘ N2) ∘_h (N3 ∘ N1)    ||      D ———–——–> E
     ||           ||                           ||          ||
     || N3        ||                           ||          ||N4
     ||           ||  (N4 ∘_h N3) ∘ (N2 ∘_h N1)||          ||
     \/           ||                           ||          \/
     F''          \/                           \/          G''
 C ————–—–> D  D ——–—————————————————————————–——–> E   D————–——–> E
                            G'' ∘ F''

#
*)
Section NatTrans_comp_hor_comp.
  Context {C D E  : Category}
          {F F' F'' : (C –≻ D)%functor}
          {G G' G'' : (D –≻ E)%functor}
          (N1 : F –≻ F')
          (N2 : G –≻ G')
          (N3 : F' –≻ F'')
          (N4 : G' –≻ G'')
  .

  Theorem NatTrans_comp_hor_comp
    : ((N4 ∘_h N3) ∘ (N2 ∘_h N1) = (N4 ∘ N2) ∘_h (N3 ∘ N1))%nattrans.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c.
    cbn.
    rewrite F_compose.
    repeat rewrite assoc.
    match goal with
      [|- (?A ∘ ?B = ?A ∘ ?C)%morphism] =>
      let H := fresh in
      cut (B = C); [intros H; rewrite H; trivial|]
    end.
    repeat rewrite assoc_sym.
    match goal with
      [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] =>
      let H := fresh in
      cut (A = C); [intros H; rewrite H; trivial|]
    end.
    apply Trans_com.
  Qed.

End NatTrans_comp_hor_comp.

(**
Given I : C ≃ D for categories C and D and F : D -> E, there is a natural
transformation from F ∘ (I ∘ I⁻¹) to F and back.
*)
Section IsoCat_NatTrans.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%isomorphism)
          {E : Category} (F : (D –≻ E)%functor).

  Local Obligation Tactic := idtac.

  Program Definition IsoCat_NatTrans :
    (F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism)) –≻ F
    :=
      {|
        Trans :=
          fun c =>
            match eq_sym (f_equal (fun x => (x _o)%object c) (right_inverse I))
                  in _ = y return ((F _o y) –≻ (F _o c))%object%morphism
            with
              eq_refl => id
            end
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    match goal with
      [|- (match ?e with _ => _ end ∘ ?A)%morphism
         = (?B ∘ match ?e' with _ => _ end)%morphism] =>
      generalize e; generalize e';
      set (U := A); set (V := B)
    end.
    intros H H'.
    cut (JMeq U V); [intros HUV|].
    {
      apply JMeq_eq.
      destruct H.
      set (z' := ((iso_morphism I)
                    _o ((inverse_morphism I) _o c'))%object) in *.
      clearbody U.
      clearbody z'.
      destruct H'.
      auto.
    }
    {
      unfold U, V; clear.
      match goal with
        [|- JMeq (F @_a ?A ?B ?C)%morphism (F _a ?D)%morphism] =>
        set (V := C);
        set (M := A) in *;
        set (N := B) in *;
        set (U := D)
      end.
      cut (M = c); [intros Hc|].
      {
        cut (N = c'); [intros Hc'|].
        {
          cut (JMeq V U); [intros HVU|].
          {
            clearbody U V M N.
            destruct Hc.
            destruct Hc'.
            apply JMeq_eq in HVU.
            destruct HVU.
            trivial.
          }
          {
            unfold U, V, M, N; clear.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
            change ((iso_morphism I) _a (I⁻¹ _a h))%morphism
            with (((iso_morphism I) ∘ I⁻¹) _a h)%morphism.
            cbn_rewrite (right_inverse I).
            trivial.
          }
        }
        {
          unfold N; clear.
          change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
          with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
          cbn_rewrite (right_inverse I); trivial.
        }
      }
      {
        unfold M; clear.
        change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
        with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
        cbn_rewrite (right_inverse I); trivial.
      }
    }
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply IsoCat_NatTrans_obligation_1.
  Qed.

  Program Definition IsoCat_NatTrans_back :
    F –≻ (F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism))
    :=
      {|
        Trans :=
          fun c =>
            match eq_sym (f_equal (fun x => (x _o)%object c) (right_inverse I))
                  in _ = y return ((F _o c) –≻ (F _o y))%object%morphism
            with
              eq_refl => id
            end
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    match goal with
      [|- (match ?e with _ => _ end ∘ ?A)%morphism
         = (?B ∘ match ?e' with _ => _ end)%morphism] =>
      generalize e; generalize e';
      set (U := A); set (V := B)
    end.
    intros H H'.
    cut (JMeq U V); [intros HUV|].
    {
      apply JMeq_eq.
      destruct H'.
      set (z := ((iso_morphism I) _o ((inverse_morphism I) _o c))%object) in *.
      clearbody V.
      clearbody z.
      destruct H.
      auto.
    }
    {
      unfold U, V; clear.
      match goal with
        [|- JMeq (F _a ?D)%morphism (F @_a ?A ?B ?C)%morphism] =>
        set (V := C);
        set (M := A) in *;
        set (N := B) in *;
        set (U := D)
      end.
      cut (M = c); [intros Hc|].
      {
        cut (N = c'); [intros Hc'|].
        {
          cut (JMeq U V); [intros HUV|].
          {
            clearbody U V M N.
            destruct Hc.
            destruct Hc'.
            apply JMeq_eq in HUV.
            destruct HUV.
            trivial.
          }
          {
            unfold U, V, M, N; clear.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
            change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
            with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
            change ((iso_morphism I) _a (I⁻¹ _a h))%morphism
            with (((iso_morphism I) ∘ I⁻¹) _a h)%morphism.
            cbn_rewrite (right_inverse I).
            trivial.
          }
        }
        {
          unfold N; clear.
          change ((iso_morphism I) _o ((I⁻¹)%morphism _o c'))%object
          with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c')%object.
          cbn_rewrite (right_inverse I); trivial.
        }
      }
      {
        unfold M; clear.
        change ((iso_morphism I) _o ((I⁻¹)%morphism _o c))%object
        with (((iso_morphism I) ∘ (I⁻¹)%morphism) _o c)%object.
        cbn_rewrite (right_inverse I); trivial.
      }
    }
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply IsoCat_NatTrans_back_obligation_1.
  Qed.

End IsoCat_NatTrans.


Require Import Nijn.Prelude.Checks.
Require Import Nijn.Prelude.Relations.WellfoundedRelation.

(** * Transitive closures *)

(** The transitive closure *)
Inductive transitiveClosure {A : Type} (R : A -> A -> Type) : A -> A -> Type :=
| TStep : forall (a1 a2 : A),
    R a1 a2
    -> transitiveClosure R a1 a2
| Trans : forall {a1 a2 a3 : A},
    transitiveClosure R a1 a2
    -> transitiveClosure R a2 a3
    -> transitiveClosure R a1 a3.

Arguments TStep {_ _ _ _} _.
Arguments Trans {_ _ _ _ _} _ _.

(** * Wellfoundedness of the transitive closure *)

(** A relation is wellfounded if its transitive closure is wellfounded *)
Proposition wf_from_transitiveClosure
            {A : Type}
            (R : A -> A -> Type)
            (HR : Wf (transitiveClosure R))
  : Wf R.
Proof.
  refine (fiber_Wf HR (fun a => a) _).
  intros a1 a2 r.
  apply TStep.
  exact r.
Qed.

(** * Reflexive closure *)
Definition reflexiveClosure {A : Type} (R : A -> A -> Type) : A -> A -> Type :=
  fun a1 a2 => (R a1 a2 + (a1 = a2))%type.


Require Import UniMath.Foundations.PartA.
Require Import UniMath.Algebra.Monoids_and_Groups.
Require Import UniMath.Combinatorics.Lists.

Require Import MoreLists.

Section PermLists.
Context  {A : hSet}
         (dec_A : isdeceq A).

Definition swap := setdirprod A A.
Definition swap_list := setlist swap.

Definition swap_map : swap -> A -> A.
Proof.
  intros s a.
  induction s as [b c].
  induction (dec_A a b).
  - exact c.
  - induction (dec_A a c).
    + exact b.
    + exact a.
Defined.

Lemma dec_A_eq {x y : A} (e : x = y) : dec_A x y = inl e.
Proof.
  induction (dec_A x y) as [e' | n].
  - assert (h : e = e').
    { apply uip. apply setproperty. }
    rewrite h. apply idpath.
  - use fromempty. apply n. apply e.
Defined.

Corollary dec_A_triv (x : A) : dec_A x x = inl (idpath _).
Proof.
  apply dec_A_eq.
Defined.

Lemma dec_A_neq {x y : A} (n : x != y) : dec_A x y = inr n.
Proof.
  induction (dec_A x y) as [e | n'].
  - use fromempty. apply n. apply e.
  - assert (h : n = n').
    { use proofirrelevance. apply isapropneg. }
    rewrite h. apply idpath.
Defined.

Lemma swap_auto_inv (s : swap) : ∏ x : A, swap_map s (swap_map s x) = x.
Proof.
  intro a. induction s as [x y].
  unfold swap_map.
  induction (dec_A a x) as [q | nq] ; cbn.
  - rewrite (dec_A_triv y). cbn. rewrite q.
    induction (dec_A y x) as [q' | nq'] ; cbn.
    + assumption.
    + apply idpath.
  - induction (dec_A a y) as [q' | nq'] ; cbn.
    + rewrite q'. rewrite (dec_A_triv x). cbn.
      apply idpath.
    + rewrite (dec_A_neq nq). cbn.
      rewrite (dec_A_neq nq'). cbn.
      apply idpath.
Defined.

Definition swap_to_weq : swap -> weq A A.
Proof.
  intros s.
  use weqgradth.
  - exact (swap_map s).
  - exact (swap_map s).
  - apply swap_auto_inv.
  - apply swap_auto_inv.
Defined.

Definition swap_list_to_weq : swap_list -> weq A A.
Proof.
  use list_ind.
  - apply idweq.
  - intros p xs IHn.
    pose (swap_to_weq p) as w.
    apply (weqcomp IHn w).
Defined.

Definition swap_list_to_weq_nil : swap_list_to_weq nil = (idweq _).
Proof.
  reflexivity.
Defined.
Definition swap_list_to_weq_cons (a : swap) (ls : swap_list)
  : swap_list_to_weq (cons a ls) = weqcomp (swap_list_to_weq ls) (swap_to_weq a).
Proof.
  reflexivity.
Defined.

Definition swap_list_to_weq_concat : forall (l1 l2 : swap_list),
    weqcomp (swap_list_to_weq l2) (swap_list_to_weq l1)
    = swap_list_to_weq (concatenate l1 l2).
Proof.
  intros l1 l2. revert l1.
  use list_ind.
  -- simpl.
     rewrite concatenate_nil_lunit.
     use total2_paths2_f.
     ++ use funextfun.
        intros z.
        reflexivity.
     ++ apply isapropisweq.
  -- simpl ; intros x xs IH.
     rewrite concatenateStep.
     rewrite !swap_list_to_weq_cons.
     rewrite <- IH.
     use total2_paths2_f.
     ++ use funextfun.
        intros z.
        reflexivity.
     ++ apply isapropisweq.
Defined.

Definition weq_inverse_list (l : swap_list) :
  ∑ s : swap_list, invweq (swap_list_to_weq l) = swap_list_to_weq s.
Proof.
  use tpair.
  + apply (reverse l).
  + simpl.
    revert l.
    use list_ind.
    -- cbn.
       symmetry.
       exact inv_idweq_is_idweq.
    -- simpl ; intros x xs IH.
       rewrite swap_list_to_weq_cons.
       rewrite invweqcomp.
       rewrite reverse_cons.
       rewrite IH.
       rewrite <- swap_list_to_weq_concat.
       use total2_paths2_f.
       ++ use funextfun.
          intros z.
          cbn.
          reflexivity.
       ++ apply isapropisweq.
Defined.

End PermLists.


From iris.algebra Require Import base gmap.
From stdpp Require Import gmap mapset.

Section Graphs.
  Context {T : Type} {HD : EqDecision T} {HC : @Countable T HD}.

  Definition graph := gmap T (option T * option T).

  Identity Coercion graph_to_gmap : graph >-> gmap.

  Definition get_left (g : graph) x : option T := g !! x ≫= fst.
  Definition get_right (g : graph) x : option T := g !! x ≫= snd.

  Definition strict_sub_child (ch ch' : option T) :=
    match ch, ch' with
    | Some c, Some c' => c = c'
    | Some c, None => True
    | None, Some _ => False
    | None, None => True
    end.

  Definition strict_sub_children (ch ch' : option T * option T) : Prop :=
    strict_sub_child (ch.1) (ch'.1) ∧ strict_sub_child (ch.2) (ch'.2).

  Definition strict_subgraph (g g' : graph) : Prop :=
    ∀ x, strict_sub_children (get_left g x, get_right g x)
           (get_left g' x, get_right g' x).

(* A path is a list of booleans true for left child and false for the right *)
(* The empty list is the identity trace (from x to x). *)
  Definition path := list bool.

  Identity Coercion path_to_list : path >-> list.

  Inductive valid_path (g : graph) (x y : T) : path → Prop :=
  | valid_path_E : x ∈ dom (gset _) g → x = y → valid_path g x y []
  | valid_path_l (xl : T) p : get_left g x = Some xl → valid_path g xl y p →
      valid_path g x y (true :: p)
  | valid_path_r (xr : T) p : get_right g x = Some xr → valid_path g xr y p →
      valid_path g x y (false :: p).

  Definition connected (g : graph) (x : T) :=
    ∀ z, z ∈ dom (gset _) g → ∃ p, valid_path g x z p.

  Definition front (g : graph) (t t' : gset T) := t ⊆ dom (gset _) g ∧
    ∀ x v, x ∈ t → (get_left g x = Some v) ∨ (get_right g x = Some v) →
       v ∈ t'.

  Definition maximal (g : graph) := front g (dom (gset _) g) (dom (gset _) g).

  Definition tree (g : graph) (x : T) :=
    ∀ z, z ∈ dom (gset _) g → exists !p, valid_path g x z p.

  (* graph facts *)

  Lemma front_t_t_dom g z t :
    z ∈ t → connected g z → front g t t → t = dom (gset _) g.
  Proof.
    intros Hz Hc [Hsb Hdt].
    apply set_equiv_spec_L; split; trivial.
    apply elem_of_subseteq => x Hx. destruct (Hc x Hx) as [p pv].
    clear Hc Hx; revert z Hz pv.
    induction p => z Hz pv.
    - by inversion pv; subst.
    - inversion pv as [|? ? Hpv1 Hpv2 Hpv3|? ? Hpv1 Hpv2 Hpv3]; subst.
      + eapply IHp; [eapply Hdt|apply Hpv2]; eauto.
      + eapply IHp; [eapply Hdt|apply Hpv2]; eauto.
  Qed.

  Lemma front_mono g t t' s : front g t t' → t' ⊆ s → front g t s.
  Proof. intros [Htd Hf] Hts; split; eauto. Qed.

  Lemma front_empty g : front g ∅ ∅.
  Proof. split; auto. intros ? Hcn; inversion Hcn. Qed.

  Lemma strict_sub_children_refl v : strict_sub_children v v.
  Proof. by destruct v as [[] []]. Qed.

  Lemma strict_sub_children_trans v1 v2 v3 : strict_sub_children v1 v2 →
    strict_sub_children v2 v3 → strict_sub_children v1 v3.
  Proof.
   destruct v1 as [[] []]; destruct v2 as [[] []];
   destruct v3 as [[] []]; cbv; by intuition subst.
  Qed.

  Lemma strict_sub_children_None v : strict_sub_children v (None, None).
  Proof. by destruct v as[[] []]. Qed.

  Lemma strict_subgraph_empty g : strict_subgraph g ∅.
  Proof.
    intros i.
    rewrite /get_left /get_right /strict_sub_child lookup_empty //=.
    by destruct (g !! i) as [[[] []]|].
  Qed.

  Lemma get_left_dom g x y : get_left g x = Some y → x ∈ dom (gset _) g.
  Proof.
    rewrite /get_left elem_of_dom. case _ : (g !! x); inversion 1; eauto.
  Qed.

  Lemma get_right_dom g x y : get_right g x = Some y → x ∈ dom (gset _) g.
  Proof.
    rewrite /get_right elem_of_dom. case _ : (g !! x); inversion 1; eauto.
  Qed.

  Lemma path_start g x y p : valid_path g x y p → x ∈ dom (gset _) g.
  Proof. inversion 1; subst; eauto using get_left_dom, get_right_dom. Qed.

  Lemma path_end g x y p : valid_path g x y p → y ∈ dom (gset _) g.
  Proof. induction 1; subst; eauto. Qed.

End Graphs.

Arguments graph _ {_ _}.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import Coq.Program.Basics.
Open Scope program_scope.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import theories.Poset.
Require Import theories.Monad.

Axiom predicate_extensionality : forall {a} {P Q : a -> Prop}, (forall x, P x <-> Q x) -> P = Q.

Record downset (a : poset) := mk_downset {
  has : a -> Prop;
  downclosed {x y : a} : ord a x y -> has y -> has x
}.
Arguments has {a}.
Arguments downclosed {a} _ {x} {y}.

Theorem downset_extensionality {a : poset} {dset0 dset1 : downset a} : (forall x, has dset0 x <-> has dset1 x) -> dset0 = dset1.
intro.
assert (has dset0 = has dset1).
exact (predicate_extensionality H).
induction dset0. induction dset1.
simpl in H0.
generalize dependent downclosed0.
rewrite H0.
intros.
assert (@downclosed0 = @downclosed1).
extensionality x.
extensionality y.
extensionality ord.
extensionality h.
exact (proof_irrelevance (has1 x) _ _).
rewrite H1.
reflexivity.
Qed.

Inductive ord_downset {a : poset} : relation (downset a) :=
| OrdDownset {dset0 dset1} (incl : forall x, has dset0 x -> has dset1 x) : ord_downset dset0 dset1.

Definition downset_poset (a : poset) : poset.
apply (mk_poset (downset a) ord_downset).
intro.
exact (OrdDownset (fun _ h => h)).
intros.
induction H, H0.
apply OrdDownset.
intros.
exact (incl0 x (incl x H)).
intros.
induction H, H0.
apply downset_extensionality.
intro.
split.
exact (incl x).
exact (incl0 x).
Defined.

Theorem downset_inclusion {a : poset} {dset0 dset1 : downset a} :
  forall {x}, ord_downset dset0 dset1 -> has dset0 x -> has dset1 x.
intros.
induction H.
exact (incl x H0).
Qed.

Definition downclose_has {a : poset} (has : a -> Prop) : a -> Prop :=
  fun x => exists y, has y /\ ord a x y.

Theorem downclose_has_is_downclosed {a : poset} {has : a -> Prop} :
  forall x y, ord a x y -> downclose_has has y -> downclose_has has x.
intros.
destruct H0.
destruct H0.
exists x0.
split.
auto.
exact (ord_trans a H H1).
Qed.

Inductive downset_unit_has {a} (x : a) : a -> Prop :=
| DsetUnitHas : downset_unit_has x x.
Arguments DsetUnitHas {a} {x}.

Definition downset_unit {a : poset} (x : a) : downset a := {|
  has := downclose_has (downset_unit_has x);
  downclosed := downclose_has_is_downclosed
|}.

Inductive downset_fmap_has {a : poset} {b} (f : a -> b) (dset : downset a) : b -> Prop :=
| DsetFmapHas {x} (h : has dset x): downset_fmap_has f dset (f x).
Arguments DsetFmapHas {a} {b} {f} {dset} {x}.

Definition raw_downset_fmap {a b : poset} (f : a -> b) (dset : downset a) : downset b := {|
  has := downclose_has (downset_fmap_has f dset);
  downclosed := downclose_has_is_downclosed
|}.

Program Definition downset_fmap {a b : poset} (f : a -> b) : monotone (downset_poset a) (downset_poset b) := {|
  base_f := raw_downset_fmap f;
|}.

Next Obligation.
apply OrdDownset.
intros.
destruct H0.
destruct H0.
inversion H0. subst.
apply (downclosed _ H1).
exists (f x2).
split.
apply DsetFmapHas.
exact (downset_inclusion H h).
exact (ord_refl b).
Qed.

Inductive downset_mult_has {a : poset} (dset0 : downset (downset_poset a)) : a -> Prop :=
| DsetMultHas (dset1 : downset a) {x} (h0 : has dset0 dset1) (h1 : has dset1 x) : downset_mult_has dset0 x.
Arguments DsetMultHas {a} {dset0}.

Definition raw_downset_mult {a} (ddset : downset (downset_poset a)) : downset a := {|
  has := downclose_has (downset_mult_has ddset);
  downclosed := downclose_has_is_downclosed
|}.

Program Definition downset_mult {a : poset} : monotone (downset_poset (downset_poset a)) (downset_poset a) :=
  mk_monotone
    (a := downset_poset (downset_poset a))
    (b := downset_poset a)
    raw_downset_mult
    _.

Next Obligation.
apply OrdDownset.
intros.
destruct H0.
destruct H0.
induction H0.
exists x0.
split.
apply (DsetMultHas dset1).
exact (downset_inclusion H h0).
exact (downclosed _ H1 h1).
exact (ord_refl a).
Qed.

Program Definition downset_monad : monad := {|
  base_m := downset_poset;
  unit _ := downset_unit;
  fmap _ _ := downset_fmap;
  mult _ := downset_mult
|}.

Next Obligation.
extensionality x.
apply downset_extensionality.
intro.
split.
intro.
destruct H.
destruct H.
inversion H. subst.
apply (downclosed _ H0).
unfold id.
exact h.
intro.
exists x0.
split.
change x0 with (id x0).
apply DsetFmapHas.
exact H.
exact (ord_refl a).
Qed.

Next Obligation.
extensionality dset.
apply downset_extensionality.
intro.
split.
intro.
destruct H.
destruct H.
inversion H.
destruct h.
destruct H2.
inversion H2. subst.
assert (ord c (g x1) (g (f x3))).
apply base_f_mono.
auto.
apply (downclosed _ (ord_trans _ H0 H1)).
exists (g (f x3)).
split.
change (g (f x3)) with ((g ∘ f) x3).
apply DsetFmapHas.
auto.
exact (ord_refl c).
intro.
destruct H.
destruct H.
inversion H. subst.
apply (downclosed _ H0).
exists ((g ∘ f) x1).
split.
unfold compose.
apply DsetFmapHas.
exists (f x1).
split.
apply DsetFmapHas.
auto.
exact (ord_refl b).
exact (ord_refl c).
Qed.

Next Obligation.
extensionality x.
apply downset_extensionality.
intro.
split.
intro.
destruct H.
destruct H.
inversion H.
refine (downclosed _ H0 _).
exists x1.
split.
subst.
apply DsetFmapHas.
exists x.
repeat constructor.
exact (ord_refl a).
exact (ord_refl b).
intro.
inversion H.
inversion H0.
inversion H1.
inversion h.
inversion H4.
inversion H5.
subst.
assert (ord b (f x2) (f x3)).
apply (base_f_mono f _ _ H6).
refine (downclosed _ (ord_trans _ H2 H3) _).
exists (f x3).
repeat constructor.
exact (ord_refl b).
Qed.

Next Obligation.
extensionality ddset.
apply downset_extensionality.
intro.
split.
intro.
destruct H.
destruct H.
destruct H.
destruct h0.
destruct H.
destruct H.
assert (has (downset_fmap f x1) x0).
change
  {| has := downclose_has (downset_fmap_has f x1); downclosed := downclose_has_is_downclosed |}
with
  (downset_fmap f x1) in H1.
exact (downset_inclusion H1 h1).
destruct H.
destruct H.
inversion H. subst.
apply (downclosed _ (ord_trans _ H0 H2)).
exists (f x3).
split.
apply DsetFmapHas.
exists x3.
split.
apply (DsetMultHas x1).
auto.
auto.
exact (ord_refl a).
exact (ord_refl b).
intro.
destruct H.
destruct H.
inversion H. subst.
destruct h.
destruct H1.
destruct H1.
exists x.
split.
apply (DsetMultHas (downset_fmap f dset1)).
exists (downset_fmap f dset1).
split.
apply DsetFmapHas.
auto.
exact (ord_refl _).
apply (downclosed _ H0).
exists (f x1).
split.
apply DsetFmapHas.
apply (downclosed _ H2).
auto.
exact (ord_refl b).
exact (ord_refl b).
Qed.

Next Obligation.
unfold compose.
extensionality dset.
apply downset_extensionality.
intro.
split.
intro.
destruct H.
destruct H.
destruct H.
assert (has dset1 x).
apply (downclosed _ H0).
auto.
assert (ord (downset_poset a) dset1 dset).
destruct h0.
destruct H1.
inversion H1.
auto.
apply (downset_inclusion H1).
auto.
intro.
exists x.
split.
exists dset.
exists dset.
split.
exact DsetUnitHas.
exact (ord_refl _).
auto.
exact (ord_refl _).
Qed.

Next Obligation.
unfold compose.
extensionality dset.
apply downset_extensionality.
intro.
split.
intro.
destruct H.
destruct H.
inversion H.
destruct h0.
destruct H2.
inversion H2. subst.
unfold id.
inversion H3. subst.
assert (has (downset_unit x3) x).
apply (incl x).
apply (downclosed _ H0).
auto.
destruct H1.
destruct H1.
inversion H1. subst.
apply (downclosed _ H4).
auto.
intro.
exists x.
split.
apply (DsetMultHas (downset_unit x)).
exists (downset_unit x).
split.
apply DsetFmapHas.
auto.
exact (ord_refl _).
exists x.
split.
exact DsetUnitHas.
exact (ord_refl _).
exact (ord_refl _).
Qed.

Lemma downset_mult_orig_set {a : poset} {ddset : downset_poset (downset_poset a)} {dset : downset_poset a} {x : a} :
  ord (downset_poset a) dset (downset_mult ddset) -> has dset x -> exists dset1, has ddset dset1 /\ has dset1 x.
intros.
assert (has (downset_mult ddset) x).
exact (downset_inclusion H H0).
destruct H1.
destruct H1.
destruct H1.
exists dset1.
split.
auto.
exact (downclosed dset1 H2 h1).
Qed.

Lemma mult_subset {a : poset} {ddset : downset_poset (downset_poset a)} {dset : downset_poset a} :
  has ddset dset -> ord (downset_poset a) dset (downset_mult ddset).
intro.
apply OrdDownset.
intros.
exists x.
split.
apply (DsetMultHas dset).
exact H.
exact H0.
exact (ord_refl _).
Qed.

Next Obligation.
extensionality dddset.
apply downset_extensionality.
intro.
split.
intro.
exists x.
split.
destruct H.
destruct H.
destruct H.
destruct h0.
destruct H.
destruct H.
assert (exists dset2, has x1 dset2 /\ has dset2 x0).
exact (downset_mult_orig_set H1 h1).
destruct H.
destruct H.
apply (DsetMultHas x2).
exists x2.
split.
apply (DsetMultHas x1).
exact h.
exact H.
exact (ord_refl _).
exact (downclosed x2 H0 H2).
exact (ord_refl _).
intro.
exists x.
split.
destruct H.
destruct H.
destruct H.
destruct h0.
destruct H.
destruct H.
apply (DsetMultHas dset1).
exists (downset_mult dset0).
split.
constructor.
auto.
assert (has dset0 dset1).
exact (downclosed dset0 H1 h2).
exact (mult_subset H).
exact (downclosed dset1 H0 h1).
exact (ord_refl _).
Qed.


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

Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
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 eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    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.

              Definition lst_mem (lst_mem_arg0 : natural) (lst_mem_arg1 : lst) : bool
              := match lst_mem_arg0, lst_mem_arg1 with
                 | n, x => mem x n
                 end.

   Fixpoint lst_subset (lst_subset_arg0 : lst) (lst_subset_arg1 : lst) : bool
              := match lst_subset_arg0, lst_subset_arg1 with
                 | Nil, x => true
                 | Cons n x, y => andb (lst_subset x y) (lst_mem n y )
                 end.

   Definition lst_eq (lst_eq_arg0 : lst) (lst_eq_arg1 : lst) : bool
              := match lst_eq_arg0, lst_eq_arg1 with
                 | x, y => andb (lst_subset x y) (lst_subset y x)
                 end.

Fixpoint lst_intersection (lst_intersection_arg0 : lst) (lst_intersection_arg1 : lst) : lst
           := match lst_intersection_arg0, lst_intersection_arg1 with
              | Nil, x => Nil
              | Cons n x, y => if lst_mem n y then Cons n (lst_intersection x y) else lst_intersection x y
              end.

Lemma Nat_beq_refl : forall (n : natural), eqb n n = true.
Proof.
  intros.
  induction n.
  - auto.
  - reflexivity.

Qed.

Lemma append_single : forall (x : lst) (n : natural), Cons n x = append (Cons n Nil) x.
Proof.
  reflexivity.
Qed.

Lemma mem_append : forall (n : natural) (x y : lst), lst_mem n x = true -> lst_mem n (append y x) = true.
Proof.
  intros.
  induction y.
  - simpl. rewrite IHy. apply Bool.orb_true_r.
  - simpl. assumption.

Qed.

Lemma subset_append_general : forall (x y z : lst), lst_subset x y = true -> lst_subset x (append z y) = true.
Proof.
  intros.
  induction x.
  - simpl. simpl in H. apply Bool.andb_true_iff in H. destruct H. apply IHx in H. apply Bool.andb_true_iff. split.
    + assumption.
    +
    rewrite mem_append. split.
      * assumption.
- reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), lst_subset x y = true -> lst_eq (lst_intersection x y) x = true.
Proof.
  intros.
  induction x.
  - simpl. simpl in H. apply Bool.andb_true_iff in H. destruct H. rewrite H0. apply IHx in H. unfold lst_eq in H.
  apply Bool.andb_true_iff in H. destruct H. unfold lst_eq. apply Bool.andb_true_iff. split.
    + simpl. apply Bool.andb_true_iff. split.
      *
      rewrite append_single. apply subset_append_general. assumption.
      *
      rewrite Nat_beq_refl. reflexivity.
    + simpl. apply Bool.andb_true_iff. split.
      *
lfind.  apply subset_append_general.  assumption.
Admitted.


Require Import Gappa_tactic.

Goal forall x,
  (1 <= x <= 5 -> 3 <= x <= 4 \/ 4 <= x <= 6 \/ 1 <= x + 1 <= 4)%R.
Proof.
gappa.
Qed.


Inductive Kind := KProp | KType.

Module Def.

Section Syntax.

Definition id := nat.

Inductive Term :=
  | TVar : id -> Term
  | TSort : Kind -> Term
  | TFor : Term -> Term -> Term
  | TFun : Term -> Term -> Term
  | TApp : Term -> Term -> Term
  | TRef : Term -> Term -> Term
  | TPrf : Term -> Term.

Inductive ContextSnippet :=
  | CType : Term -> ContextSnippet
  | CHold : Term -> ContextSnippet.

Definition Context := list (option ContextSnippet).

End Syntax.

Fixpoint Shift M d c :=
  match M with
  | TVar n => TVar (if Nat.leb c n then n + d else n)
  | TSort s => TSort s
  | TFor A B => TFor (Shift A d c) (Shift B d (S c))
  | TFun A t => TFun (Shift A d c) (Shift t d (S c))
  | TApp M N => TApp (Shift M d c) (Shift N d c)
  | TRef A P => TRef (Shift A d c) (Shift P d c)
  | TPrf P => TPrf (Shift P d c)
  end.

Fixpoint Subst M y N :=
  match M with
  | TVar x =>
    if (Nat.eqb x y) then
      Shift N y 0
    else if Nat.ltb y x then
      TVar (Nat.pred x)
    else
      TVar x
  | TSort s => TSort s
  | TFor A B => TFor (Subst A y N) (Subst B (S y) N)
  | TFun A t => TFun (Subst A y N) (Subst t (S y) t)
  | TApp M1 M2 => TApp (Subst M1 y N) (Subst M2 y N)
  | TRef A P => TRef (Subst A y N) (Subst P y N)
  | TPrf P => TPrf (Subst P y N)
  end.


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 plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Lemma lem: forall m n, even (plus m n) = negb (even (plus m (Succ n))).
Proof.
induction m.
  - intros. simpl. rewrite <- IHm. reflexivity.
  - intros. simpl. unfold negb. destruct (even n). reflexivity. reflexivity.
Qed.

Lemma lem2: forall n, plus n Zero = n.
Proof.
induction n.
  - simpl. rewrite IHn. reflexivity.
  - reflexivity.
Qed.

(* An alternaturale proof strategy is to prove that plus is commutative as a helper lemma,
and then this theorem can be proven without induction. *)

Theorem theorem0 : forall (x : natural) (y : natural), eq (even (plus x y)) (even (plus y x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. lfind. Admitted.


From mathcomp Require Import ssreflect ssrnat eqtype.
From deriving Require Import deriving.

Require Import type.

(* cf. https://github.com/arthuraa/deriving/blob/master/tests/tree.v *)

(* t_rect is the recursor automatically generated by Coq *)
Time Definition t_indDef A := [indDef for t_rect A].
Canonical t_indType A := Eval hnf in IndType (t A) (t_indDef A).

Time Definition t_eqMixin (A:eqType) := [derive eqMixin for t A].
Canonical t_eqType (A:eqType) := Eval hnf in EqType (t A) (t_eqMixin A).


Inductive vec (a : Type) : nat -> Type :=
 | Nil  :                           vec a 0
 | Cons : forall n, a -> vec a n -> vec a (S n).

Fixpoint fold {a : Type} (b : forall m, vec a m -> Type)
              (z : b 0 (Nil a)) (s : forall m v val, b m v -> a -> b (S m) (Cons a m val v))
              {n : nat} (v : vec a n)
              :=
 match v with
 | Nil => z
 | Cons m l ls => s m ls l (fold b z s ls) l
 end.

Definition map {a b : Type} {n : nat}
               (f : a -> b)
               (v : vec a n) : vec b n
 :=
 fold (fun m v => vec b m)
   (Nil b) (fun m v val rest val' => Cons b m (f val') rest)
   v.

Inductive exT
 {a : Type} (b : a -> Type)
 :=
 exI : forall x : a, b x -> exT b.

Definition filter {a : Type} {n : nat}
                  (p : a -> bool)
                  (v : vec a n)
                  : exT (fun n' => vec a n')
 :=
 fold (fun m v => exT (fun n' => vec a n'))
  (exI _ 0 (Nil _))
  (fun m v val rest val' =>
    if   p val'
    then match rest with
         exI filt_len vo =>
           exI _ (S filt_len) (Cons _ _ val' vo)
         end
    else rest)
  v
.


Require Export Sets_Theorems.

Definition Rel := set.

Definition trans (R : Rel) (A : set) :=
  forall x y z, x ∈ A -> y ∈ A -> z ∈A ->
  <|x,y|> ∈         R  ->        <|y,z|> ∈ R -> <|x,z|> ∈R.

Definition not_refl(R : Rel) (A : set) :=
  forall x, x ∈ A -> ~ <|x,x|> ∈ R.

Definition refl (R : Rel) (A : set) :=
  forall x, x ∈ A -> <|x,x|>∈ R.

Definition trich (R : Rel) (A : set) :=
  forall x y, x ∈ A -> y ∈ A ->
  <|x,y|> ∈ R \/ <|y,x|> ∈ R \/ x = y.

Definition sym (R : Rel)(A : set) :=
  forall x y, x ∈ A -> y ∈ A -> (<|x,y|> ∈ R <-> <|y,x|> ∈ R).

Definition semi_order (R : Rel) (A : set) :=
  trans R A /\ not_refl R A.

Definition total_order (R : Rel)(A : set) :=
  trans R A /\ not_refl R A /\ trich R A.

Definition equivalence (R : Rel) (A : set) :=
  refl R A /\ sym R A /\ trans R A.

Definition Dom (R : Rel) :=
  {⊔ ⊔ R ; fun x => exists y, <|x,y|> ∈ R}.
Theorem dom {R : Rel} :
  forall x, x ∈( Dom R) <-> exists y, <|x,y|> ∈ R.
Proof.
  intro x.
  rewrite class.
  split => [H | H].
  + apply H.
  + induction H as [y H]  .
    split.
    - apply cups.
      exists (Single x).
      split.
      * by apply (single x).
      * apply cups .
        exists (<|x,y|>).
        split.
        apply (x_xOPy x y).
        apply H.
    - exists y.
      done.
Qed.

Definition Ran (R : Rel) :=
  {⊔ ⊔ R ; fun y => exists x, <|x,y|> ∈ R}.
Theorem ran {R : Rel} :
  forall y, y ∈ (Ran R) <-> exists x, <|x,y|> ∈ R.
Proof.
  intro y.
  rewrite class.
  split => [H | H].
  + apply H.
  + induction H as [x xy_R] .
    split.
    - apply cups.
      exists (Couple x y) .
      split.
      * apply (y_xy x y)  .
      * apply cups.
        exists (<|x,y|>) .
        apply (conj (xy_xOPy x y) xy_R).
    - exists x.
      apply xy_R.

Qed.

Definition Restriction R A :=
  { R ; fun u => exists x y, u = <|x,y|> /\ x ∈ A}.
Notation "R ↾ A" := (Restriction R A)(at level 10).  (* ⊺ : upharpoonright*)
Theorem restriction R A :
  forall u, u ∈ (R ↾ A  )  <->  u  ∈  R/\     exists x y, u = <|x,y|> /\ x ∈ A.
Proof.
  intros u.
  by rewrite class.
Qed.

Definition func (f : Rel):=
  forall x, x ∈ (Dom f) -> exists !y, <|x,y|> ∈ f.

Axiom Value : Rel -> set -> set.
Axiom value :
  forall f x, func f ->  <|x, (Value f x)|>  ∈f .

Theorem eq_value {f x y : set} :
  func f -> <|x,y|> ∈ f <-> y = (Value f x).
Proof.
  intro funcf.
  specialize (value f x funcf) as H.
  assert (x_domf : x ∈ (Dom f)).
  apply dom.
  by exists (Value f x).
  specialize (funcf x x_domf).
  induction funcf as [y_ uni_y].
  induction uni_y as [xy_f H1].
  split => [H2 | H2].
  + apply (H1 y) in H2.
    apply (H1 (Value f x)) in H.
    by subst y_.
  + by subst y.
Qed.

Definition Map (F A B : set) :=
  func F /\ Dom F = A /\ Ran F ⊂ B.
Notation "F | A → B" := (Map F A B)(at level 10). (* → : rightarrow *)

Definition Surjection (F A B : set) :=
  F | A → B /\ Ran F = B.

Definition Injection (F A B : set) :=
  F | A → B  /\ forall x x', Value F x = Value F x' -> x = x'.

Definition Bijection (F A B : set) :=
  F | A → B /\ Ran F = B /\ forall x x', Value F x = Value F x' -> x = x'.

Definition Image F A := Ran (F ↾ A).
Theorem image {f A} :
  forall b , b     ∈    (Image f A)    <->    exists   a   ,   a   ∈   A /\   <|a,b|>  ∈     f.
Proof.
  intro b.
  rewrite ran.
  split => [H | H].
  + induction H as [a H1].
    apply restriction in H1.
    induction H1 as [ab_f H1].
    induction H1 as [x]; induction H as [y].
    induction H as [abcy aA].
    apply eq_OrderPair in abcy; induction abcy; subst x y.
    by exists a.
  + induction H as [a]; induction H as [aA ab_f].
    exists a.
    rewrite restriction.
    apply (conj ab_f).
    by exists a; exists b.
Qed.

Definition Product (X Y : set) :=
  {P[P[X ∪ Y]]; fun u => exists x y, x ∈ X /\ y ∈ Y /\ u = <|x,y|>}.
Notation "X × Y" := (Product X Y) (at level 10).

Theorem product X Y :
  forall u, u ∈ (X × Y) <->exists x y, x ∈ X /\ y ∈ Y /\ u = <|x,y|>.
Proof.
  intro u.
  rewrite class.
  split => [H | H] .
  + apply H.
  + induction H as [x]; induction H as [y] .
    induction H as [xX]; induction H as [yY u_xy].
    split.
    - apply powerset.
      intros i iu.
      apply powerset.
      intros j ji.
      rewrite cup.
      rewrite u_xy in iu.
      apply couple in iu.
      induction iu as [i_x | i_xy].
      * rewrite i_x in ji.
        apply single in ji.
        subst j.
        apply (or_introl xX).
      * subst i.
        apply couple in ji.
        induction ji as [j_x | j_y] .
        subst j; apply(or_introl xX).
        subst j; apply(or_intror yY).
    - exists x; exists y.
      apply (conj xX (conj yY u_xy)).
Qed.

Lemma prop_implies_func (A : set) (P : set -> set -> Prop) :
  (forall x, x ∈ A -> exists !y, (P x y)) ->
  (exists f, func f /\ Dom f = A /\ forall x, x ∈ A ->(P x (Value f x))).
Proof.
  intro H0.
  specialize (Replacement P A H0) as H.
  induction H as [B H].

  assert (funcf : func ({ A × B ; fun u => exists x y, u = <|x,y|> /\ P x y})).
  intros x x_domf.
  apply dom in x_domf.
  induction x_domf as [y H1].
  exists y.
  apply (conj H1).
  apply class in H1.
  induction H1 as [L R].
  apply product in L.
  induction L as [x_ L]; induction L as [y_ L].
  induction L as [xA L]; induction L as [yB xyxy].
  apply eq_OrderPair in xyxy; induction xyxy; subst x_ y_.
  induction R as [x_ R]; induction R as [y_ R].
  induction R as [xyxy Pxy].
  apply eq_OrderPair in xyxy; induction xyxy; subst x_ y_.
  intros y' H1.
  apply class in H1.
  induction H1 as [L R].
  apply product in L.
  induction L as [x_ L]; induction L as [y_ L].
  induction L as [_ L]; induction L as [y_B xyxy].
  apply eq_OrderPair in xyxy; induction xyxy; subst x_ y_.
  induction R as [x_ R]; induction R as [y_ R].
  induction R as [xyxy Pxy'].
  apply eq_OrderPair in xyxy; induction xyxy; subst x_ y_.
  specialize (H0 x xA).
  induction H0 as [y0 H0].
  induction H0 as [Pxy0 H0].
  apply (H0 y) in Pxy.
  apply (H0 y' ) in Pxy'.
  by subst y0 y'.

  exists ({ A × B ; fun u => exists x y, u = <|x,y|> /\ P x y}) .
  apply (conj funcf).
  split.
  + apply Extensionality => a.
    split => [H2 | H1].
    - apply dom in H2.
      induction H2 as [b H2].
      apply class in H2.
      induction H2 as [H2 _].
      apply product in H2.
      induction H2 as [x]; induction H1 as [y].
      induction H1 as [xA]; induction H1 as [_ abcy].
      by apply eq_OrderPair in abcy; induction abcy; subst x y.
    - rewrite dom.
      specialize (H a H1).
      induction H as [b H].
      induction H as [bB Pab].
      exists b.
      apply class.
      split.
      * apply product.
        by exists a; exists b.
      * by exists a; exists b.
  + intros a aA.
    specialize (H0 a aA) as H3.
    specialize (H a aA).
    induction H as [b]; induction H as [bB Pab].
    induction H3 as [b_]; induction H as [_ H].
    specialize (H b Pab) as bb_.
    assert (b_fa : b = Value ({A × B; fun u : set => exists x y : set, u = <| x, y |> /\ P x y}) a).
    apply (eq_value funcf).
    apply class.
    split.
    apply product.
    by exists a; exists b.
    by exists a; exists b.
    by rewrite <- b_fa.
Qed.

Definition Reverse (R : Rel) :=
  {(Ran R) × (Dom  R)  ; fun u => exists x y, u = <|y,x|> /\ <|x,y|> ∈ R}.

Theorem reverse (R : Rel) :
  forall x y, <|x,y|> ∈ (Reverse R) <-> <|y,x|> ∈ R.
Proof.
  intros x y.
  rewrite class.
  split => [H | H].
  + induction H as [_ H].
    induction H as [x_]; induction H as [y_].
    induction H as [xyxy xy_R].
    by apply eq_OrderPair in xyxy; induction xyxy; subst x_ y_.
  + split.
    - apply product.
      exists x; exists y.
      rewrite ran.
      rewrite dom.
      split.
      by exists y.
      split.
      by exists x.
      done.
    - by exists y; exists x.
Qed.

Definition Composition (G F : Rel) : Rel :=
  {(Dom F) × (Ran G) ; fun u => exists x y z, u = <|x,z|> /\ <|x,y|> ∈ F /\ <|y,z|> ∈ G }.
Notation "G ○ F" := (Composition G F) (at level 10).
Theorem composition {G F} :
    forall u, u ∈ (G ○ F) <-> exists x y z, u = <|x,z|> /\ <|x,y|> ∈ F /\ <|y,z|> ∈ G.
Proof.
  intro u.
  rewrite class.
  split => [H | H].
  + apply H.
  + induction H as [x]; induction H as [y]; induction H as [z].
    induction H as [u_xz]; induction H as [xy_F yz_G].
    split.
    - rewrite product.
      exists x; exists z.
      split.
      * rewrite dom.
        exists y.
        apply xy_F.
      * split.
        rewrite ran .
        exists y.
        apply yz_G.
        done.
    - exists x; exists y; exists z.
      apply (conj u_xz (conj xy_F yz_G)) .
Qed.

Definition eqClass {R : Rel} {A : set} (H : equivalence R A) (x : set) :=
  { A ; fun y => <|x,y|> ∈ R}.

Theorem eqclass  {R : Rel} {A : set} {H : equivalence R A} {x : set} :
  forall y, y ∈      (eqClass H x)      <->   y   ∈ A   /\      <|x,y|>    ∈     R.
Proof.
  intro y.
  by rewrite class.
Qed.

Definition is_eqClass {R : Rel} {A : set} (H : equivalence R A) (x y : set) :=
  y = (eqClass H x).

Theorem unique_eqClass {R : Rel} {A : set} (H : equivalence R A):
  forall x, x ∈ A -> exists !y, (is_eqClass H) x y.
Proof.
  intros x xA.
  exists (eqClass H x).
  split.
  + done.
  + unfold is_eqClass.
    intros y H1.
    done.
Qed.

Theorem exists_quotiention {R : Rel} {A : set} (H : equivalence R A) :
  exists U, forall u, u ∈ U <->exists x, x ∈ A /\ u = eqClass H x.
Proof.
  specialize (unique_eqClass H)  as h.
  specialize (prop_implies_func A (is_eqClass H) h) as H0.
  induction H0 as [f H0].
  induction H0 as [funcf H0].
  induction H0 as [domA H0].
  exists (Ran f).
  intro u.
  split => [H1 | H1].
  + apply ran in H1.
    induction H1 as [x xuf].
    exists x.
    split.
    - rewrite <- domA.
      rewrite dom.
      by exists u.
    - apply (eq_value funcf) in xuf as u_Hx.
      rewrite u_Hx.
      apply H0.
      rewrite <- domA.
      apply dom.
      by exists u.
  + induction H1 as [x H1].
    induction H1 as [xA u_Hx].
    apply ran.
    assert (xA_ : x ∈ A) by done.
    rewrite <- domA in xA.
    apply dom in xA.
    induction xA as [y xy_f].
    apply (eq_value funcf) in xy_f as y_fx.
    specialize (H0 x xA_).
    exists x.
    apply (eq_value funcf).
    by subst y u.
Qed.

Definition Quotiention (R : Rel) (A : set) (H : equivalence R A) :=
  Class (fun u => exists x, x ∈ A /\ u = eqClass H x) (exists_quotiention H).

Theorem quotiention {R : Rel} {A : set} {H : equivalence R A} :
  forall u, u ∈ (Quotiention R A H) <-> exists x, x ∈ A /\ u = (eqClass H x).
Proof.
  intro u.
  by rewrite class.
Qed.

Definition Isomorphism F A B R G :=
  Bijection F A B /\
  forall x y, x ∈ A -> y ∈ A -> <|x,y|> ∈ R <->
  <|Value F x , Value F y|> ∈ G.
Notation "[ A , R ] ≅ [ B , G ]" := (exists F, Isomorphism F A B R G)(at level 10).


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import choice tuple fintype finfun finset.
From mathcomp Require Import bigop ssralg ssrnum poly ssrint.

Require Import words.

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

(* Characterization via trajectories.*)

(* A two-dimentional grid, as (a  warper around) pairs of  integers *)

Import GRing.Theory Num.Theory.
Open Scope ring_scope.

Inductive gridpoint := Gridpoint of int * int.

(* Boilerplate code to install the structures of equality, countable, choice
   type on type step, plus a coercion from grid to paris of integers. *)

Coercion int_pair_of_gridpoint (p : gridpoint) := let: Gridpoint xy := p in xy.

Canonical gridpoint_subType := Eval hnf in [newType for int_pair_of_gridpoint].

Definition gridpoint_eqMixin := [eqMixin of gridpoint by <:].
Canonical  gridpoint_eqType  := EqType gridpoint gridpoint_eqMixin.

Definition gridpoint_choiceMixin := [choiceMixin of gridpoint by <:].
Canonical  gridpoint_choiceType  := ChoiceType gridpoint gridpoint_choiceMixin.

Definition gridpoint_countMixin   := [countMixin of gridpoint by <:].
Canonical  gridpoint_countType    := CountType gridpoint gridpoint_countMixin.
Canonical  gridpoint_subCountType := Eval hnf in [subCountType of gridpoint].
(* End boilerplate code *)

(* Origin of the gridpoint *)
Definition origin := Gridpoint (0, 0).

(* Abscissia and ordinate of a point of the gridpoint *)
Definition abs  := (fun g : gridpoint => g.1).
Definition ord  := (fun g : gridpoint => g.2).

Lemma gridpoint_eq g1 g2 : (g1 == g2) = (abs g1 == abs g2) && (ord g1 == ord g2).
Proof. by []. Qed.

(* Several predicates describing zones of interest in the grid *)
Definition diag (g : gridpoint) : bool := abs g == ord g.

(* North (closed) half plane *)
Definition nhalf (g : gridpoint) : bool := 0 <= ord g.

(* South (closed) half plane *)
Definition shalf (g : gridpoint) : bool := ord g <= 0.

(* East (closed) half plane *)
Definition ehalf (g : gridpoint) : bool := 0 <= abs g.

(* West (closed) half plane *)
Definition whalf (g : gridpoint) : bool := abs g <= 0.

(* Quadrant I *)
Definition Iquadrant := predI nhalf ehalf.

Arguments Iquadrant : simpl never.

(* (* Quadrant II *) *)
(* Definition IIquadrant : bool := predI nhalf whalf. *)

(* (* Quadrant III *) *)
(* Definition IIIquadrant : bool := predI shalf whalf. *)

(* (* Quadrant IV *) *)
(* Definition IVquadrant : bool := predI shalf ehalf. *)

(* We interpret each step as a function : gridpoint -> gridpoint,
   with the following semantic:
   - North means increasing ordinate of 1, leaving abscissia unchanged
   - West means decreasing abscissia of 1, leaving ordinate unchanged
   - SouthEast (coded by 2) means decreading both ordinate and abscissia. *)

Definition move_of_letter (g : gridpoint) (s : letter) : gridpoint :=
  let: Gridpoint (g1, g2) := g in
  match s with
    |N  => Gridpoint (g1, g2 + 1)
    |W  => Gridpoint (g1 - 1, g2)
    |Se => Gridpoint (g1 + 1, g2 - 1)
  end.

Arguments move_of_letter : simpl never.

Lemma move_of_N g : move_of_letter g N = Gridpoint (abs g, ord g + 1).
Proof. by case: g; case=> g1 g2. Qed.

Lemma move_of_W g : move_of_letter g W = Gridpoint (abs g - 1, ord g).
Proof.  by case: g; case=> g1 g2. Qed.

Lemma move_of_Se g : move_of_letter g Se = Gridpoint (abs g + 1, ord g - 1).
Proof.  by case: g; case=> g1 g2. Qed.

Lemma abs_move_N g : abs (move_of_letter g N) = abs g.
Proof. by rewrite move_of_N. Qed.

Lemma abs_move_W g : abs (move_of_letter g W) = abs g - 1.
Proof. by rewrite move_of_W. Qed.

Lemma abs_move_Se g : abs (move_of_letter g Se) = abs g + 1.
Proof. by rewrite move_of_Se. Qed.

Lemma ord_move_of_N g : ord (move_of_letter g N) = ord g + 1.
Proof. by rewrite move_of_N. Qed.

Lemma ord_move_of_W g : ord (move_of_letter g W) = ord g.
Proof. by rewrite move_of_W. Qed.

Lemma ord_move_of_Se g : ord (move_of_letter g Se) = ord g - 1.
Proof. by rewrite move_of_Se. Qed.

(* We call (trajectory g w) the sequence of positions prescribed by a sequence of
   letters w , from a starting point g of the grid. If the list of letters is
   of the form s :: w, the move coded by s is executed first. The grid point
   (final_pos g w) is the final position on the grid reached at the end of the
   trajectory.*)

Definition final_pos := foldl move_of_letter.

Lemma final_pos_nil g : final_pos g [::] = g. Proof. by []. Qed.

Lemma final_pos_cons g s w :
  final_pos g (s :: w) = final_pos (move_of_letter g s) w.
Proof. by []. Qed.

Lemma final_pos_cat g w1 w2 :
  final_pos g (w1 ++ w2) = final_pos (final_pos g w1) w2.
Proof. by rewrite /final_pos foldl_cat. Qed.

Lemma abs_final g w :
  abs (final_pos g w) = abs g + (#Se w)%:Z - (#W w)%:Z.
Proof.
elim: w g => [| s w ihw] /= g; first by rewrite addrK.
rewrite ihw; case: s => /=; rewrite !add0n ?add1n; first by rewrite abs_move_N.
- by rewrite abs_move_W intS opprD addrACA addrA.
- by rewrite abs_move_Se intS addrA.
Qed.

Lemma ord_final g w :
  ord (final_pos g w) = ord g + (#N w)%:Z - (#Se w)%:Z.
Proof.
elim: w g => [| s w ihw] /= g; first by rewrite addrK.
rewrite ihw; case: s => /=; rewrite !add0n ?add1n ?intS.
- by rewrite ord_move_of_N addrA.
- by rewrite ord_move_of_W.
- by rewrite ord_move_of_Se opprD addrACA addrA.
Qed.

Definition trajectory := scanl move_of_letter.

Lemma trajectory_nil g : trajectory g [::] = [::]. by []. Qed.

Lemma trajectory_cons g s w :
  trajectory g (s :: w) =
  (move_of_letter g s) :: trajectory (move_of_letter g s) w.
Proof. by []. Qed.

Lemma last_trajectory g w : last g (trajectory g w) = final_pos g w.
Proof.
rewrite /final_pos /trajectory (last_nth g) size_scanl; case: w => [| s w] //.
by rewrite [size _]/= [LHS]nth_scanl // -[(size w).+1]/(size (s :: w)) take_size.
Qed.

Lemma trajectory_cat g w1 w2 :
  trajectory g (w1 ++ w2) = trajectory g w1 ++ (trajectory (final_pos g w1) w2).
Proof. by rewrite /trajectory scanl_cat. Qed.

Lemma size_trajectory g w : size (trajectory g w) = size w.
Proof. by rewrite /trajectory size_scanl. Qed.

Lemma nth_trajectory g1 g2 w n : (n < size w)%N ->
   nth g1 (trajectory g2 w) n = final_pos g2 (take n.+1 w).
Proof. by move=> ltnsw; rewrite nth_scanl. Qed.

Lemma final_pos_take g w n :
  final_pos g (take n.+1 w) = nth (final_pos g w) (trajectory g w) n.
Proof.
case: (ltnP n (size  w)) => hnsw; first by rewrite nth_scanl.
rewrite take_oversize; last by apply: leq_trans hnsw _.
by rewrite nth_default // size_trajectory.
Qed.

Lemma abs_nth_trajectory g1 g2 w n : (n < size w)%N ->
  abs (nth g1 (trajectory g2 w) n) =
  abs g2 + (#Se (take n.+1 w))%:Z - (#W (take n.+1 w))%:Z.
Proof. by move=> ?; rewrite nth_trajectory // abs_final. Qed.

Lemma ord_nth_trajectory g1 g2 w n : (n < size w)%N ->
  ord (nth g1 (trajectory g2 w) n) =
  ord g2 + (#N (take n.+1 w))%:Z - (#Se (take n.+1 w))%:Z.
Proof. by move=> ?; rewrite nth_trajectory // ord_final. Qed.

Lemma trajectory_final g w : final_pos g w \in g :: trajectory g w.
Proof.
case: w => [|s w]; first by rewrite /= mem_seq1.
rewrite -[X in final_pos g X \in _]take_size [size _]/= -(nth_trajectory g) //.
by rewrite in_cons mem_nth ?orbT // size_trajectory.
Qed.

Lemma trajectory_final_cons g s w :
  final_pos g (s :: w) \in trajectory g (s :: w).
Proof. by rewrite /=; exact: trajectory_final. Qed.

(* Several predicates on the final position of a trajectory *)

Definition to_diag_traj (g : gridpoint) (w : seq letter) : bool :=
  diag (final_pos g w).

(* Not sure this is the usefull form... *)
Lemma to_diag_trajP g w :
 reflect (abs g + (#Se w)%:Z -  (#W w)%:Z =
          ord g + (#N w)%:Z - (#Se w)%:Z)
         (to_diag_traj g w).
Proof. by apply: (iffP eqP); rewrite /to_diag_traj abs_final ord_final. Qed.

Lemma oto_diag_trajP w :
 reflect ((#Se w)%:Z - (#W w)%:Z = (#N w)%:Z - (#Se w)%:Z)
         (to_diag_traj origin w).
Proof.
rewrite -[LHS]add0r -[RHS]add0r !addrA; exact: (to_diag_trajP origin).
Qed.

Definition loop_traj (g : gridpoint) (w : seq letter) : bool :=
  final_pos g w == g.

Lemma loop_trajP (g : gridpoint) (w : seq letter) :
  reflect (#N w = #Se w /\ #Se w = #W w) (loop_traj g w).
Proof.
rewrite /loop_traj gridpoint_eq.
apply: (iffP andP); rewrite ord_final abs_final; case; last first.
  by move=> -> ->; rewrite !addrK.
  rewrite -!addrA ![_ + (_ - _) == _](can2_eq (addKr _) (addNKr _)) !addNr.
by rewrite  !subr_eq0; move=> /eqP [] <- /eqP [] ->.
Qed.

(* Properties of trajectories that start and stay in the north half plane *)
Definition nhalf_traj (g : gridpoint) (w : seq letter) : bool :=
  all nhalf (g :: (trajectory g w)).

Lemma nhalf_trajE g w : nhalf_traj g w = nhalf g && all nhalf (trajectory g w).
Proof. by []. Qed.

Lemma nhalf_traj_cat  g w1 w2 :
  nhalf_traj g (w1 ++ w2) =
  nhalf_traj g w1 && nhalf_traj (final_pos g w1) w2.
Proof.
rewrite [in LHS]/nhalf_traj trajectory_cat -cat_cons all_cat.
apply: andb_id2l; rewrite nhalf_trajE; move/allP/(_ _ (trajectory_final _ _))->.
done.
Qed.

(* If the trajectory along w from the origin stays in the north half-plane,
  then the number of Se in w is smaller than the number of N *)
Lemma nhalf_otraj_le w : nhalf_traj origin w ->
  (#Se w <= #N w)%N.
Proof.
move/allP/(_ _ (trajectory_final _ _)); rewrite /nhalf ord_final add0r subr_ge0.
done.
Qed.

(* If  the trajectory along w from the origin stays in the north half-plane,
  then for every of its prefixes w' the number of Se in w' is smaller than
  the number of N *)

Lemma nhalf_otraj_pre w1 w2 : nhalf_traj origin (w1 ++ w2) ->
  (#Se w1 <= #N w1)%N.
Proof. by rewrite nhalf_traj_cat; case/andP=> /nhalf_otraj_le. Qed.

(* This is in fact characterizing trajectories from the origin that stay in
   the north plane *)
Lemma nhalf_otrajP w :
  reflect (forall n, #Se (take n w) <= #N (take n w))%N
          (nhalf_traj origin w).
Proof.
apply: (iffP idP) => [ntw n| countle].
  by move: ntw; rewrite -{1}[w](cat_take_drop n); move/nhalf_otraj_pre.
rewrite nhalf_trajE /=; apply/(all_nthP origin) => i ltisw.
rewrite /nhalf ord_nth_trajectory -?(size_trajectory origin) // subr_ge0.
exact: countle.
Qed.

(* The analogue theory for trajectories staying in the east half plane.
   Copy-paste mutatis mutandis. *)

Definition ehalf_traj (g : gridpoint) (w : seq letter) : bool :=
  all ehalf (g :: (trajectory g w)).

Lemma ehalf_trajE g w :
  ehalf_traj g w = ehalf g && all ehalf (trajectory g w).
Proof. by []. Qed.

Lemma ehalf_traj_cat  g w1 w2 :
  ehalf_traj g (w1 ++ w2) =
  ehalf_traj g w1 && ehalf_traj (final_pos g w1) w2.
Proof.
rewrite [in LHS]/ehalf_traj trajectory_cat -cat_cons all_cat.
apply: andb_id2l; rewrite ehalf_trajE; move/allP/(_ _ (trajectory_final _ _))->.
done.
Qed.

(* If  the trajectory along w from the origin stays in the east half-plane,
  then the number of W in w is smaller than the number of Se *)
Lemma ehalf_otraj_le w : ehalf_traj origin w -> (#W w <= #Se w)%N.
Proof.
move/allP/(_ _ (trajectory_final _ _)); rewrite /ehalf abs_final add0r subr_ge0.
done.
Qed.

(* If  the trajectory along w from the origin stays in the north half-plane,
  then for every of its prefixes w' the number of W in w' is smaller than
  the number of Se *)

Lemma ehalf_otraj_pre w1 w2 : ehalf_traj origin (w1 ++ w2) ->
  (#W w1 <= #Se w1)%N.
Proof. by rewrite ehalf_traj_cat; case/andP=> /ehalf_otraj_le. Qed.

(* This is in fact characterizing trajectories from the origin that stay in
   the east plane *)
Lemma ehalf_otrajP w :
  reflect (forall n, #W (take n w) <= #Se (take n w))%N
          (ehalf_traj origin w).
Proof.
apply: (iffP idP) => [ntw n| countle].
  by move: ntw; rewrite -{1}[w](cat_take_drop n); move/ehalf_otraj_pre.
rewrite ehalf_trajE /=; apply/(all_nthP origin) => i ltisw.
rewrite /ehalf abs_nth_trajectory -?(size_trajectory origin) // subr_ge0.
exact: countle.
Qed.

Definition Iquadrant_traj (g : gridpoint) (w : seq letter) : bool :=
  all Iquadrant (g :: (trajectory g w)).

Lemma Iquadrant_trajE g w :
  Iquadrant_traj g w = Iquadrant g && all Iquadrant (trajectory g w).
Proof. by []. Qed.

Lemma Iquadrant_nhalf_traj g w : Iquadrant_traj g w -> nhalf_traj g w.
Proof. by rewrite [Iquadrant_traj _ _]all_predI; case/andP. Qed.

Lemma Iquadrant_ehalf_traj g w : Iquadrant_traj g w -> ehalf_traj g w.
Proof. by rewrite [Iquadrant_traj _ _]all_predI; case/andP. Qed.

Lemma Iquadrant_nehalf_traj g w :
  Iquadrant_traj g w = (nhalf_traj g w) && (ehalf_traj g w).
Proof. by rewrite /Iquadrant_traj /Iquadrant all_predI. Qed.

Lemma Iquadrant_traj_cat  g w1 w2 :
  Iquadrant_traj g (w1 ++ w2) =
  Iquadrant_traj g w1 && Iquadrant_traj (final_pos g w1) w2.
Proof.
rewrite [in LHS]/Iquadrant_traj trajectory_cat -cat_cons all_cat.
apply: andb_id2l => /allP/(_ _ (trajectory_final _ _)).
by rewrite Iquadrant_trajE; move->.
Qed.

Lemma Iquadrant_otraj_le w : Iquadrant_traj origin w ->
  (#W w <= #Se w <= #N w)%N.
Proof.
move=> itow; rewrite ehalf_otraj_le; last exact: Iquadrant_ehalf_traj.
rewrite nhalf_otraj_le //; exact: Iquadrant_nhalf_traj.
Qed.

Lemma Iquadrant_otraj_pre w1 w2 : Iquadrant_traj origin (w1 ++ w2) ->
  (#W w1 <= #Se w1 <= #N w1)%N.
Proof.
by rewrite Iquadrant_traj_cat; case/andP=> itow1 _; apply: Iquadrant_otraj_le.
Qed.

Lemma Iquadrant_otrajP w :
  reflect (forall n, #W (take n w) <= #Se (take n w)
                                       <= #N (take n w))%N
          (Iquadrant_traj origin w).
Proof.
apply: (iffP idP) => [ntw n| countle].
  move/Iquadrant_nhalf_traj: (ntw) => /nhalf_otrajP ->.
  by move/Iquadrant_ehalf_traj: (ntw) => /ehalf_otrajP ->.
rewrite Iquadrant_nehalf_traj.
have /nhalf_otrajP -> :
  forall n, (#Se (take n w))%:Z <= (#N (take n w))%:Z.
  by move=> n; case/andP: (countle n).
by apply/ehalf_otrajP=> n; case/andP: (countle n).
Qed.

(* A sequence is an Asequence if its associated trajectory from the origin stays
   in the upper (north) half-plane and ends at the origin: *)

Definition Aseq (w : seq letter) := nhalf_traj origin w && loop_traj origin w.

Lemma Aseq_nhalf w : w \in Aseq -> nhalf_traj origin w.
Proof. by case/andP. Qed.

Lemma Aseq_oloop w : w \in Aseq -> loop_traj origin w.
Proof. by case/andP. Qed.

(* An Aseq necessarily has an equal number of N, W and Se *)
Lemma Aseq_count_NW : {in Aseq, #N =1 #W}.
Proof. by move=> w /Aseq_oloop /loop_trajP; case=> ->. Qed.

Lemma Aseq_count_SeW : {in Aseq, #Se =1 #W}.
Proof. by move=> w /Aseq_oloop /loop_trajP; case=> _ ->. Qed.

Lemma Aseq_count_NSe : {in Aseq, #N =1 #Se}.
Proof. by move=> w Aw; rewrite /= Aseq_count_NW // Aseq_count_SeW. Qed.

(* Any prefix of an Aseq has more N than Se: *)
Lemma Aseq_pre w1 w2 : w1 ++ w2 \in Aseq ->
  (#Se w1)%:Z <= (#N w1)%:Z.
Proof. by move/Aseq_nhalf/nhalf_otraj_pre. Qed.

Lemma AseqP w : reflect
                [/\ forall n, (#Se (take n w))%:Z <= (#N (take n w))%:Z,
                    #N w = #Se w & #Se w = #W w]
                (Aseq w).
Proof.
apply: (iffP idP).
  by rewrite /Aseq; case/andP => /nhalf_otrajP=> ? /loop_trajP; case.
by rewrite /Aseq; case=> /nhalf_otrajP => -> /= he1 he2; apply/loop_trajP.
Qed.

(* A sequence is a B-sequence if its trajectory from the origin stays in
   quadrant I and ends somewhere on the diagonal: *)
Definition Bseq (w : seq letter) :=
  Iquadrant_traj origin w && to_diag_traj origin w.

Lemma Bseq_Iquadrant w : w \in Bseq -> Iquadrant_traj origin w.
Proof. by case/andP. Qed.

Lemma Bseq_oto_diag w : w \in Bseq -> to_diag_traj origin w.
Proof. by case/andP. Qed.

(* A Bseq necessarily has less W than Se than N *)
Lemma Bseq_count_le w : w \in Bseq ->
   (#W w)%:Z <= (#Se w)%:Z <= (#N w)%:Z.
Proof. by move/Bseq_Iquadrant/Iquadrant_otraj_le. Qed.

Lemma Bseq_pre w1 w2 : w1 ++ w2 \in Bseq ->
   (#W w1)%:Z <= (#Se w1)%:Z <= (#N w1)%:Z.
Proof. by move/Bseq_Iquadrant/Iquadrant_otraj_pre. Qed.

(* Again we inherit from the tentative statement of
   to_diagP, probably not in its most convenient form. *)
Lemma Bseq_count w : w \in Bseq ->
  (#Se w)%:Z - (#W w)%:Z = (#N w)%:Z - (#Se w)%:Z.
Proof. by move/Bseq_oto_diag/oto_diag_trajP. Qed.

Lemma BseqP w : reflect
                  ((forall n, (#W (take n w))%:Z <= (#Se (take n w))%:Z
                                                      <= (#N (take n w))%:Z)
                  /\
                    (#Se w)%:Z - (#W w)%:Z =
                    (#N w)%:Z - (#Se w)%:Z)
                  (Bseq w).
Proof.
apply: (iffP idP).
  by rewrite /Bseq; case/andP => /Iquadrant_otrajP=> ? /oto_diag_trajP.
by case=> /Iquadrant_otrajP iw /oto_diag_trajP odw; rewrite /Bseq iw.
Qed.

(* A state monad for datas of type A equipped with two counters *)

(* Now we have all the necessary vocabulary to describe the families of walks
   the exercise is about *)

(* A (walk n) is (a wrapper around) a sequence of size n  *)

Inductive walk (n : nat) := Walk of n.-tuple letter.

(* Boilerplate code to install the structures of equality, countable, choice and
   finite type on type (walk n), plus a coercion from (walk n) to n-tuple. *)

Coercion tuple_of_walk (n : nat) (w : walk n) := let: Walk t := w in t.

Canonical walk_subType (n : nat) := Eval hnf in [newType for (@tuple_of_walk n)].

Definition walk_eqMixin (n : nat) := [eqMixin of (walk n) by <:].
Canonical  walk_eqType (n : nat) := EqType (walk n) (walk_eqMixin n).

Definition walk_choiceMixin (n : nat) := [choiceMixin of (walk n) by <:].
Canonical  walk_choiceType (n : nat) := ChoiceType (walk n) (walk_choiceMixin n).

Definition walk_countMixin (n : nat) := [countMixin of (walk n) by <:].
Canonical  walk_countType (n : nat)  := CountType (walk n) (walk_countMixin n).
Canonical  walk_subCountType (n : nat) := Eval hnf in [subCountType of (walk n)].

Definition walk_finMixin (n : nat)  := [finMixin of (walk n) by <:].
Canonical  walk_finType (n : nat)   := FinType (walk n) (walk_finMixin n).
Canonical  walk_subFinType (n : nat) := Eval hnf in [subFinType of (walk n)].
(* End boilerplate code *)

(* An n-Awalk is an Asequence of length n *)
Definition Awalk (n : nat) (w : walk n) := Aseq w.

(* An n-Bwalk is a B-sequence  of length n *)
Definition Bwalk (n : nat) (w : walk n) := Bseq w.

(* And the conjecture is the following: *)
(* Conjecture card_Awalks_Bwalks : forall n : nat, #|@Awalk n| = #|@Bwalk n|. *)

(* Rmk : I would like n to be explicit in definitions Aseq and Bseq, but
   I do not manage to overrid the flag set by my global options, even
   with the Argument command. Is it possible? *)