(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Export XPath.
Require Export XPathSemantics.
Require Export XPCAxioms.
Require Import XPCdecide.

Section demo.
Variable a : XPath.
Variable b : Name.

(* Equivalence Rule *)
Axiom slash_associatif: forall p1 p2 p3 : XPath, slash p1 (slash p2 p3) = slash (slash p1 p2) p3.

(* Tactical *)
(* Ltac solve_Ple10:= *)
(*   match goal with *)
(*   |-  (Ple (slash dot (slash star (step child (name b))))  (slash dot (step descendant (name b)))) *)
(*  => rewrite slash_associatif; *)
(*     apply g1; [ apply d1;constructor;simpl;auto *)
(*  	      | apply d2;[ apply Ple_reflexive  *)
(*  	      		 | unfold star;apply d1; constructor;simpl; auto] *)
(*  	      ] *)
(* end. *)

(* Automated Proof of ./*/b <= ./descendant::b  *)
Goal (Ple (slash dot (slash star (step child (name b))))  (slash dot (step descendant (name b)))).
rewrite !slash_associatif.
solve_Le idtac.
Qed.

(* Proof of ./*/b <= ./descendant::b without the tactical... *)
Goal (Ple (slash dot (slash star (step child (name b))))  (slash dot (step descendant (name b)))).
rewrite slash_associatif.
apply g1.
 apply d1.
  constructor.
  simpl; auto.
 apply d2.
  apply Ple_reflexive.
  unfold star.
    apply d1.
   constructor.
   simpl; auto.
Qed.

End demo.


(* * Definition of Multi-Tape Turing Machines *)

(* Definitions of tapes and (unlabelled) multi-tape Turing machines from Asperti, Riciotti "A formalization of multi-tape Turing machines" (2015) and the accompanying Matita code. *)

From Undecidability.TM.Util Require Export Prelim Relations.
Require Import Undecidability.Shared.Libs.PSL.Vectors.Vectors.
Require Export Undecidability.TM.TM.

Set Default Goal Selector "!".

#[export] Hint Rewrite <- app_assoc : list.

Section Fix_Sigma.

  Variable sig : Type.

  Notation tape := (tape sig).

  (* ** Definition of the tape *)

  (* A tape is essentially a triple 〈left,current,right〉 where, however, the current symbol could be missing. This may happen for three different reasons: both tapes are empty, we are on the left extremity of a non-empty tape (left overflow), or we are on the right extremity of a non-empty tape (right overflow). *)

  (* Note that the alphabet has type [Type], not [finType]. *)
  (* Print tape. *)

  Definition tapes n := Vector.t tape n.

  Definition tapeToList (t : tape) : list sig :=
    match t with
    | niltape => []
    | leftof s r => s :: r
    | rightof s l => List.rev (s :: l)
    | midtape l c r => (List.rev l) ++ [c] ++ r
    end.

  Definition sizeOfTape t := |tapeToList t|.

  Definition left :=
    fun (t : tape) =>
      match t with
      | niltape => []
      | leftof _ _ => []
      | rightof s l => s :: l
      | midtape l _ _ => l
      end.

  Definition right :=
    fun (t : tape) =>
      match t with
      | niltape => []
      | leftof s r => s :: r
      | rightof _ _ => []
      | midtape _ _ r => r
      end.

  (* Lemmas for [midtape] *)
  Lemma tape_midtape_current_right t rs s :
    current t = Some s ->
    right t = rs ->
    t = midtape (left t) s rs.
  Proof. destruct t; cbn; congruence. Qed.

  Lemma tape_midtape_current_left t ls s :
    current t = Some s ->
    left t = ls ->
    t = midtape ls s (right t).
  Proof. destruct t; cbn; congruence. Qed.

  Lemma tape_is_midtape t ls s rs :
    left t = ls ->
    current t = Some s ->
    right t = rs ->
    t = midtape ls s rs.
  Proof. destruct t; cbn; congruence. Qed.

  (* ** Definition of moves *)

  (* Print move.  *)

  (* Declare discreteness of [move] *)
  #[export] Instance move_eq_dec : eq_dec move.
  Proof.
    intros. hnf. decide equality.
  Defined. (* because definition *)

  (* Declare finiteness of [move] *)
  #[export] Instance move_finC : finTypeC (EqType move).
  Proof.
    apply (FinTypeC (enum := [Lmove; Rmove; Nmove])).
    intros []; now cbv.
  Defined. (* because definition *)

  (* We outsource the second [match] of [tape_move_right] in the [midtape] case to another named definition. This has the advantage that the [cbn] tactic will not reduce [tape_move_left (midtape ls m rs)] to a long term that contains [match]. It reduces to [tape_move_left' ls m rs] instead. Furthermore, there are rewrite lemmas available for [tape_move_left']. *)

  Definition tape_move_right' ls a rs : tape :=
    match rs with
    | nil => rightof a ls
    | r::rs' => midtape (a::ls) r rs'
    end.

  Definition tape_move_right :=
    fun (t : tape) =>
      match t with
      | niltape => niltape
      | rightof _ _ =>t
      | leftof a rs =>midtape  [ ] a rs
      | midtape ls a rs => tape_move_right' ls a rs
      end.

  Definition tape_move_left' ls a rs : tape :=
    match ls with
    | nil => leftof a rs
    | l::ls' => midtape ls' l (a::rs)
    end.

  Definition tape_move_left :=
    fun (t : tape) =>
      match t with
      | niltape => niltape
      | leftof _ _ => t
      | rightof a ls => midtape ls a [ ]
      | midtape ls a rs => tape_move_left' ls a rs
      end.

  Definition tape_move (t : tape) (m : move) :=
    match m with
    | Rmove => tape_move_right t
    | Lmove => tape_move_left t
    | Nmove => t
    end.

  (* *** Rewriting Lemmas *)

  Lemma tapeToList_move (t : tape) (D : move) :
    tapeToList (tape_move t D) = tapeToList t.
  Proof.
    destruct t, D; cbn; auto.
    - revert s l0. induction l; intros; cbn in *; simpl_list; auto.
    - revert s l. induction l0; intros; cbn in *; simpl_list; auto.
  Qed.

  Lemma tapeToList_move_R (t : tape) :
    tapeToList (tape_move_right t) = tapeToList t.
  Proof. apply (tapeToList_move t Rmove). Qed.

  Lemma tapeToList_move_L (t : tape) :
    tapeToList (tape_move_left t) = tapeToList t.
  Proof. apply (tapeToList_move t Lmove). Qed.

  Lemma tape_move_right_left (t : tape) (s : sig) :
    current t = Some s ->
    tape_move_left (tape_move_right t) = t.
  Proof.
    intros H1. destruct t; cbn in *; inv H1; auto; destruct l; auto; destruct l0; auto.
  Qed.

  Lemma tape_move_left_right (t : tape) (s : sig) :
    current t = Some s ->
    tape_move_right (tape_move_left t) = t.
  Proof.
    intros H1. destruct t; cbn in *; inv H1; auto; destruct l; auto; destruct l0; auto.
  Qed.

  (* ** Machine step *)

  (* Writing on the tape *)
  Definition tape_write (t : tape) (s : option sig) :=
    match s with
    | None => t
    | Some s' => midtape (left t) s' (right t)
    end.

  (* A single step of the machine *)
  Definition doAct (t : tape) (mv : option sig * move) :=
    tape_move (tape_write t (fst mv)) (snd mv).

  (* One step on each tape *)
  Definition doAct_multi (n : nat) (ts : tapes n) (actions : Vector.t (option sig * move) n) :=
    Vector.map2 doAct ts actions.

  (* Read characters on all tapes *)
  Definition current_chars (n : nat) (tapes : tapes n) := Vector.map current tapes.

End Fix_Sigma.

(* ** Rewriting tactics *)

(* Tactic to destruct a vector of tapes of known size *)
Lemma destruct_tape {X : Type} (ts : tapes X 1) : ts = [| Vector.hd ts |].
Proof.
  unfold tapes in *. rewrite (Vector.eta ts). generalize (Vector.tl ts). now apply Vector.case0.
Qed.

(* Simplification Database for tapes and vectors *)
Create HintDb tape.
Create HintDb vector.

(* We use [rewrite_strat] instead of [autorewrite], because it is faster. *)
Tactic Notation "simpl_tape" :=
  repeat rewrite_strat (topdown (choice (hints tape) (hints vector))).
Tactic Notation "simpl_tape" "in" ident(H) :=
  repeat rewrite_strat (topdown (choice (hints tape) (hints vector))) in H.
Tactic Notation "simpl_tape" "in" "*" :=
  repeat multimatch goal with
         | [ H : _ |- _ ] => simpl_tape in H
         end;
  simpl_tape.

Tactic Notation "simpl_vector" :=
  repeat rewrite_strat (topdown (hints vector)).
Tactic Notation "simpl_vector" "in" ident(H) :=
  repeat rewrite_strat (topdown (hints vector)) in H.
Tactic Notation "simpl_vector" "in" "*" :=
  repeat multimatch goal with
         | [ H : _ |- _ ] => simpl_vector in H
         end;
  simpl_vector.

#[export] Hint Rewrite tapeToList_move : tape.
#[export] Hint Rewrite tapeToList_move_R : tape.
#[export] Hint Rewrite tapeToList_move_L : tape.
#[export] Hint Rewrite tape_move_right_left using eauto : tape.
#[export] Hint Rewrite tape_move_left_right using eauto : tape.

Arguments current_chars : simpl never.
#[export] Hint Unfold current_chars : tape.

Lemma nth_map' (A B : Type) (f : A -> B) (n : nat) (v : Vector.t A n) (k : Fin.t n) :
  (VectorDef.map f v)[@k] = f v[@k].
Proof. erewrite VectorSpec.nth_map; eauto. Qed.

Lemma nth_map2' (A B C : Type) (f : A -> B -> C) (n : nat) (v1 : Vector.t A n) (v2 : Vector.t B n) (k : Fin.t n) :
  (VectorDef.map2 f v1 v2)[@k] = f v1[@k] v2[@k].
Proof. erewrite VectorSpec.nth_map2; eauto. Qed.

#[export] Hint Rewrite @nth_map' : vector.
#[export] Hint Rewrite @nth_map2' : vector.
#[export] Hint Rewrite VectorSpec.const_nth : vector.

(* Set Notation scopes for tapes, so that the alphabet of the tape is parsed as a type (e.g. [X+Y] is parsed as the sum type, not the addition of [X] and [Y]) *)
Arguments tapes (sig % type) (n % nat).

(* ** Nop Action *)

(* (∅, Nmove)^n *)
Section Nop_Action.
  Variable n : nat.
  Variable sig : finType.

  Definition nop_action := Vector.const (@None sig, Nmove) n.

  Lemma doAct_nop tapes :
    doAct_multi tapes nop_action = tapes.
  Proof.
    unfold nop_action, doAct_multi.
    apply Vector.eq_nth_iff; intros ? i <-.
    erewrite Vector.nth_map2; eauto.
    rewrite Vector.const_nth.
    cbn. reflexivity.
  Qed.

End Nop_Action.

Lemma nth_nop_action {n Σ} i : Vector.nth (nop_action n Σ) i = (None, Nmove).
Proof.
  now induction i.
Qed.

(* Make [n] and [sig] contextual implicit *)
Arguments nop_action {_ _}.

(* ** Mirror tapes *)

Section MirrorTape.
  Variable (n : nat) (sig : Type).

  Definition mirror_tape (t : tape sig) : tape sig :=
    match t with
    | niltape _ => niltape _
    | leftof r rs => rightof r rs
    | rightof l ls => leftof l ls
    | midtape ls m rs => midtape rs m ls
    end.

  Lemma mirror_tape_left (t : tape sig) :
    left (mirror_tape t) = right t.
  Proof. now destruct t. Qed.

  Lemma mirror_tape_right (t : tape sig) :
    right (mirror_tape t) = left t.
  Proof. now destruct t. Qed.

  Lemma mirror_tape_current (t : tape sig) :
    current (mirror_tape t) = current t.
  Proof. now destruct t. Qed.

  Lemma mirror_tape_involution (t : tape sig) :
    mirror_tape (mirror_tape t) = t.
  Proof. destruct t; cbn; congruence. Qed.

  Lemma mirror_tape_injective (t1 t2 : tape sig) :
    mirror_tape t1 = mirror_tape t2 ->
    t1 = t2.
  Proof. destruct t1, t2; intros H; cbn in *; congruence. Qed.

  Lemma mirror_tape_move_left (t : tape sig) :
    mirror_tape (tape_move_left t) = tape_move_right (mirror_tape t).
  Proof. destruct t; cbn; auto. destruct l; cbn; auto. Qed.

  Lemma mirror_tape_move_right (t : tape sig) :
    mirror_tape (tape_move_right t) = tape_move_left (mirror_tape t).
  Proof. destruct t; cbn; auto. destruct l0; cbn; auto. Qed.

  Lemma mirror_tape_inv_midtape t r1 r2 x :
    mirror_tape t = midtape r1 x r2 -> t = midtape r2 x r1.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_leftof t rs x :
    mirror_tape t = leftof rs x -> t = rightof rs x.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_rightof t ls x :
    mirror_tape t = rightof ls x -> t = leftof ls x.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_niltape t :
    mirror_tape t = niltape _  -> t = niltape _.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_midtape' t r1 r2 x :
    midtape r1 x r2 = mirror_tape t -> t = midtape r2 x r1.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_leftof' t rs x :
    leftof rs x = mirror_tape t -> t = rightof rs x.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_rightof' t ls x :
    rightof ls x = mirror_tape t -> t = leftof ls x.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Lemma mirror_tape_inv_niltape' t :
    niltape _ = mirror_tape t -> t = niltape _.
  Proof. intros. destruct t; cbn in *; congruence. Qed.

  Definition mirror_tapes (t : tapes sig n) : tapes sig n := Vector.map mirror_tape t.

  Lemma mirror_tapes_involution (t : tapes sig n) :
    mirror_tapes (mirror_tapes t) = t.
  Proof.
    unfold mirror_tapes. apply Vector.eq_nth_iff. intros ? ? ->.
    erewrite !Vector.nth_map; eauto. apply mirror_tape_involution.
  Qed.

  Lemma mirror_tapes_injective (t1 t2 : tapes sig n) :
    mirror_tapes t1 = mirror_tapes t2 ->
    t1 = t2.
  Proof.
    intros H. unfold mirror_tapes in *. apply Vector.eq_nth_iff. intros ? ? ->.
    eapply Vector.eq_nth_iff with (p1 := p2) in H; eauto.
    erewrite !Vector.nth_map in H; eauto. now apply mirror_tape_injective.
  Qed.

  Definition mirror_move (D : move) : move := match D with | Nmove => Nmove | Lmove => Rmove | Rmove => Lmove end.

  Lemma mirror_move_involution (D : move) : mirror_move (mirror_move D) = D.
  Proof. now destruct D. Qed.

  Lemma mirror_tapes_nth (tapes : tapes sig n) (k : Fin.t n) :
    (mirror_tapes tapes)[@k] = mirror_tape (tapes[@k]).
  Proof. intros. eapply VectorSpec.nth_map; eauto. Qed.

End MirrorTape.

Arguments mirror_tapes : simpl never.
#[export] Hint Unfold mirror_tapes : tape.

#[export] Hint Rewrite mirror_tape_left : tape.
#[export] Hint Rewrite mirror_tape_right : tape.
#[export] Hint Rewrite mirror_tape_current : tape.
#[export] Hint Rewrite mirror_tape_involution : tape.
#[export] Hint Rewrite mirror_tape_move_left : tape.
#[export] Hint Rewrite mirror_tape_move_right : tape.
#[export] Hint Rewrite mirror_tapes_involution : tape.
#[export] Hint Rewrite mirror_tapes_nth : tape.

(* ** Helping functions for tapes *)

Section Tape_Local.

  Variable sig : Type.

  (* The current symbol :: right symbols *)
  Definition tape_local (t : tape sig) : list sig :=
    match t with
    | niltape _ => []
    | leftof a l => []
    | rightof _ _ => []
    | midtape _ a l => a :: l
    end.

  (* The current symbol :: left symbols *)
  Definition tape_local_l (t : tape sig) : list sig :=
    match t with
    | niltape _ => []
    | leftof a l => []
    | rightof _ _ => []
    | midtape r a l => a :: r
    end.

  Lemma tape_local_mirror (t : tape sig) :
    tape_local_l (mirror_tape t) = tape_local t.
  Proof. destruct t; cbn; auto. Qed.

  Lemma tape_local_mirror' (t : tape sig) :
    tape_local (mirror_tape t) = tape_local_l t.
  Proof. destruct t; cbn; auto. Qed.

  Lemma tape_local_current_cons (x : sig) (xs : list sig) (t : tape sig) :
    tape_local t = x :: xs -> current t = Some x.
  Proof. destruct t eqn:E; cbn; congruence. Qed.

  Lemma tape_local_l_current_cons (x : sig) (xs : list sig) (t : tape sig) :
    tape_local_l t = x :: xs -> current t = Some x.
  Proof. destruct t eqn:E; cbn; congruence. Qed.

  Lemma tape_local_right (x : sig) (xs : list sig) (t : tape sig) :
    tape_local t = x :: xs -> right t = xs.
  Proof. destruct t eqn:E; cbn; congruence. Qed.

  Lemma tape_local_l_left (x : sig) (xs : list sig) (t : tape sig) :
    tape_local_l t = x :: xs -> left t = xs.
  Proof. destruct t eqn:E; cbn; congruence. Qed.

  Lemma tape_local_cons_iff (t : tape sig) (x : sig) (xs : list sig) :
    tape_local t = x :: xs <-> current t = Some x /\ right t = xs.
  Proof.
    split; intros H.
    - destruct t; cbn in *; inv H. eauto.
    - destruct t; cbn in *; inv H; inv H0. eauto.
  Qed.

  Lemma tape_local_l_cons_iff (t : tape sig) (x : sig) (xs : list sig) :
    tape_local_l t = x :: xs <-> current t = Some x /\ left t = xs.
  Proof.
    split; intros H.
    - destruct t; cbn in *; inv H. eauto.
    - destruct t; cbn in *; inv H; inv H0. eauto.
  Qed.

  Lemma tape_local_nil (t : tape sig) :
    tape_local t = [] <-> current t = None.
  Proof.
    destruct t; cbn; intuition; auto; congruence.
  Qed.

  Lemma tape_local_move_right (t : tape sig) (x : sig) (xs : list sig) :
    tape_local t = x :: xs -> tape_local (tape_move_right t) = xs.
  Proof.
    intro H. destruct t eqn:E; cbn in *; try congruence.
    inv H. destruct xs; cbn; auto.
  Qed.

  Lemma tape_local_l_move_left (t : tape sig) (x : sig) (xs : list sig) :
    tape_local_l t = x :: xs -> tape_local_l (tape_move_left t) = xs.
  Proof.
    intro H. destruct t eqn:E; cbn in *; try congruence.
    inv H. destruct xs; cbn; auto.
  Qed.

  Lemma tape_left_move_right (t : tape sig) (x : sig) :
    current t = Some x -> left (tape_move_right t) = x :: left t.
  Proof. intros H. destruct t; cbn in *; try congruence. inv H. destruct l0; cbn; reflexivity. Qed.

  Lemma tape_right_move_left (t : tape sig) (x : sig) :
    current t = Some x -> right (tape_move_left t) = x :: right t.
  Proof. intros H. destruct t; cbn in *; try congruence. inv H. destruct l; cbn; reflexivity. Qed.

  Lemma midtape_tape_local_cons t r2 x :
    tape_local t = x :: r2 <-> t = midtape (left t) x r2.
  Proof.
    split.
    - intros H1. destruct t; cbn in *; congruence.
    - intros H1. destruct t; cbn in *; inv H1. auto.
  Qed.

  Lemma midtape_tape_local_cons_left t r1 r2 x :
    left t = r1 /\ tape_local t = x :: r2 <-> t = midtape r1 x r2.
  Proof. rewrite midtape_tape_local_cons. intuition subst; cbn; auto. Qed.

  Lemma midtape_tape_local_l_cons t r1 x :
    tape_local_l t = x :: r1 <-> t = midtape r1 x (right t).
  Proof.
    split.
    - intros H1. destruct t; cbn in *; congruence.
    - intros H1. destruct t; cbn in *; inv H1. auto.
  Qed.

  Lemma midtape_tape_local_l_cons_right t r1 r2 x :
    tape_local_l t = x :: r1 /\ right t = r2 <-> t = midtape r1 x r2.
  Proof. rewrite midtape_tape_local_l_cons. intuition subst; cbn; auto. Qed.

End Tape_Local.

#[export] Hint Rewrite tape_local_mirror  : tape.
#[export] Hint Rewrite tape_local_mirror' : tape.
#[export] Hint Rewrite tape_local_current_cons using auto : tape.
#[export] Hint Rewrite tape_local_l_current_cons using auto : tape.
#[export] Hint Rewrite tape_local_right        using auto : tape.
#[export] Hint Rewrite tape_local_l_left        using auto : tape.
#[export] Hint Rewrite tape_left_move_right    using auto : tape.
#[export] Hint Rewrite tape_right_move_left    using auto : tape.

(* ** Mapping tapes *)

(* Apply a function to each symbol on the tape *)
Section MapTape.
  Variable sig tau : Type.
  Variable g : tau -> sig.

  Definition mapTape : tape tau -> tape sig.
  Proof using g.
    destruct 1 eqn:E1.
    - apply niltape.
    - apply leftof.
      + apply (g t).
      + apply (List.map g l).
    - apply rightof.
      + apply (g t).
      + apply (List.map g l).
    - apply midtape.
      + apply (List.map g l).
      + apply (g t).
      + apply (List.map g l0).
  Defined. (* because definition *)

  Definition mapTapes {n : nat} : Vector.t (tape tau) n -> Vector.t (tape sig) n := Vector.map mapTape.

  (* Correctness of mapTape *)

  Lemma mapTape_current t :
    current (mapTape t) = map_opt g (current t).
  Proof. destruct t; cbn; reflexivity. Qed.

  Lemma mapTape_left t :
    left (mapTape t) = List.map g (left t).
  Proof. destruct t; cbn; reflexivity. Qed.

  Lemma mapTape_right t :
    right (mapTape t) = List.map g (right t).
  Proof. destruct t; cbn; reflexivity. Qed.

  Lemma mapTape_move_left t :
    tape_move_left (mapTape t) = mapTape (tape_move_left t).
  Proof. destruct t; cbn; auto. destruct l; cbn; auto. Qed.

  Lemma mapTape_move_right t :
    tape_move_right (mapTape t) = mapTape (tape_move_right t).
  Proof. destruct t; cbn; auto. destruct l0; cbn; auto. Qed.

End MapTape.

(* Rewriting Hints *)

#[export] Hint Rewrite mapTape_current    : tape.
#[export] Hint Rewrite mapTape_left       : tape.
#[export] Hint Rewrite mapTape_right      : tape.
#[export] Hint Rewrite mapTape_move_left  : tape.
#[export] Hint Rewrite mapTape_move_right : tape.
(* Hint Rewrite mapTapes_nth       : tape. *)
#[export] Hint Unfold mapTapes : tape.

Lemma mapTape_mapTape (sig tau gamma : Type) (f : sig -> tau) (g : tau -> gamma) (t : tape sig) :
  mapTape g (mapTape f t) = mapTape (fun x => g (f x)) t.
Proof. destruct t; cbn; auto; try simpl_tape; now rewrite !map_map. Qed.

Lemma mapTape_ext (sig tau : Type) (f g : sig -> tau) (t : tape sig) :
  (forall a, f a = g a) -> mapTape f t = mapTape g t.
Proof. intros H. destruct t; cbn; auto; simpl_tape; rewrite H; f_equal; eapply map_ext; eauto. Qed.

Lemma mapTape_id (sig : Type) (t : tape sig) :
  mapTape (fun x => x) t = t.
Proof. destruct t; cbn; auto; f_equal; apply map_id. Qed.
#[export] Hint Rewrite mapTape_mapTape : tape.
#[export] Hint Rewrite mapTape_id : tape.

Lemma mapTape_local (sig tau : Type) (f : sig -> tau) t :
  tape_local (mapTape f t) = List.map f (tape_local t).
Proof. destruct t; cbn; reflexivity. Qed.
#[export] Hint Rewrite mapTape_local : tape.

(* ** Lemmas about [tape_move_left'] and [tape_move_right'] *)
Section MatchTapes.
  Variable sig : Type.

  (* Left movement *)

  Lemma tape_left_move_left' ls (x : sig) rs :
    left (tape_move_left' ls x rs) = tl ls.
  Proof. now destruct ls; cbn. Qed.

  Lemma tape_left_move_left (t : tape sig) :
    left (tape_move_left t) = tl (left t).
  Proof. destruct t; cbn; auto. apply tape_left_move_left'. Qed.

  Lemma tape_left_move_right' ls (x : sig) rs :
    left (tape_move_right' ls x rs) = x :: ls.
  Proof. destruct rs; cbn; reflexivity. Qed.

  Lemma tape_right_move_left' ls (x : sig) rs :
    right (tape_move_left' ls x rs) = x :: rs.
  Proof. destruct ls; cbn; reflexivity. Qed.

  Lemma tape_local_l_move_left' rs (x : sig) ls :
    tape_local_l (tape_move_left' rs x ls) = rs.
  Proof. destruct rs; cbn; reflexivity. Qed.

  Lemma mirror_tape_move_left' rs (x : sig) ls :
    mirror_tape (tape_move_left' rs x ls) = tape_move_right' ls x rs.
  Proof. now destruct rs; cbn. Qed.

  (* Right movement *)

  Lemma tape_right_move_right' ls (x : sig) rs :
    right (tape_move_right' ls x rs) = tl rs.
  Proof. now destruct rs; cbn. Qed.

  Lemma tape_right_move_right (t : tape sig) :
    right (tape_move_right t) = tl (right t).
  Proof. destruct t; cbn; auto. apply tape_right_move_right'. Qed.

  Lemma tape_local_move_right' rs (x : sig) ls :
    tape_local (tape_move_right' rs x ls) = ls.
  Proof. destruct ls; cbn; reflexivity. Qed.

  Lemma mirror_tape_move_right' rs (x : sig) ls :
    mirror_tape (tape_move_right' rs x ls) = tape_move_left' ls x rs.
  Proof. now destruct ls; cbn. Qed.

  Lemma tape_move_niltape (m : move) :
    tape_move (niltape sig) m = niltape sig.
  Proof. now destruct m. Qed.

  Lemma tape_write_left (t : tape sig) s :
    left (tape_write t s) = left t.
  Proof. destruct s; auto. Qed.

  Lemma tape_write_right (t : tape sig) s :
    right (tape_write t s) = right t.
  Proof. destruct s; auto. Qed.

End MatchTapes.

#[export] Hint Rewrite tape_left_move_left' : tape.
#[export] Hint Rewrite tape_left_move_left : tape.
#[export] Hint Rewrite tape_left_move_right' : tape.
#[export] Hint Rewrite tape_right_move_left' : tape.
#[export] Hint Rewrite tape_local_l_move_left' : tape.
#[export] Hint Rewrite mirror_tape_move_left' : tape.

#[export] Hint Rewrite tape_right_move_right' : tape.
#[export] Hint Rewrite tape_right_move_right : tape.
#[export] Hint Rewrite tape_right_move_left' : tape.
#[export] Hint Rewrite tape_right_move_right' : tape.
#[export] Hint Rewrite tape_local_move_right' : tape.
#[export] Hint Rewrite mirror_tape_move_right' : tape.

#[export] Hint Rewrite tape_move_niltape tape_write_left tape_write_right : tape.

(* ** Definition of Multi-Tape Turing Machines *)
Section Semantics.

  Variable sig : finType.

  Notation TM := (TM sig).
  (* Labelled Multi-Tape Turing Machines *)
  Definition pTM (F: Type) (n:nat) := { M : TM n & state M -> F }.

  (* *** Configurations of TMs *)

  Record mconfig (state:finType) (n:nat): Type :=
    mk_mconfig
      {
        cstate : state;
        ctapes : tapes sig n
      }.

  (* *** Machine execution *)

  Definition step {n} (M:TM n) : mconfig (state M) n -> mconfig (state M) n :=
    fun c =>
      let (news,actions) := trans (cstate c, current_chars  (ctapes c)) in
      mk_mconfig news (doAct_multi (ctapes c) actions).

  Definition haltConf {n} (M : TM n) : mconfig (state M) n -> bool := fun c => halt (cstate c).

  (* Run the machine i steps until it halts *)
  Definition loopM n (M : TM n) := loop (@step _ M) (@haltConf _ M).

  (* Initial configuration *)
  Definition initc n (M : TM n) tapes :=
    mk_mconfig (n := n) (@start _ n M) tapes.

  (* *** Realisation *)

  (* Parametrised relations *)
  Definition pRel (sig : Type) (F: Type) (n : nat) := Rel (tapes sig n) (F * tapes sig n).

  (* A (labelled) machine [M] realises a (labelled) relation [R], if: for every tape vectors [t], if [M] with [t] terminates in a configuration [c], then [R (t), (projT2 M (cstate c), ctapes c)]. That means that the pair of the input tape vectors, the labelof the state in that the machine terminated, and the output tape, must be in the relation [R]. *)

  Definition Realise n F (pM : pTM n F) (R : pRel sig n F) :=
    forall t k outc, loopM (initc (projT1 pM) t) k = Some outc -> R t (projT2 pM (cstate outc), ctapes outc).

  Notation "M '⊨' R" := (Realise M R) (no associativity, at level 30, format "M  '⊨'  R").

  (* Realisation is monotone *)
  Lemma Realise_monotone n (F : Type) (pM : pTM F n) R R' :
    pM ⊨ R' -> R' <<=2 R -> pM ⊨ R.
  Proof. firstorder. Qed.

  (* *** Termination/Runtime *)

  (* A machine is said to "terminate in" a relation [T : Rel (tapes sig n) nat], if for every pair of input tape vectors [t] and step numbers [k] such that T t k, there exists an output configuration [cout] that [M] reaches from [t] in [k] steps. *)

  Definition tRel sig n := Rel (tapes sig n) nat.

  Definition TerminatesIn {n : nat} (M : TM n) (T : tRel sig n) :=
    forall tin k, T tin k -> exists conf, loopM (initc M tin) k = Some conf.

  Arguments TerminatesIn { _ } _.
  Notation "M ↓ T" := (TerminatesIn M T) (no associativity, at level 60, format "M  '↓'  T").

  (* Termination is anti-monotone *)
  Lemma TerminatesIn_monotone {n : nat} (M : TM n) (T T' : tRel sig n) :
    M ↓ T' -> (T <<=2 T') -> M ↓ T.
  Proof. intros H1 H2. firstorder. Qed.

  Lemma TerminatesIn_extend {n : nat} (M : TM n) (T : tRel sig n) :
    M ↓ T ->
    M ↓ (fun tin k => exists k', k' <= k /\ T tin k').
  Proof.
    intros HTerm. hnf in *. intros tin k. intros (k'&Hk'&HT).
    specialize HTerm with (1 := HT) as (oconf&HLoop).
    exists oconf. eapply loop_monotone; eauto.
  Qed.

  (* Realisation plus termination in constant time *)
  Definition RealiseIn n (F : Type) (pM : pTM F n) (R : pRel sig F n) (k : nat) :=
    forall input, exists outc, loopM (initc (projT1 pM) input) k = Some outc /\ R input ((projT2 pM (cstate outc)), ctapes outc).
  Notation "M '⊨c(' k ')' R" := (RealiseIn M R k) (no associativity, at level 45, format "M  '⊨c(' k ')'  R").

  Lemma RealiseIn_monotone n (F : Type) (pM : pTM F n) (R R' : pRel sig F n) k k' :
    pM ⊨c(k') R' -> k' <= k -> R' <<=2 R -> pM ⊨c(k) R.
  Proof.
    unfold RealiseIn. intros H1 H2 H3 input.
    specialize (H1 input) as (outc & H1). exists outc.
    split.
    - unfold loopM. eapply loop_monotone; eauto. intuition.
    - intuition.
  Qed.

  Lemma RealiseIn_split n (F : Type) (pM : pTM F n) R1 R2 (k : nat) :
    pM ⊨c(k) R1 /\ pM ⊨c(k) R2 <-> pM ⊨c(k) R1 ∩ R2.
  Proof.
    split; swap 1 2; [ intros H | intros (H1&H2)].
    - firstorder eauto.
    - repeat intros ?. specialize (H1 input) as (outc &H1&H1').
      specialize (H2 input) as (outc2&H2&H2').
      pose proof loop_injective H1 H2 as <-.
      exists outc. split; hnf; eauto.
  Qed.

  Lemma Realise_total n (F : Type) (pM : { M : TM n & state M -> F }) R k :
    pM ⊨ R /\ projT1 pM ↓ (fun _ i => k <= i) <-> pM ⊨c(k) R.
  Proof.
    split.
    - intros (HR & Ht) t. edestruct (Ht t k); [reflexivity|eauto].
    - intros H.
      split.
      + intros t i cout Hc.
        destruct (H t) as (? & ? & ?).
        replace cout with x.
        * eassumption.
        * unfold loopM in *.
          eapply loop_injective; eauto.
      + intros t i Hi.
        edestruct (H t) as (? & ? & ?).
        exists x. eapply loop_monotone; eauto.
  Qed.

  Lemma RealiseIn_Realise n (F : Type) (pM : pTM F n) R k :
    pM ⊨c(k) R -> pM ⊨ R.
  Proof. now intros (?&?) % Realise_total. Qed.

  Lemma RealiseIn_TerminatesIn n (F : Type) (pM : { M : TM n & state M -> F }) R k :
    pM ⊨c(k) R -> projT1 pM ↓ (fun tin l => k <= l).
  Proof.
    intros HRel. hnf. intros tin l HSteps. hnf in HRel. specialize (HRel tin) as (outc&HLoop&Rloop).
    exists outc. eapply loop_monotone; eauto.
  Qed.

  Lemma Realise_strengthen n (F : Type) (pM : pTM F n) R1 R2 :
    Realise pM R2 -> Realise pM R1 -> Realise pM (R1 ∩ R2).
  Proof.
    intros HwR HR t. firstorder.
  Qed.

  (* *** Canonical relations *)

  Section Canonical_Correctness.
    Variable (n : nat).
    Variable (F : Type).
    Variable (pM : pTM F n).

    Definition Canonical_Rel : pRel sig F n :=
      fun t1 '(y, t2) =>
        exists outc k, loopM (M := projT1 pM) (initc (projT1 pM) t1) k = Some outc /\
                  ctapes outc = t2 /\ projT2 pM (cstate outc) = y.

    Fact Canonical_Realise :
      pM ⊨ Canonical_Rel.
    Proof. hnf. firstorder eauto. Qed.

    Lemma R_canonical_functional : functional Canonical_Rel.
    Proof.
      hnf. intros x (y1&z1) (y2&z2) (c1&k1&H1&<-&H1') (c2&k2&H2&<-&H2').
      pose proof loop_injective H1 H2 as ->. congruence.
    Qed.

  End Canonical_Correctness.

  Section Canonical_Termination.
    Variable (n : nat).
    Variable (M : TM n).

    Definition Canonical_T : tRel sig n :=
      fun t k => exists outc, loopM (M := M) (initc M t) k = Some outc.

    Lemma Canonical_TerminatesIn :
      M ↓ Canonical_T.
    Proof. firstorder. Qed.

  End Canonical_Termination.

End Semantics.

(* Notation for parametrised Turing machines *)
Notation "'(' M ';' labelling ')'" := (existT (fun x => state x -> _) M labelling).

(* Notations for semantic of concrete Turing machines *)
Notation "M '⊨' R" := (Realise M R) (no associativity, at level 60, format "M  '⊨'  R").
Notation "M '⊨c(' k ')' R" := (RealiseIn M R k) (no associativity, at level 45, format "M  '⊨c(' k ')'  R").
Notation "M '↓' t" := (TerminatesIn M t) (no associativity, at level 60, format "M  '↓'  t").

(* [inhabitedC] instances for state and labels *)

#[export] Instance inhabited_move : inhabitedC move := ltac:(repeat constructor).

#[export] Instance inhabited_TM_Q (n : nat) (sig : finType) (M : TM sig n) : inhabitedC (state M).
Proof. constructor. apply start. Qed.

Lemma inhabited_pTM_lab (n : nat) (sig : finType) (F : Type) (pM : pTM sig F n) : inhabitedC F.
Proof. constructor. apply (projT2 pM). apply default. Qed.

#[export] Hint Extern 4 => once lazymatch goal with
                | [ pM : pTM ?sig ?F ?n |- inhabitedC ?F ] => apply (inhabited_pTM_lab pM)
                end : typeclass_instances.

(* ** Automation of the generation of relations *)
(* Alternative to the the smpl-based tactic databases *)
Create HintDb TMdb discriminated.

(* ** TM evaluation and loop is equivalent  *)

Lemma Vector_map2_ext {A B C} (f g : A -> B -> C) n (v1 : Vector.t A n) (v2 : Vector.t B n) :
  (forall a b, f a b = g a b) ->
  Vector.map2 f v1 v2 = Vector.map2 g v1 v2.
Proof.
  intros H.
  pattern n, v1, v2; revert n v1 v2.
  eapply Vector.rect2.
  - reflexivity.
  - intros n v1 v2 IH a b. cbn. now rewrite H, IH.
Qed.

Lemma TM_eval_iff (Σ : finType) n (M : TM Σ n) q t q' t' :
  TM.eval M q t q' t' <-> exists n, loopM (M := M) (mk_mconfig q t) n = Some (mk_mconfig q' t').
Proof.
  split.
  - induction 1 as [ | q t q' a q'' t' H0 H1 H2 [m IH]].
    + exists 0. cbn. unfold haltConf. cbn. now rewrite H.
    + exists (S m). cbn. unfold haltConf. cbn. rewrite H0.
      unfold step. cbn. unfold current_chars.
      rewrite H1. erewrite Vector_map2_ext.
      * now rewrite IH.
      * intros [] [[] []]; reflexivity.
  - intros [k H].
    induction k in q, t, H, q', t' |- *; cbn in H; unfold haltConf in H; cbn in H.
    + destruct halt eqn:E; inv H. now econstructor.
    + destruct halt eqn:E; inv H.
      * now econstructor.
      * unfold step in H1. cbn in H1.
        destruct trans eqn:E2.
        econstructor; [ eassumption .. | ].
        eapply IHk. erewrite Vector_map2_ext.
        -- now rewrite H1.
        -- intros [] [[] []]; reflexivity.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Theory.Naturality.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Transform.

Context {C : Category}.
Context {D : Category}.
Context {F : C ⟶ D}.
Context {G : C ⟶ D}.

Class Transform := {
transform {x} : F x ~> G x;

naturality {x y} (f : x ~> y) :
fmap[G] f ∘ transform ≈ transform ∘ fmap[F] f;

naturality_sym {x y} (f : x ~> y) :
transform ∘ fmap[F] f ≈ fmap[G] f ∘ transform
}.

Global Program Instance Transform_Setoid : Setoid Transform.

End Transform.

Arguments transform {_ _ _ _} _ _.
Arguments naturality
{_ _ _ _ _ _ _ _}, {_ _ _ _} _ {_ _ _}, {_ _ _ _} _ _ _ _.
Arguments naturality_sym
{_ _ _ _ _ _ _ _}, {_ _ _ _} _ {_ _ _}, {_ _ _ _} _ _ _ _.

Bind Scope transform_scope with Transform.
Delimit Scope transform_type_scope with transform_type.
Delimit Scope transform_scope with transform.
Open Scope transform_type_scope.
Open Scope transform_scope.

Notation "F ⟹ G" := (@Transform _ _ F%functor G%functor)
(at level 90, right associativity) : transform_type_scope.

Notation "transform[ F ]" := (@transform _ _ _ _ F%transform)
(at level 9, only parsing, format "transform[ F ]") : morphism_scope.
Notation "naturality[ F ]" := (@naturality _ _ _ _ F%transform)
(at level 9, only parsing, format "naturality[ F ]") : morphism_scope.

Coercion transform : Transform >-> Funclass.

Ltac transform :=
unshelve (refine {| transform := _ |}; simpl; intros).

Corollary fun_id_left {C D : Category} {F : C ⟶ D} : Id ◯ F ⟹ F.
Proof. hammer_hook "Transformation" "Transformation.fun_id_left". transform; simpl; intros; cat. Qed.

Corollary fun_id_left_sym {C D : Category} {F : C ⟶ D} : F ⟹ Id ◯ F.
Proof. hammer_hook "Transformation" "Transformation.fun_id_left_sym". transform; simpl; intros; cat. Qed.

Corollary fun_id_right {C D : Category} {F : C ⟶ D} : F ◯ Id ⟹ F.
Proof. hammer_hook "Transformation" "Transformation.fun_id_right". transform; simpl; intros; cat. Qed.

Corollary fun_id_right_sym {C D : Category} {F : C ⟶ D} : F ⟹ F ◯ Id.
Proof. hammer_hook "Transformation" "Transformation.fun_id_right_sym". transform; simpl; intros; cat. Qed.

Corollary fun_comp_assoc {C D E B : Category}
{F : E ⟶ B} {G : D ⟶ E} {H : C ⟶ D} : F ◯ (G ◯ H) ⟹ (F ◯ G) ◯ H.
Proof. hammer_hook "Transformation" "Transformation.fun_comp_assoc". transform; simpl; intros; cat. Qed.

Corollary fun_comp_assoc_sym {C D E B : Category}
{F : E ⟶ B} {G : D ⟶ E} {H : C ⟶ D} : (F ◯ G) ◯ H ⟹ F ◯ (G ◯ H).
Proof. hammer_hook "Transformation" "Transformation.fun_comp_assoc_sym". transform; simpl; intros; cat. Qed.

Program Definition whisker_right {C D : Category} {F G : C ⟶ D} `(N : F ⟹ G)
{E : Category} (X : E ⟶ C) : F ◯ X ⟹ G ◯ X := {|
transform := fun x => N (X x);

naturality     := fun _ _ _ => naturality;
naturality_sym := fun _ _ _ => naturality_sym
|}.

Notation "N ⊲ F" := (whisker_right N F) (at level 10).

Program Definition whisker_left {C D : Category}
{E : Category} (X : D ⟶ E)
{F G : C ⟶ D} `(N : F ⟹ G) : X ◯ F ⟹ X ◯ G := {|
transform := fun x => fmap[X] (N x)
|}.
Next Obligation.
simpl; rewrite <- !fmap_comp;
apply fmap_respects, naturality.
Qed.
Next Obligation.
simpl; rewrite <- !fmap_comp;
apply fmap_respects, naturality_sym.
Qed.

Notation "F ⊳ N" := (whisker_left F N) (at level 10).


(*===========================================================================
    Partial functions, represented as X -> option Y
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool.
Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms.

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

Section PFun.

  Variable X Y : Type.

  (* Asymmetric combination of partial functions, right-hand operand taking priority *)
  Definition extend (f1 f2: X -> option Y) :=
  fun x => if f2 x is Some z then Some z else f1 x.

  Definition includedIn (f1 f2: X -> option Y) :=
  forall x y, f1 x = Some y -> f2 x = Some y.

  Lemma includedIn_refl f : includedIn f f.
  Proof. rewrite /includedIn; intuition.
  Qed.

  Lemma includedIn_trans f1 f2 f3 : includedIn f1 f2 -> includedIn f2 f3 -> includedIn f1 f3.
  Proof.  rewrite /includedIn. move => H1 H2. move => x y.
  auto. Qed.

  Definition splitsAs (f f1 f2: X -> option Y) :=
  forall x,
  if f x is Some y
    then (f1 x = Some y /\ f2 x = None)
      \/ (f2 x = Some y /\ f1 x = None)
    else f1 x = None /\ f2 x = None.

  Lemma splitsAsExtend f f1 f2 : splitsAs f f1 f2 -> f =1 extend f1 f2.
  Proof. rewrite /extend /splitsAs. move => H. move => x.
  specialize (H x). case e: (f x) => [z |]; rewrite e in H.
  + destruct H; by rewrite (proj2 H) (proj1 H).
  + by rewrite (proj2 H) (proj1 H). Qed.

  Definition empFun : X -> option Y := fun _ => None.

  Lemma splitsAs_commutative f f1 f2 : splitsAs f f1 f2 -> splitsAs f f2 f1.
  Proof. rewrite /splitsAs. move => H x.
  specialize (H x). case e: (f x) => [y |]; rewrite e in H.
  case H; [by right | by left]. intuition.
  Qed.

  Lemma splitsAs_f_emp_g f g : splitsAs f empFun g -> f =1 g.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e: (f x) => [z |]; rewrite e in H; [by destruct H; destruct H | intuition].
  Qed.

  Lemma splitsAs_f_g_emp f g : splitsAs f g empFun -> f =1 g.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e: (f x) => [z |]; rewrite e in H; [by destruct H; destruct H | intuition].
  Qed.

  Lemma splitsAs_f_f_emp f : splitsAs f f empFun.
  Proof. move => x. case (f x); intuition. Qed.

  Lemma splitsAs_f_emp_f f : splitsAs f empFun f.
  Proof. move => x. case (f x); intuition. Qed.

  Lemma splitsAs_f_g_f f g : splitsAs f g f -> g =1 empFun.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e:(f x) => [y |]; rewrite e in H. by elim H; intuition. by intuition.
  Qed.

  Lemma splitsAs_f_f_g f g: splitsAs f f g -> g =1 empFun.
  Proof. rewrite /splitsAs. move => H x. specialize (H x).
  case e:(f x) => [y |]; rewrite e in H. by elim H; intuition. by intuition.
  Qed.

  Lemma splitsAs_functional f g h i : splitsAs h f g -> splitsAs i f g -> h =1 i.
  Proof.
    rewrite /splitsAs. move => Hh Hi x.
    specialize (Hh x); specialize (Hi x).
    case eh:(h x) => [y |]; rewrite eh in Hh;
    case ei:(i x) => [z |]; rewrite ei in Hi;
    intuition congruence.
  Qed.

  Lemma splitsAs_functionalArg s s1 s2 s3 : splitsAs s s2 s1 -> splitsAs s s3 s1 -> s2 =1 s3.
  Proof.
    rewrite /splitsAs. move => H1 H2 x.
    specialize (H1 x). specialize (H2 x).
    case E1: (s x) => [y |]. rewrite E1 in H1, H2.
      destruct H1. destruct H as [Ha Hb].
      destruct H2; destruct H; congruence.
      destruct H2; destruct H; destruct H0; congruence.
    rewrite E1 in H1, H2. destruct H1; destruct H2; congruence.
  Qed.

  Lemma splitsAs_eq f g h i : splitsAs h f g -> h =1 i -> splitsAs i f g.
  Proof.
    rewrite /splitsAs. move => H heqi x.
    specialize (H x).
    case e:(h x) => [y |]; rewrite e in H;
    rewrite heqi in e; rewrite e; intuition.
  Qed.

  Lemma splitsAs_eq_arg f g h i : splitsAs i f g -> f =1 h -> splitsAs i h g.
  Proof.
    rewrite /splitsAs. move => H feqh x.
    specialize (H x).
    case e:(i x) => [y |]; rewrite e in H; intuition congruence.
  Qed.

  Lemma splitsAsIncludedInSplitsAs f f1 f2 g :
    let g2 :=fun x => if f1 x is Some _ then None else if f2 x is Some y then Some y else g x
    in
    splitsAs f f1 f2 -> includedIn f g ->
    splitsAs g f1 g2 /\ includedIn f2 g2.
  Proof. move => g2 fsplit fg.
  rewrite /splitsAs in fsplit. rewrite /includedIn in fg.
  split.
  rewrite /splitsAs => x.
  specialize (fsplit x).
  case E: (f x) => [z |].
  rewrite E in fsplit. specialize (fg _ _ E). rewrite fg.
    destruct fsplit; destruct H as [H1 H2].
    + left. by rewrite /g2 H2 H1.
    + right. by rewrite /g2 H2 H1.
  rewrite E in fsplit.
  destruct fsplit as [H1 H2]. case E2: (g x) => [y |]. right. by rewrite /g2 H1 H2.
  by rewrite /g2 H1 H2.

  rewrite /includedIn => x y E.
  case E2: (f x) => [z |].
  specialize (fg _ _ E2). specialize (fsplit x). rewrite E2 in fsplit.
  destruct fsplit; destruct H as [H1 H2].
  + congruence. rewrite /g2 H2 H1. congruence.
  + specialize (fsplit x). rewrite E2 in fsplit. destruct fsplit as [H1 H2].
  congruence.
  Qed.

  Lemma splitsAs_associative f f1 f2 f3 f4 :
    let f5 := fun x => if f4 x is Some y then Some y else f1 x in
    splitsAs f f1 f2 -> splitsAs f2 f3 f4 ->
    splitsAs f f3 f5 /\ splitsAs f5 f1 f4.
  Proof. rewrite /splitsAs. move => H1 H2.
  split.
  * move => x. specialize (H1 x). specialize (H2 x).
  case e: (f x) => [y |].
  + rewrite e in H1.
    case e': (f2 x) => [y' |].
    - rewrite e' in H2.
      destruct H1. destruct H. congruence.
      destruct H2. destruct H. destruct H0.
      rewrite H2. left. rewrite H in e'. rewrite e'. done.
      destruct H. destruct H0.
      rewrite H2. right. rewrite H0. rewrite H in e'. rewrite e'. done.
    - rewrite e' in H2. destruct H2. destruct H1. right. rewrite H0. intuition.
      destruct H1. rewrite e' in H1. done.
  + rewrite e in H1. destruct H1. rewrite H0 in H2. destruct H2. rewrite H2. done.
  * move => x. specialize (H1 x). specialize (H2 x).
  case e: (f x) => [y |]. rewrite e in H1.
  case e': (f2 x) => [y' |]. rewrite e' in H2.
  destruct H2. destruct H. rewrite H0.
  destruct H1. destruct H1. rewrite H1. left. done.
  destruct H1. rewrite H2. done.
  destruct H. rewrite H.
  destruct H1. destruct H1. rewrite H2 in e'. done. right. destruct H1. done.
  rewrite e' in H2. destruct H2. rewrite H0.
  destruct H1. destruct H1. rewrite H1. left. done.
  destruct H1. rewrite H2. done.
  rewrite e in H1. destruct H1. rewrite H0 in H2. destruct H2. rewrite H2.
  rewrite H. done.
  Qed.

  Lemma splitsAsIncludes f f1 f2 : splitsAs f f1 f2 -> includedIn f1 f /\ includedIn f2 f.
  Proof. move => S. split; move => x y H; specialize (S x);
  case e: (f x) => [y' | ]; rewrite e in S; intuition; congruence.
  Qed.

  Lemma splitsAsExtendL s s1 s2 s3 s4 : splitsAs s s1 s2 -> splitsAs s2 s3 s4 ->
  splitsAs s (extend s1 s3) s4.
  Proof. move => H1 H2 x.
  rewrite /splitsAs in H1, H2. specialize (H1 x). specialize (H2 x). rewrite /extend.
  case E1: (s x) => [y |]; rewrite E1 in H1.
  + case E2: (s2 x) => [z |]; rewrite E2 in H2.
    - case H2 => {H2} H2'. destruct H2' as [H2a H2b].
      case H1 => {H1} H1'; destruct H1' as [H1a H1b]. congruence.
      left. rewrite H2a. split;  congruence.
    - case H1 => {H1} H1'; destruct H1' as [H1a H1b]. congruence.
      destruct H2' as [H2a H2b]. rewrite H2b. right. split; congruence.
    destruct H2 as [H2a H2b]. rewrite H2a. left.
    case H1 => {H1} H1'; destruct H1' as [H1a H1b]. done. congruence.
  + case E2: (s2 x) => [z |]; rewrite E2 in H2.
    destruct H1 as [H1a H1b]. rewrite H1a. rewrite H1b in E2. done.
    destruct H2 as [H2a H2b]. rewrite H2a. intuition.
  Qed.

  Global Instance eqfun_equivalence {A B} : Equivalence (@eqfun A B).
  Proof.
    split.
    + intros a x; reflexivity.
    + intros a b H x; symmetry; apply H.
    + intros a b c H1 H2 x; transitivity (b x); [apply H1 | apply H2].
  Qed.

  Global Instance splitsAs_m :
    (Proper (@eqfun (option Y) X ==> @eqfun (option Y) X ==> @eqfun (option Y) X ==> iff)) splitsAs.
  Proof.
    move => a b aeqb c d ceqd e f eeqf; split.
    + move => H.
      eapply splitsAs_eq; [|eassumption].
      eapply splitsAs_eq_arg; [|eassumption].
      apply splitsAs_commutative.
      eapply splitsAs_eq_arg; [|eassumption].
      apply splitsAs_commutative; assumption.
    + move => H.
      eapply splitsAs_eq; [|symmetry; eassumption].
      eapply splitsAs_eq_arg; [|symmetry; eassumption].
      apply splitsAs_commutative.
      eapply splitsAs_eq_arg; [|symmetry; eassumption].
      apply splitsAs_commutative; assumption.
  Qed.

End PFun.

  Hint Resolve splitsAsIncludes.
  Hint Resolve includedIn_refl.