Require Import Coqlib.
Require Import Maps.

Require Import Integers.
Open Scope Z_scope.
Import ListNotations.

Set Asymmetric Patterns.

Require Import state.
Require Import language.

Require Import LibTactics.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope nat.

(*+ Assertion Language +*)
(* Syntax of assertion language *)
Inductive asrt : Type :=
| Aemp : asrt
| Amapsto : Address -> Word -> asrt
| Aaexpevl : AddrExp -> Address -> asrt
| Aoexpevl : OpExp -> Word -> asrt
| Areg : RegName -> Word -> asrt
| Aregdly : nat -> SpReg -> Word -> asrt
| Apure : Prop -> asrt
| Aframe : Word -> FrameList -> asrt
| Atrue : asrt
| Afalse : asrt
| Aconj : asrt -> asrt -> asrt
| Adisj : asrt -> asrt -> asrt
| Astar : asrt -> asrt -> asrt
| Aforall (ty : Type) (P : ty -> asrt)
| Aexists (ty : Type) (P : ty -> asrt).

Notation "'[|' P '|]'" := (Apure P) (at level 29, no associativity).
Infix "**" := Astar (at level 30, right associativity).
Infix "//\\" := Aconj (at level 31, right associativity).
Infix "\\//" := Adisj (at level 32, right associativity).
Notation "l |-> v" := (Amapsto l v) (at level 20).
Notation "aexp '==ₓ' addr" := (Aaexpevl aexp addr) (at level 20).
Notation "oexp '==ₑ' v" := (Aoexpevl oexp v) (at level 20).
Notation "rn |=> v" := (Areg rn v) (at level 20).
Notation "n '@' rn |==> v" := (Aregdly n rn v) (at level 20).

Notation "'EX' x , p " :=
  (Aexists (fun x => p))
    (at level 32, x ident, right associativity).
Notation "'EX' x : t , p " :=
  (Aexists (fun x : t => p))
    (at level 32, x ident, right associativity).
Notation "'EX' x .. y , p" :=
  (Aexists (fun x => .. (Aexists (fun y => p)) ..))
    (at level 32, x binder, right associativity).

Notation "'FORALL' x , p " :=
  (Aforall (fun x => p))
    (at level 32, x ident, right associativity).
Notation "'FORALL' x : t , p " :=
  (Aforall (fun x : t => p))
    (at level 32, x ident, right associativity).
Notation "'FORALL' x .. y , p" :=
  (Aforall (fun x => .. (Aforall (fun y => p)) ..))
    (at level 32, x binder, right associativity).

Notation "'{|' id , F '|}'" := (Aframe id F) (at level 20).

Definition getmem (s : State) :=
  match s with
  | (M, Q, D) => M
  end.

Definition getregs (s : State) :=
  match s with
  | (M, (R, F), D) => R
  end.

Definition getdlyls (s : State) :=
  match s with
  | (M, (R, F), D) => D
  end.

Definition getframelst (s : State) :=
  match s with
  | (M, (R, F), D) => F
  end.

Definition regInDlyBuff (rn : RegName) (D : DelayList) :=
  match rn with
  | Rr rr => False
  | Rpsr rst => False
  | Rsp rsp => In rsp (getRegs D)
  end.

Lemma sep_reg_dec :
  forall (s s' : SpReg),
    {s = s'} + {s <> s'}.
Proof.
  intros.
  destruct s; destruct s'; eauto;
    try solve [right; intro; tryfalse].
  destruct a; destruct a0; eauto;
    try solve [right; intro; tryfalse].
Qed.

Fixpoint remove_one {A : Type} (eq_dec : forall (x y : A), {x = y} + {x <> y})
         (a : A) (l : list A) :=
  match l with
  | x :: l => if eq_dec a x then l else x :: remove_one eq_dec a l
  | nil => nil
  end.

Definition noDup (rn : SpReg) (l : list SpReg) : Prop :=
  ~ In rn (remove_one sep_reg_dec rn l).

Definition inDlyBuff (d : DelayItem) (D : DelayList) :=
  In d D /\ noDup (snd (fst d)) (getRegs D).

(* $ rn = v hold if the value v locates in memory with address R(rn) *)
Definition regSt (rn : RegName) (v : Word) (s : State) :=
  getregs s = RegMap.set rn (Some v) empR /\ getmem s = empM /\
  ~ (regInDlyBuff rn (getdlyls s)).

Fixpoint regdlySt (n : nat) (rsp : SpReg) (v : Word) (s : State) :=
  match n with
  | 0%nat => inDlyBuff (0, rsp, v) (getdlyls s)
  | (S n')%nat => inDlyBuff (n, rsp, v) (getdlyls s) \/ regdlySt n' rsp v s
  end.

(* S1 S2 can be union if their delaylist is same
and memory states and register state are disjoint *)
Definition state_union (s1 s2 s : State) :=
  match s1, s2 with
  | (M1, (R1, F1), D1), (M2, (R2, F2), D2) =>
    disjoint M1 M2 /\ disjoint R1 R2 /\
    s = (merge M1 M2, (merge R1 R2, F1), D1) /\ F1 = F2 /\ D1 = D2
  end.

(* semantics of assertion language *)
Fixpoint sat (s : State) (p : asrt) {struct p} : Prop :=
  match p with
  | Aemp => getmem s = empM /\ getregs s = empR
  | Amapsto l v => getmem s = MemMap.set l (Some v) empM /\
                  getregs s = empR /\ word_aligned l = true
  | Aaexpevl aexp addr => eval_addrexp (getregs s) aexp = Some addr /\
                          word_aligned addr = true
  | Aoexpevl oexp v => eval_opexp (getregs s) oexp = Some v
  | Areg rn v => regSt rn v s
  | Aregdly t rsp v =>
    exists v', getregs s = RegMap.set rsp (Some v') empR /\ getmem s = empM /\
          (regdlySt t rsp v s \/ regSt rsp v s)
  | Apure p => p /\ getmem s = empM /\ getregs s = empR
  | Aframe id F => regSt cwp id s /\ getframelst s = F
  | Atrue => True
  | Afalse => False
  | Aconj p1 p2 => sat s p1 /\ sat s p2
  | Adisj p1 p2 => sat s p1 \/ sat s p2
  | Astar p1 p2 =>
    exists s1 s2, state_union s1 s2 s /\ sat s1 p1 /\ sat s2 p2
  | Aforall t p' => forall (x : t), sat s (p' x)
  | Aexists t p' => exists (x : t), sat s (p' x)
  end.

Notation "s '|=' p" := (sat s p) (at level 33, no associativity).
Notation "p ==> q" :=
  (forall s, s |= p -> s |= q)
    (at level 33, right associativity).
Notation "p <==> q" :=
  (forall s, s |= p <-> s |= q)
    (at level 33, right associativity).

Definition OutRegs (fm : Frame) : asrt :=
  match fm with
  | consfm w0 w1 w2 w3 w4 w5 w6 w7 =>
    r8 |=> w0 ** r9 |=> w1 ** r10 |=> w2 ** r11 |=> w3 ** r12 |=> w4 **
       r13 |=> w5 ** r14 |=> w6 ** r15 |=> w7
  end.

Definition LocalRegs (fm : Frame) : asrt :=
  match fm with
  | consfm w0 w1 w2 w3 w4 w5 w6 w7 =>
    r16 |=> w0 ** r17 |=> w1 ** r18 |=> w2 ** r19 |=> w3 ** r20 |=> w4 **
        r21 |=> w5 ** r22 |=> w6 ** r23 |=> w7
  end.

Definition InRegs (fm : Frame) : asrt :=
  match fm with
  | consfm w0 w1 w2 w3 w4 w5 w6 w7 =>
    r24 |=> w0 ** r25 |=> w1 ** r26 |=> w2 ** r27 |=> w3 ** r28 |=> w4 **
        r29 |=> w5 ** r30 |=> w6 ** r31 |=> w7
  end.

Definition Regs (fm1 fm2 fm3 : Frame) : asrt :=
  OutRegs fm1 ** LocalRegs fm2 ** InRegs fm3.

Fixpoint DlyFrameFree (a : asrt) :=
  match a with
  | t @ rn |==> v => False
  | {| id, F |} => False
  | p //\\ q => DlyFrameFree p /\ DlyFrameFree q
  | p \\// q => DlyFrameFree p /\ DlyFrameFree q
  | p ** q => DlyFrameFree p /\ DlyFrameFree q
  | Aforall t p => forall x : t, DlyFrameFree (p x)
  | Aexists t p => forall x : t, DlyFrameFree (p x)
  | _ => True
  end.

(*+ Well-formed Instruction +*)
Inductive wf_ins : asrt -> ins -> asrt -> Prop :=
| ld_rule : forall p q aexp l v v' (rd : GenReg),
    p ==> aexp ==ₓ l ->
    p ==> l |-> v ** rd |=> v' ** q ->
    wf_ins p (ld aexp rd) (l |-> v ** rd |=> v ** q)

| st_rule : forall p aexp l v v1 (rs : GenReg),
    l |-> v  ** p ==> ((Or rs) ==ₑ v1 //\\ aexp ==ₓ l) ->
    wf_ins (l |-> v  ** p) (st rs aexp)
           (l |-> v1 ** p)

| add_rule : forall p q oexp (rs rd : GenReg) v1 v2 v,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> rd |=> v ** q ->
    wf_ins p (add rs oexp rd) (rd |=> (v1 +ᵢ v2) ** q)

| sub_rule : forall p q oexp (rs rd : GenReg) v1 v2 v,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> rd |=> v ** q ->
    wf_ins p (sub rs oexp rd) (rd |=> (v1 -ᵢ v2) ** q)

| subcc_rule : forall p q oexp (r1 r2 : GenReg) v1 v2 v vr vn vz,
    p ==> ((Or r1) ==ₑ v1 //\\ oexp ==ₑ v2) -> v = v1 -ᵢ v2 ->
    p ==> r2 |=> vr ** n |=> vn ** z |=> vz ** q ->
    wf_ins p (subcc r1 oexp r2)
           (r2 |=> v ** n |=> (get_range 31 31 v) ** z |=> (iszero v) ** q)

| and_rule : forall p q oexp (rs rd : GenReg) v1 v2 v,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> rd |=> v ** q ->
    wf_ins p (and rs oexp rd) (rd |=> (v1 &ᵢ v2) ** q)

| andcc_rule : forall p q oexp (r1 r2 : GenReg) v1 v2 v vr vn vz,
    p ==> ((Or r1) ==ₑ v1 //\\ oexp ==ₑ v2) -> v = v1 &ᵢ v2 ->
    p ==> r2 |=> vr ** n |=> vn ** z |=> vz ** q ->
    wf_ins p (andcc r1 oexp r2)
           (r2 |=> v ** n |=> (get_range 31 31 v) ** z |=> (iszero v) ** q)

| sll_rule : forall p q oexp (rs rd : GenReg) v1 v2 v,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> rd |=> v ** q ->
    wf_ins p (sll rs oexp rd) (rd |=> (v1 <<ᵢ (get_range 0 4 v2)) ** q)

| srl_rule : forall p q oexp (rs rd : GenReg) v1 v2 v,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> rd |=> v ** q ->
    wf_ins p (srl rs oexp rd) (rd |=> (v1 >>ᵢ (get_range 0 4 v2)) ** q)

| or_rule : forall p q oexp (rs rd : GenReg) v1 v2 v,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> rd |=> v ** q ->
    wf_ins p (or rs oexp rd) (rd |=> (v1 |ᵢ v2) ** q)

| set_rule : forall p q (rd : GenReg) w v,
    p ==> rd |=> v ** q ->
    wf_ins p (sett w rd) (rd |=> w ** q)

| nop_rule : forall p q,
    p ==> q ->
    wf_ins p nop q

| rd_rule : forall (rsp : SpReg) v v1 (r1 : GenReg) p,
    wf_ins (rsp |=> v ** r1 |=> v1 ** p) (rd rsp r1)
           (rsp |=> v ** r1 |=> v ** p)

| wr_rule : forall (rsp : SpReg) (rs : GenReg) p v v1 v2 oexp,
    rsp |=> v ** p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    wf_ins (rsp |=> v ** p) (wr rs oexp rsp)
           ((3 @ rsp |==> (set_spec_reg rsp (v1 xor v2))) ** p)

| getcwp_rule : forall p F p1 id v' (rd : GenReg),
    p ==> {| id, F |} ** rd |=> v' ** p1 ->
    wf_ins p (getcwp rd) ({| id, F |} ** rd |=> id ** p1)

| save_rule : forall p p1 q (rs rd : GenReg) id id' F fm1 fm2 fmo fml fmi v1 v2 v v' oexp,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> {| id, F ++ (fm1 :: fm2 :: nil) |} ** (Regs fmo fml fmi) ** p1 ->
    id' = pre_cwp id -> win_masked id' v = false ->
    {| id', fml :: fmi :: F |} ** (Regs fm1 fm2 fmo) ** p1 ==> rd |=> v' ** q ->
    wf_ins (Rwim |=> v ** p) (save rs oexp rd) (Rwim |=> v ** rd |=> v1 +ᵢ v2 ** q)

| restore_rule : forall p p1 q (rs rd : GenReg) id id' F fm1 fm2 fmo fml fmi v1 v2 v v' oexp,
    p ==> ((Or rs) ==ₑ v1 //\\ oexp ==ₑ v2) ->
    p ==> {| id, fm1 :: fm2 :: F |} ** (Regs fmo fml fmi) ** p1 ->
    id' = post_cwp id -> win_masked id' v = false ->
    {| id', F ++ (fmo :: fml :: nil)  |} ** (Regs fmi fm1 fm2) ** p1 ==> rd |=> v' ** q ->
    wf_ins (Rwim |=> v ** p) (restore rs oexp rd) (Rwim |=> v ** rd |=> v1 +ᵢ v2 ** q)

| ins_conj_rule : forall p1 p2 q1 q2 i,
    wf_ins p1 i q1 -> wf_ins p2 i q2 ->
    wf_ins (p1 //\\ p2) i (q1 //\\ q2)

| ins_disj_rule : forall p1 p2 q1 q2 i,
    wf_ins p1 i q1 -> wf_ins p2 i q2 ->
    wf_ins (p1 \\// p2) i (q1 \\// q2)

| ins_conseq_rule : forall p p1 q q1 i,
    p ==> p1 -> wf_ins p1 i q1 -> q1 ==> q ->
    wf_ins p i q

| ins_frame_rule : forall p q r i,
    wf_ins p i q -> DlyFrameFree r ->
    wf_ins (p ** r) i (q ** r).

Notation " '|-' '{{' p '}}' i '{{' q '}}' " := (wf_ins p i q) (at level 50).

(*+ Well-formed Sequence +*)

Definition stack_val : Type := Address * list (Frame * Frame).
Definition ctx_val : Type := Address * (list Word * list Word * list Word * Word).

Inductive logicvar : Type :=
| logic_lv : Word -> logicvar
| logic_llv : list Word -> logicvar
| logic_reg : RegName -> logicvar
| logic_fm : Frame -> logicvar
| logic_fmls : FrameList -> logicvar
| logic_flp : list (Frame * Frame) -> logicvar
| logic_stk : stack_val -> logicvar
| logic_ctx : ctx_val -> logicvar.

Definition fpre := list logicvar -> asrt.
Definition fpost := list logicvar -> asrt.
Definition fspec : Type := fpre * fpost.
Definition funspec := Word * Word -> option fspec.

(* Delay Time Reduce *)
Fixpoint TimReduce (a : asrt) : asrt :=
  match a with
  | p //\\ q => (TimReduce p) //\\ (TimReduce q)
  | p \\// q => (TimReduce p) \\// (TimReduce q)
  | p ** q => (TimReduce p) ** (TimReduce q)
  | Aforall t p => Aforall (fun x : t => (TimReduce (p x)))
  | Aexists t p => Aexists (fun x : t => (TimReduce (p x)))
  | Aregdly t rsp v =>
    match t with
    | O => rsp |=> v
    | S t' => t' @ rsp |==> v
    end
  | _ => a
  end.
Notation "p ↓" := (TimReduce p) (at level 40).

Definition fretSta (p1 p2 : asrt) :=
  forall s s', s |= p1 -> s' |= p2 ->
          (exists v, (getregs s) r15 = Some v /\
                (getregs s') r15 = Some v).

Inductive wf_seq : funspec -> asrt -> InsSeq -> asrt -> Prop :=
| seq_rule : forall f i I p p' q Spec,
    |- {{ p ↓ }} i {{ p' }} -> wf_seq Spec p' I q ->
    wf_seq Spec p (f # i ;; I) q

| call_rule : forall f f1 f2 i I p p1 p2 p' q r fp fq (L : list logicvar) v (Spec : funspec),
    Spec (f, f +ᵢ ($ 4)) = Some (fp, fq) ->
    (p ↓) ==> r15 |=> v ** p1 ->
    |- {{ (r15 |=> f1 ** p1) ↓ }} i {{ p2 }} -> fp L ==> ((Or r15) ==ₑ f1) ->
    p2 ==> fp L ** r -> fq L ** r ==> p'-> fq L ==> ((Or r15) ==ₑ f1) ->
    DlyFrameFree r -> wf_seq Spec p' I q ->
    wf_seq Spec p (f1 c> call f ;; f2 c> i ;; I) q

| retl_rule : forall p p' q f1 f2 i Spec,
    |- {{ (p ↓) ↓ }} i {{ p' }} -> p' ==> q -> fretSta ((p ↓) ↓) p' ->
    wf_seq Spec p (f1 r> retl ;; f2 r> i) q

| J1_rule : forall p p1 p' q (r1 : GenReg) f f1 f2 aexp Spec fp fq L v r i,
    (p ↓) ==> aexp ==ₓ f -> Spec (f, f +ᵢ ($ 4)) = Some (fp, fq) ->
    (p ↓) ==> r1 |=> v ** p1 -> |- {{ (r1 |=> f1 ** p1) ↓ }} i {{ p' }} ->
    p' ==> fp L ** r -> fq L ** r ==> q -> DlyFrameFree r ->
    wf_seq Spec p (consJ1 f1 aexp r1 f2 i) q

| J2_rule : forall p p1 p2 q r fp fq L aexp1 aexp2 f1 f1' f2 f2' (r1 r2 : GenReg) v1 v2 Spec,
    (p ↓) ==> (aexp1 ==ₓ f1') -> (p ↓) ==> r1 |=> v1 ** p1 ->
    ((r1 |=> f1 ** p1) ↓) ==> (aexp2 ==ₓ f2') -> ((r1 |=> f1 ** p1) ↓) ==> r2 |=> v2 ** p2 ->
    Spec (f1', f2') = Some (fp, fq) ->
    (r2 |=> f2 ** p2) ==> fp L ** r -> fq L ** r ==> q -> DlyFrameFree r ->
    wf_seq Spec p (consJ2 f1 aexp1 r1 f2 aexp2 r2) q

| Be_rule : forall p p' q r f1 f2 f bv fp fq L i I Spec,
    Spec (f, f +ᵢ ($ 4)) = Some (fp, fq) ->
    |- {{ p ↓↓ }} i {{ p' }} -> (p ↓) ==> z |=> bv ** Atrue ->
    (bv =ᵢ ($ 0) = true -> wf_seq Spec p' I q) -> DlyFrameFree r ->
    ((bv =ᵢ ($ 0) = false) -> ((p' ==> fp L ** r) /\ (fq L ** r ==> q))) ->
    wf_seq Spec p (f1 e> be f ;; f2 e> i ;; I) q

| Bne_rule : forall p p' q r f1 f2 f bv fp fq L i I Spec,
    Spec (f, f +ᵢ ($ 4)) = Some (fp, fq) ->
    |- {{ p ↓↓ }} i {{ p' }} -> (p ↓) ==> z |=> bv ** Atrue ->
    (bv =ᵢ ($ 0) = false -> wf_seq Spec p' I q) -> DlyFrameFree r ->
    ((bv =ᵢ ($ 0) = true) -> ((p' ==> fp L ** r) /\ (fq L ** r ==> q))) ->
    wf_seq Spec p (f1 n> bne f ;; f2 n> i ;; I) q

| Seq_false_rule : forall q I Spec,
    wf_seq Spec Afalse I q

| Seq_frame_rule : forall p q I Spec r,
    wf_seq Spec p I q -> DlyFrameFree r ->
    wf_seq Spec (p ** r) I (q ** r )

| Ex_intro_rule : forall q I {tp:Type} p Spec,
    (forall x', wf_seq Spec (p x') I q) ->
    wf_seq Spec (EX x : tp, p x) I q

| Seq_conseq_rule : forall p p' q q' I Spec,
    wf_seq Spec p' I q' -> p ==> p' -> q' ==> q ->
    wf_seq Spec p I q

| Seq_disj_rule : forall p1 p2 q1 q2 I Spec,
    wf_seq Spec p1 I q1 -> wf_seq Spec p2 I q2 ->
    wf_seq Spec (p1 \\// p2) I (q1 \\// q2)

| Pure_intro_rule : forall p q (pu : Prop) I Spec,
    (pu -> wf_seq Spec p I q) ->
    wf_seq Spec ([| pu |] ** p) I q.

Notation " Spec '|-' '{{' p '}}' I '{{' q '}}' " :=
  (wf_seq Spec p I q) (at level 55).

(*+ Well-formed Code Heap +*)
Definition wf_cdhp (Spec : funspec) (C : CodeHeap) (Spec' : funspec) :=
  forall f1 f2 L fp fq,
    Spec' (f1, f2) = Some (fp, fq) ->
    exists I, LookupC C f1 f2 I /\ wf_seq Spec (fp L) I (fq L).


(*
 * Copyright 2015-2016 IBM Corporation
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module defines possible interleavings of lists. *)

Require Import List.
Require Import ListSet.
Require Import Bool.
Require Import Permutation.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Equivalence.
Require Import RelationClasses.
Require Import Lia.
Require Import LibUtilsCoqLibAdd.
Require Import LibUtilsLift.
Require Import LibUtilsListAdd.
Require Import LibUtilsAssoc.
Require Import LibUtilsSublist.
Require Import LibUtilsBag.

Section interleaving.

  Inductive is_interleaved {A} : list (list A) -> list A -> Prop
    :=
      is_interleaved_concat (ls1 ls2:list (list A)) :
        Permutation ls1 ls2 ->
        is_interleaved ls2 (concat ls1)
    | is_interleaved_cons lh ls1 ls2 l x :
        is_interleaved (lh::ls1) l ->
        Permutation ((x::lh)::ls1) ls2 ->
        is_interleaved ls2 (x::l).

  Lemma is_interleaved_concat_simple {A:Type} (l:list (list A)) :
    is_interleaved l (concat l).
  Proof.
    apply is_interleaved_concat.
    reflexivity.
  Qed.

  Lemma is_interleaved_cons_simple {A:Type} (x:A) lh ls l :
    is_interleaved (lh::ls) l ->
    is_interleaved ((x::lh)::ls) (x::l).
  Proof.
    intros isl.
    eapply is_interleaved_cons; try eassumption.
    reflexivity.
  Qed.

  Global Instance is_interleaved_perm_proper {A}  :
    Proper ((@Permutation (list A)) ==> eq ==> iff) (@is_interleaved A).
  Proof.
    cut (Proper ((@Permutation (list A)) ==> eq ==> Basics.impl) (@is_interleaved A)); unfold Proper, respectful; [intros H | ]; intros l1 l2 perm ? l ?; subst.
    { split; intros isl.
      - eapply H; eauto.
      - symmetry in perm.
        eapply H; eauto.
    }
    intros isl.
    revert l2 perm.
    induction isl; simpl; intros l2 perm.
    - rewrite perm in H.
      constructor; trivial.
    - assert (inn:In (x::lh) ls2).
      { rewrite <- H; simpl; eauto. }
      destruct (in_split _ _ inn) as [ls11 [ls12 ?]]; subst.
      clear inn.
      apply Permutation_cons_app_inv in H.
      specialize (IHisl (lh::ls11++ls12)).
      econstructor.
      + apply IHisl.
        rewrite H; trivial.
      + rewrite <- perm.
        apply Permutation_cons_app; trivial.
  Qed.

  Lemma is_interleaved_refl {A} (l:list A) : is_interleaved (l::nil) l.
  Proof.
    generalize (is_interleaved_concat_simple (l::nil)); simpl.
    rewrite app_nil_r; trivial.
  Qed.

  Lemma is_interleaved_nil_l {A:Type} (l:list A) : is_interleaved nil l <-> l = nil.
  Proof.
    split; intros H.
    - cut (forall x, Permutation nil x -> is_interleaved x l -> l = nil).
      { intros HH; apply (HH nil); trivial. }
      clear; intros.
      revert H.
      induction H0; simpl; trivial; intros perm.
      + apply Permutation_nil in perm; subst; simpl; trivial.
        symmetry in H; apply Permutation_nil in H; subst; simpl; trivial.
      +  apply Permutation_nil in perm; subst; simpl; trivial.
         symmetry in H; apply Permutation_nil in H; subst; simpl; trivial.
         discriminate.
    - subst.
      apply (is_interleaved_concat_simple nil).
  Qed.

  Lemma is_interleaved_perm_concat {A} {ls} {l:list A}:
    is_interleaved ls l -> Permutation l (concat ls).
  Proof.
    induction 1; simpl.
    - apply Permutation_concat; trivial.
    - rewrite IHis_interleaved.
      rewrite <- H0.
      simpl; reflexivity.
  Qed.

  Lemma is_interleaved_both_perm {A:Type} {ls} {l1 l2:list A} :
    is_interleaved ls l1 ->
    is_interleaved ls l2 ->
    Permutation l1 l2.
  Proof.
    intros isl1 isl2.
    rewrite (is_interleaved_perm_concat isl1).
    rewrite (is_interleaved_perm_concat isl2).
    reflexivity.
  Qed.

  Lemma is_interleaved_In {A:Type} (ls:list (list A)) l x :
    is_interleaved ls l ->
    In x l <-> exists l', In l' ls /\ In x l'.
  Proof.
    intros isl.
    rewrite (is_interleaved_perm_concat isl).
    apply concat_In.
  Qed.

  Lemma is_interleaved_sublist {A:Type} {ls} {l:list A} :
    is_interleaved ls l ->
    Forall (fun x => sublist x l) ls.
  Proof.
    induction 1.
    - rewrite <- H.
      apply concat_sublist.
    - invcs IHis_interleaved.
      rewrite <- H0.
      constructor.
      + constructor; trivial.
      + revert H4.
        apply Forall_impl; intros ? subl.
        constructor; trivial.
  Qed.

  Lemma is_interleaved_cons_nil_f {A} {ls:list (list A)} {l:list A} :
    is_interleaved ls l -> is_interleaved (nil :: ls) l.
  Proof.
    intros isl.
    induction isl.
    - rewrite <- H.
      generalize (is_interleaved_concat_simple (nil::ls1)); simpl; trivial.
    - rewrite <- H.
      rewrite perm_swap in IHisl.
      rewrite perm_swap.
      apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_cons_list {A} a ls2 (l2:list A) :
    is_interleaved ls2 l2 ->
    is_interleaved (a::ls2) (a++l2).
  Proof.
    intros isl.
    induction a; simpl.
    - apply is_interleaved_cons_nil_f; trivial.
    - apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_app {A} ls1 l1 ls2 (l2:list A) :
    is_interleaved ls1 l1 ->
    is_interleaved ls2 l2 ->
    is_interleaved (ls1++ls2) (l1++l2).
  Proof.
    intros isl1 isl2.
    induction isl1; rewrite <- H; clear ls0 H.
    - induction ls1; simpl; trivial.
      destruct a; simpl.
      + apply is_interleaved_cons_nil_f; trivial.
      + apply is_interleaved_cons_simple.
        rewrite app_ass.
        apply is_interleaved_cons_list; trivial.
    - apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_map {A B:Type} (f:A->B) ls (l:list A) :
    is_interleaved ls l ->
    is_interleaved (map (map f) ls) (map f l).
  Proof.
    intros isl.
    induction isl; simpl; intros.
    - rewrite concat_map.
      apply is_interleaved_concat.
      apply Permutation_map; trivial.
    - rewrite <- H; simpl.
      apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_filter {A:Type} f ls (l:list A) :
    is_interleaved ls l ->
    is_interleaved (map (filter f) ls) (filter f l).
  Proof.
    intros isl.
    induction isl; simpl; intros.
    - rewrite concat_filter.
      apply is_interleaved_concat.
      apply Permutation_map; trivial.
    - rewrite <- H; simpl.
      destruct (f x); trivial.
      apply is_interleaved_cons_simple; trivial.
  Qed.

  Lemma is_interleaved_filter_nil_f {A:Type} {ls} {l:list A} :
    is_interleaved ls l ->
    is_interleaved (filter_nil ls) l.
  Proof.
    intros isl.
    - induction isl; simpl in *.
      + unfold filter_nil. rewrite <- (Permutation_filter _ _ _ H).
        generalize (is_interleaved_concat_simple (filter_nil ls1)); intros isl.
        rewrite concat_filter_nil in isl; trivial.
      + rewrite <- H; simpl.
        apply is_interleaved_cons_simple.
        destruct lh; simpl; trivial.
        apply is_interleaved_cons_nil_f; trivial.
  Qed.

  Lemma is_interleaved_filter_nil {A:Type} ls (l:list A) :
    is_interleaved ls l <->
    is_interleaved (filter_nil ls) l.
  Proof.
    split; intros isl.
    - apply is_interleaved_filter_nil_f; trivial.
    - revert ls isl.
      induction l; simpl; intros ls isl.
      + invcs isl.
        rewrite H.
        apply concat_nil_r in H.
        induction ls; trivial.
        * apply (is_interleaved_concat_simple nil).
        * { destruct a; simpl in *.
            - apply is_interleaved_cons_nil_f; auto.
            - rewrite H1 in H.
              invcs H.
              discriminate.
          }
      + invcs isl.
        * symmetry in H1.
          destruct (Permutation_filter_pullback_r H1) as [ll [? perm2]]; subst.
          fold (@filter_nil A) in *; rewrite concat_filter_nil in *.
          apply is_interleaved_concat; symmetry; trivial.
        * symmetry in H3.
          destruct (filter_perm_head H3).
          symmetry in H3.
          rewrite H; simpl.
          apply is_interleaved_cons_simple.
          apply IHl.
          { replace (filter_nil (lh :: ls1 ++ x)) with (filter_nil (lh::ls1)); trivial.
            - apply is_interleaved_filter_nil_f; trivial.
            - generalize (Permutation_filter not_nil _ _ H); intros perm2.
              rewrite <- H3 in perm2.
              rewrite filter_app in perm2.
              generalize (Permutation_filter not_nil _ _ H3); intros perm3.
              unfold filter_nil in *.
              rewrite filter_filter in perm3.
              rewrite <- H3 in perm3.
              rewrite <- perm3 in perm2.
              rewrite filter_filter in perm2.
              generalize (Permutation_app_inv_l (filter not_nil ((a :: lh) :: ls1)) nil (filter not_nil x)); intros inv.
              rewrite app_nil_r in inv.
              specialize (inv perm2).
              apply Permutation_nil in inv.
              simpl.
              rewrite filter_app, inv.
              rewrite app_nil_r; trivial.
          }
  Qed.

  Lemma is_interleaved_cons_nil {A} ls (l:list A) :
    is_interleaved ls l <-> is_interleaved (nil :: ls) l.
  Proof.
    split; intros isl.
    - apply is_interleaved_cons_nil_f; trivial.
    - apply is_interleaved_filter_nil in isl.
      simpl in isl.
      apply is_interleaved_filter_nil; trivial.
  Qed.

  Lemma is_interleaved_app_cons_nil {A} ls1 ls2 (l:list A) :
    is_interleaved (ls1 ++ nil :: ls2) l <-> is_interleaved (ls1++ls2) l.
  Proof.
    rewrite <- (@Permutation_cons_app (list A) (ls1 ++ ls2) ls1 ls2)
    ; try reflexivity.
    symmetry.
    apply is_interleaved_cons_nil.
  Qed.

  Lemma is_interleaved_nil_r {A:Type} (ls:list (list A)) :
    is_interleaved ls nil <-> Forall (eq nil) ls.
  Proof.
    split; intros H.
    - apply is_interleaved_perm_concat in H.
      apply Permutation_nil in H.
      apply concat_nil_r in H.
      trivial.
    - generalize (is_interleaved_concat_simple ls); intros isl.
      apply concat_nil_r in H.
      rewrite H in isl; trivial.
  Qed.

  (*
    Lemma is_interleaved_concat_inside {A} {ls1 ls2 ls3} {l:list A} :
      is_interleaved (ls1++(concat ls2)::ls3) l ->
      is_interleaved (ls1++ls2++ls3) l.
    Proof.

    Lemma is_interleaved_distr {A} ls1 ls2 ls3 l2 (l:list A) :
          is_interleaved (ls1++ls2++ls3) l ->
          is_interleaved ls2 l2 ->
          is_interleaved (ls1++l2::ls3) l.
    Proof.
   *)

  (*
    Lemma is_interleaved_In {A:Type} (ls:list (list A)) l x :
      is_interleaved ls l ->
      In x l <-> exists l', In l' ls /\ In x l'.
    Proof.
      intros isl.
      rewrite (is_interleaved_perm_concat isl).
      apply concat_In.
    Qed.
   *)

  Lemma is_interleaved_lookup_none {A B} {dec:EqDec A eq} {ls:list (list (A*B))} l x :
    is_interleaved ls l ->
    lookup dec l x = None <->
    Forall (fun ll => lookup dec ll x = None) ls.
  Proof.
    intros isl.
    split; intros.
    - rewrite Forall_forall; intros.
      case_eq (lookup dec x0 x); trivial; intros.
      apply lookup_in in H1.
      generalize (is_interleaved_In _ _ (x,b) isl); intros [Hf Hb].
      cut_to Hb.
      + apply in_dom in Hb.
        destruct (in_dom_lookup dec Hb); congruence.
      + eauto.
    - apply is_interleaved_perm_concat in isl.
      case_eq (lookup dec l x); trivial; intros.
      apply lookup_in in H0.
      rewrite isl in H0.
      apply concat_In in H0.
      destruct H0 as [? [inn1 inn2]].
      rewrite Forall_forall in H.
      specialize (H _ inn1).
      apply lookup_none_nin in H.
      apply in_dom in inn2.
      congruence.
  Qed.

  Lemma is_interleaved_lookup_some {A B} {dec:EqDec A eq} {ls:list (list (A*B))} l x v :
    is_interleaved ls l ->
    lookup dec l x = Some v ->
    exists ll, In ll ls /\ lookup dec ll x = Some v.
  Proof.
    intros isl; induction isl; intros lo.
    - destruct (concat_lookup_some_break lo) as [ll1 [ll2 [ll3 [eqq [inn nin]]]]].
      subst.
      exists ll2; split; trivial.
      rewrite <- H.
      rewrite in_app_iff; simpl; eauto.
    - simpl in lo.
      destruct x0.
      destruct (dec x a); unfold equiv in *.
      + invcs lo.
        exists ((a,v)::lh); simpl.
        split.
        * rewrite <- H; simpl; eauto.
        * match_destr; congruence.
      + destruct (IHisl lo) as [ll [inn1 inn2]].
        simpl in inn1.
        destruct inn1.
        * subst.
          exists ((a,b)::ll); simpl.
          { split.
            - rewrite <- H; simpl; eauto.
            - rewrite inn2.
              destruct (dec x a); congruence.
          }
        * exists ll; split; trivial.
          rewrite <- H; simpl; eauto.
  Qed.

  Lemma is_interleaved_disjoint_lookup_equiv {A B} {dec:EqDec A eq} {ls:list (list (A*B))} :
    all_disjoint (map domain ls) ->
    forall l1 l2,
      is_interleaved ls l1 ->
      is_interleaved ls l2 ->
      lookup_equiv l1 l2.
  Proof.
    intros ad l1 l2 isl1 isl2 x.
    case_eq (lookup dec l1 x).
    - intros ? inn.
      destruct (is_interleaved_lookup_some _ _ _ isl1 inn)
        as [ll [inn1 inn2]].
      case_eq (lookup dec l2 x).
      + intros ? inn'.
        destruct (is_interleaved_lookup_some _ _ _ isl2 inn')
          as [ll' [inn1' inn2']].
        cut (ll = ll').
        { congruence. }
        generalize (is_interleaved_both_perm isl1 isl2); intros perm.
        apply lookup_in in inn.
        apply lookup_in in inn'.
        rewrite perm in inn.
        apply lookup_in_domain in inn2.
        apply lookup_in_domain in inn2'.
        eapply all_disjoint_domain_has_same_eq; eauto.
      + intros inn'.
        apply (is_interleaved_lookup_none _ x isl2) in inn'.
        apply (is_interleaved_lookup_none _ x isl1) in inn'.
        congruence.
    - intros inn'.
      apply (is_interleaved_lookup_none _ x isl1) in inn'.
      apply (is_interleaved_lookup_none _ x isl2) in inn'.
      congruence.
  Qed.

  Lemma is_interleaved_disjoint_update_first {A B} dec ls (l:list (A*B)) v d:
    all_disjoint (map domain ls) ->
    is_interleaved ls l ->
    is_interleaved (map (fun l0 : list (A * B) => update_first dec l0 v d) ls)
                   (update_first dec l v d).
  Proof.
    intros disj isl.
    revert disj.
    induction isl; intros disj.
    - rewrite <- (Permutation_map domain H) in disj.
      rewrite update_first_concat_disjoint_push by trivial.
      econstructor.
      rewrite H; trivial.
    - rewrite <- (Permutation_map domain H) in disj.
      destruct x; simpl in *.
      cut_to IHisl.
      + rewrite <- H; clear ls2 H; simpl.
        assert (nin: Forall (fun x => ~ In a x) (map domain ls1)).
        { invcs disj.
          revert H1; apply Forall_impl.
          intros ? disj.
          apply disjoint_cons_inv1 in disj; tauto.
        }
        destruct (dec v a); simpl.
        * subst.
          { replace (map (fun l0 : list (A * B) => update_first dec l0 a d) ls1)
              with (map id ls1).
            - rewrite map_id.
              eapply is_interleaved_cons; eauto.
            - apply map_ext_in; intros.
              rewrite nin_update; trivial.
              apply lookup_nin_none.
              rewrite Forall_forall in nin.
              apply nin.
              apply in_map_iff.
              eauto.
          }
        * econstructor; eauto.
      + invcs disj.
        constructor; trivial.
        revert H2; apply Forall_impl.
        intros ? disj.
        apply disjoint_cons_inv1 in disj; tauto.
  Qed.

  Lemma is_interleaved_singleton_inv {A B} (l1 l2:list (A*B)) :
    is_interleaved (l1::nil) l2 -> l1 = l2.
  Proof.
    revert l1; induction l2; intros l1 isl.
    - apply is_interleaved_nil_r in isl.
      invcs isl; trivial.
    - invcs isl.
      + symmetry in H1; apply Permutation_length_1_inv in H1; subst.
        simpl in H; rewrite app_nil_r in H; subst; simpl.
        rewrite app_nil_r; trivial.
      + symmetry in H3.
        apply Permutation_length_1_inv in H3.
        invcs H3.
        f_equal; auto.
  Qed.

  Lemma is_interleaved_cons_inv {A B} {dec:EqDec A eq} (a:(A*B)) l1 l2 l3 :
    all_disjoint (map domain ((a::l1)::l2)) ->
    is_interleaved ((a::l1)::l2) (a::l3) ->
    is_interleaved (l1::l2) l3.
  Proof.
    revert l1 l3.
    induction l2; simpl; intros l1 l3 disj isl.
    - apply is_interleaved_singleton_inv in isl.
      invcs isl.
      apply is_interleaved_refl.
    - invcs isl.
      + assert (inn1:In(a::l1) ls1).
        { rewrite H1; trivial; simpl; eauto. }
        destruct (in_split _ _ inn1)
          as [ll1 [ll2 eqq]]; subst; clear inn1.
        symmetry in H1.
        apply Permutation_cons_app_inv in H1.
        assert (nin:~ In a (concat ll1)).
        { intros inn.
          assert (inn1:In a (concat (ll1 ++ ll2))).
          { rewrite concat_app, in_app_iff; eauto. }
          rewrite <- H1 in inn1; simpl in inn1.
          rewrite in_app_iff in inn1.
          invcs disj.
          invcs H3.
          destruct a; simpl in *.
          destruct inn1 as [inn1|inn1].
          - apply in_dom in inn1.
            apply (H5 a); simpl; eauto.
          - apply concat_In in inn1.
            destruct inn1 as [? [inn1 inn2]].
            rewrite Forall_forall in H6.
            specialize (H6 (domain x)).
            cut_to H6.
            + apply in_dom in inn2.
              apply (H6 a); simpl; eauto.
            + apply in_map; trivial.
        }
        rewrite concat_app in H.
        case_eq (concat ll1); [intros eqq | intros ?? eqq]
        ; rewrite eqq in *.
        * simpl in H; invcs H.
          apply concat_nil_r in eqq.
          change (is_interleaved ((l1::nil)++a0 :: l2) (l1 ++ nil++concat ll2)).
          { apply is_interleaved_app.
            - apply is_interleaved_refl.
            - rewrite H1.
              apply is_interleaved_app.
              + apply is_interleaved_nil_r; trivial.
              + apply is_interleaved_concat_simple.
          }
        * invcs H.
          simpl in nin; intuition.
      + destruct (Permutation_in_nin_inv H3 a) as [eqq perm].
        * simpl; eauto.
        * invcs disj.
          invcs H1.
          rewrite Forall_forall in *.
          destruct a; simpl in *.
          { rewrite in_app_iff; intros [inn|inn].
            - apply in_dom in inn.
              apply (H5 a); simpl; eauto.
            - apply concat_In in inn.
              destruct inn as [? [inn1 inn2]].
              specialize (H6 (domain x)).
              cut_to H6.
              + apply in_dom in inn2.
                apply (H6 a); simpl; eauto.
              + apply in_map; trivial.
          }
        * invcs eqq.
          rewrite perm in H2; trivial.
  Qed.

  Lemma is_interleaved_in_dom_cons_inv {A B} {dec:EqDec A eq} {a:(A*B)} {l1 l2 l3} :
    is_interleaved (l1::l2) (a::l3) ->
    all_disjoint (map domain (l1::l2)) ->
    In (fst a) (domain l1) ->
    exists l1', l1 = a::l1'.
  Proof.
    intros isl disj inn.
    destruct a; simpl in *.
    invcs isl.
    - assert (perm:Permutation (filter_nil ls1) (filter_nil (l1::l2))).
      { apply Permutation_filter; trivial. }
      rewrite <- concat_filter_nil in H.
      assert (nnil:not_nil l1 = true).
      { destruct l1; simpl in *; tauto. }
      simpl in perm; rewrite nnil in perm.
      case_eq (filter_nil ls1); [intros eqq | intros ?? eqq]
      ; rewrite eqq in *; simpl in *; try discriminate.
      destruct l; simpl in *.
      + cut False; [contradiction | ].
        revert eqq; clear.
        induction ls1; simpl; try discriminate.
        destruct a; simpl; trivial; try discriminate.
      + invcs H.
        destruct (Permutation_in_nin_inv perm (a,b))
          as [eqq2 perm2].
        * simpl; eauto.
        * rewrite concat_In.
          intros [x [inn1 inn2]].
          invcs disj.
          rewrite Forall_forall in H2.
          specialize (H2 (domain x)).
          { cut_to H2.
            - apply (H2 a); trivial; eapply in_dom; eauto.
            - apply in_map; trivial.
              unfold filter_nil in inn1.
              apply filter_In in inn1; tauto.
          }
        * subst; eauto.
    - destruct (Permutation_in_nin_inv H3 (a,b))
        as [eqq perm].
      + simpl; eauto.
      + rewrite concat_In.
        intros [x [inn1 inn2]].
        invcs disj.
        rewrite Forall_forall in H1.
        specialize (H1 (domain x)).
        cut_to H1.
        * apply (H1 a); trivial; eapply in_dom; eauto.
        * apply in_map; trivial.
      + subst; eauto.
  Qed.

  Lemma is_interleaved_in_cons_inv {A B} {dec:EqDec A eq} {a:(A*B)} {l1 l2 l3} :
    is_interleaved (l1::l2) (a::l3) ->
    all_disjoint (map domain (l1::l2)) ->
    In a l1 ->
    exists l1', l1 = a::l1'.
  Proof.
    intros; eapply is_interleaved_in_dom_cons_inv; eauto.
    destruct a.
    eapply in_dom; eauto.
  Qed.

  Lemma is_interleaved_cons_dom_eq {A B} {dec:EqDec A eq} {a:A} {b b':B} {l1 l2 l3} :
    is_interleaved (((a, b)::l1)::l2) ((a,b')::l3) ->
    all_disjoint (map domain (((a,b)::l1)::l2)) ->
    b = b'.
  Proof.
    intros isl disj.
    destruct (is_interleaved_in_dom_cons_inv isl disj); simpl; [eauto | ].
    invcs H; trivial.
  Qed.

  Lemma is_interleaved_cons_dom_inv {A B} {dec:EqDec A eq} {a:A} {b b':B} {l1 l2 l3} :
    is_interleaved (((a, b)::l1)::l2) ((a,b')::l3) ->
    all_disjoint (map domain (((a,b)::l1)::l2)) ->
    is_interleaved (l1::l2) l3.
  Proof.
    intros isl disj.
    rewrite <- (is_interleaved_cons_dom_eq isl disj) in isl.
    eapply is_interleaved_cons_inv; eauto.
  Qed.

End interleaving.

Section close_enough.

  Definition close_enough_lists {A B:Type} (l1 l2:list (A*B)) :=
    exists (ls:list (list (A*B))),
      all_disjoint (map domain ls) /\
      is_interleaved ls l1 /\
      is_interleaved ls l2.

  Global Instance close_enough_lists_refl {A B} : Reflexive (@close_enough_lists A B).
  Proof.
    intros x.
    exists (x::nil); simpl; repeat split.
    - repeat constructor.
    - apply is_interleaved_refl.
    - apply is_interleaved_refl.
  Qed.

  Global Instance close_enough_lists_symm {A B} : Symmetric (@close_enough_lists A B).
  Proof.
    intros x y [l [disj [isl1 isl2]]].
    exists l; eauto.
  Qed.

  (* This should be true, but would take more work to prove.
       This can be proven by exhibiting a finer witness.  In general, in fact,
       we can group things by clumping all the same domain stuff together *)
  (*
    Global Instance close_enough_lists_trans {A B} : Transitive (@close_enough_lists A B).
    Proof.
      intros x y z [xyl [xydisj [xyisl1 xyisl2]]] [yzl [yzdisj [yzisl1 yzisl2]]].
      red.
      assert (perm:Permutation xyl yzl).
      - apply is_interleaved_perm_concat in xyisl2.
        apply is_interleaved_perm_concat in yzisl1.
        rewrite xyisl2 in yzisl1.

    Qed.
   *)

  Global Instance close_enough_lists_lookup_equiv {A B} {dec:EqDec A eq} :
    subrelation (@close_enough_lists A B) lookup_equiv.
  Proof.
    intros l1 l2 [l [disj [isl1 isl2]]].
    eapply is_interleaved_disjoint_lookup_equiv; eauto.
  Qed.

  Lemma close_enough_update_first {A B} dec (l1 l2:list (A*B)) v d :
    close_enough_lists l1 l2 ->
    close_enough_lists (update_first dec l1 v d) (update_first dec l2 v d).
  Proof.
    intros [l [disj [isl1 isl2]]].
    red.
    exists (map (fun l => update_first dec l v d) l).
    repeat split.
    - rewrite map_map.
      replace (map (fun x : list (A * B) => domain (update_first dec x v d)) l)
        with (map domain l); trivial.
      apply map_ext; intros.
      rewrite domain_update_first; trivial.
    - apply is_interleaved_disjoint_update_first; trivial.
    - apply is_interleaved_disjoint_update_first; trivial.
  Qed.

  Hint Resolve disjoint_nil_l disjoint_nil_r : fml.

  Lemma close_enough_lists_cons {A B} {dec:EqDec A eq} (a:(A*B)) l1 l2 :
    close_enough_lists l1 l2 ->
    close_enough_lists (a::l1) (a::l2).
  Proof.
    destruct a.
    intros [l [disj [isl1 isl2]]].
    destruct (in_in_split_domain_or dec l a)
      as [[m1 [ma [m2 [eqq [inn nin]]]]]|nin].
    - subst.
      exists (m1++((a,b)::ma)::m2).
      assert (perm1: Permutation (m1 ++ ((a, b) :: ma) :: m2) (((a, b) :: ma)::m1 ++ m2)).
      { rewrite <- Permutation_cons_app; try reflexivity. }
      assert (perm2: Permutation (m1 ++ ma :: m2) (ma::m1 ++ m2)).
      { rewrite <- Permutation_cons_app; try reflexivity. }
      repeat rewrite perm1.
      repeat rewrite perm2 in *.
      repeat split.
      + repeat rewrite map_app in *; simpl in *.
        invcs disj.
        constructor; trivial.
        revert H1; apply Forall_impl; intros.
        intros ?; simpl; intros inn1 inn2.
        eapply H; try eapply inn2.
        destruct inn1; subst; trivial.
      + econstructor; eauto.
      + econstructor; eauto.
    - exists (((a,b)::nil)::l); simpl.
      repeat split.
      + constructor; trivial.
        rewrite Forall_map.
        revert nin; apply Forall_impl; intros.
        apply disjoint_cons1; trivial with fml.
      + econstructor; eauto.
        apply is_interleaved_cons_nil in isl1; trivial.
      + econstructor; eauto.
        apply is_interleaved_cons_nil in isl2; trivial.
  Qed.

  Lemma close_enough_lists_cons_invs {A B} {dec:EqDec A eq} (a:A) (b b':B) l1 l2 :
    close_enough_lists ((a,b)::l1) ((a,b')::l2) ->
    b = b' /\ close_enough_lists l1 l2.
  Proof.
    intros [ll [disj [isl1 isl2]]].
    assert (inn1:In a (domain (concat ll))).
    { apply is_interleaved_perm_concat in isl1.
      rewrite <- isl1; simpl; eauto.
    }
    destruct (in_in_split_domain_first dec inn1)
      as [m1 [ma [m2 [eqq [inn nin]]]]]
    ; subst; clear inn1.
    rewrite <- Permutation_cons_app in isl1; try reflexivity.
    rewrite <- Permutation_cons_app in isl2; try reflexivity.
    rewrite <- Permutation_cons_app in disj; try reflexivity.
    assert(inn1:In (a, b) ma).
    { apply is_interleaved_perm_concat in isl1.
      assert (inn2:In (a,b) (concat (ma :: m1 ++ m2))).
      { rewrite <- isl1; simpl; eauto. }
      simpl in inn2.
      rewrite concat_app in inn2.
      repeat rewrite in_app_iff in inn2.
      invcs disj; rewrite Forall_forall in H1.
      destruct inn2 as [inn2|[inn2|inn2]]; trivial.
      - apply concat_In in inn2.
        destruct inn2 as [x [inn3 inn4]].
        specialize (H1 (domain x)).
        cut_to H1.
        + elim (H1 a); trivial; eapply in_dom; eauto.
        + rewrite map_app, in_app_iff.
          left; apply in_map; trivial.
      - apply concat_In in inn2.
        destruct inn2 as [x [inn3 inn4]].
        specialize (H1 (domain x)).
        cut_to H1.
        + elim (H1 a); trivial; eapply in_dom; eauto.
        + rewrite map_app, in_app_iff.
          right; apply in_map; trivial.
    }
    destruct (is_interleaved_in_cons_inv isl1 disj inn1) as [mm ?]; subst.
    apply is_interleaved_cons_inv in isl1; trivial.
    split.
    - apply (is_interleaved_cons_dom_eq isl2); trivial.
    - apply is_interleaved_cons_dom_inv in isl2; trivial.
      exists (mm::m1++m2); repeat split; trivial.
      simpl in disj.
      apply all_disjoint_cons_inv in disj.
      tauto.
  Qed.

  Lemma close_enough_lists_cons_inv {A B} {dec:EqDec A eq} (a:(A*B)) l1 l2 :
    close_enough_lists (a::l1) (a::l2) ->
    close_enough_lists l1 l2.
  Proof.
    destruct a.
    apply close_enough_lists_cons_invs.
  Qed.

End close_enough.


(* Copyright © 1998-2008
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Cezary Kaliszyk
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing [-] %\ensuremath-% #−# *)
(** printing [--] %\ensuremath-% #−# *)
(** printing {-} %\ensuremath-% #−# *)
(** printing {--} %\ensuremath-% #−# *)

Require Import CoRN.tactics.CornTac.
Require Export CoRN.algebra.CMonoids.
Set Automatic Introduction.

(* Begin_SpecReals *)

(**
* Groups
** Definition of the notion of Group
*)

Definition is_CGroup (G : CMonoid) (inv : CSetoid_un_op G) :=
  forall x, is_inverse csg_op [0] x (inv x).

Record CGroup : Type :=
  {cg_crr   : CMonoid;
   cg_inv   :  CSetoid_un_op cg_crr;
   cg_proof :  is_CGroup cg_crr cg_inv}.

Module Export coercions.
  Coercion cg_crr : CGroup >-> CMonoid.
End coercions.

(* End_SpecReals *)

(* Begin_SpecReals *)

Arguments cg_inv {c}.
Notation "[--] x" := (cg_inv x) (at level 4, right associativity).

Definition cg_minus (G : CGroup) (x y : G) := x[+] [--]y.

(**
%\begin{nameconvention}%
In the names of lemmas, we will denote [[--] ] with [inv],
and [ [-] ] with [minus].
%\end{nameconvention}%
*)

Arguments cg_minus [G].
Infix "[-]" := cg_minus (at level 50, left associativity).

(* End_SpecReals *)

(**
** Group axioms
%\begin{convention}% Let [G] be a group.
%\end{convention}%
*)
Section CGroup_axioms.
Variable G : CGroup.

Lemma cg_inverse : forall x : G, is_inverse csg_op [0] x [--] x.
Proof cg_proof G.

End CGroup_axioms.

(**
** Group basics
General properties of groups.
%\begin{convention}% Let [G] be a group.
%\end{convention}%
*)
Section CGroup_basics.
Variable G : CGroup.

Lemma cg_rht_inv_unfolded : forall x : G, x[+] [--] x [=] [0].
Proof.
 intro x; elim (cg_inverse G x); auto.
Qed.

Lemma cg_lft_inv_unfolded : forall x : G, [--] x[+]x [=] [0].
Proof.
 intro x; elim (cg_inverse G x); auto.
Qed.

Lemma cg_minus_correct : forall x : G, x [-] x [=] [0].
Proof.
 intro x.
 unfold cg_minus in |- *.
 apply cg_rht_inv_unfolded.
Qed.
Hint Resolve cg_rht_inv_unfolded cg_lft_inv_unfolded cg_minus_correct:
  algebra.

Lemma cg_inverse' : forall x : G, is_inverse csg_op [0] [--] x x.
Proof.
 intro x.
 split; algebra.
Qed.

(* Hints for Auto *)
Lemma cg_minus_unfolded : forall x y : G, x [-] y [=] x[+] [--] y.
Proof.
 algebra.
Qed.
Hint Resolve cg_minus_unfolded: algebra.

Lemma cg_minus_wd : forall x x' y y' : G, x [=] x' -> y [=] y' -> x [-] y [=] x' [-] y'.
Proof.
 intros x x' y y' H H0.
 unfold cg_minus in |- *.
 Step_final (x[+] [--] y').
Qed.
Hint Resolve cg_minus_wd: algebra_c.

Lemma cg_minus_strext : forall x x' y y' : G, x [-] y [#] x' [-] y' -> x [#] x' or y [#] y'.
Proof.
 intros x x' y y' H. cut (x [#] x' or [--] y [#] [--] y').
 intro H0. elim H0.
  left; trivial.
  intro H1.
  right; exact (cs_un_op_strext G cg_inv y y' H1).
 apply bin_op_strext_unfolded with (csg_op (c:=G)). trivial.
Qed.

Definition cg_minus_is_csetoid_bin_op : CSetoid_bin_op G :=
  Build_CSetoid_bin_op G (cg_minus (G:=G)) cg_minus_strext.

Lemma grp_inv_assoc : forall x y : G, x[+]y [-] y [=] x.
Proof.
 intros x y; unfold cg_minus in |- *.
 astepl (x[+](y[+] [--] y)).
 Step_final (x[+][0]).
Qed.
Hint Resolve grp_inv_assoc: algebra.

Lemma cg_inv_unique : forall x y : G, x[+]y [=] [0] -> y [=] [--] x.
Proof.
 intros x y H.
 astepl ([0][+]y).
 astepl ([--] x[+]x[+]y).
 astepl ([--] x[+](x[+]y)).
 Step_final ([--] x[+][0]).
Qed.

Lemma cg_inv_inv : forall x : G, [--] [--] x [=] x.
Proof.
 intro x.
 astepl ([0][+] [--] [--] x).
 astepl (x[+] [--] x[+] [--] [--] x).
 astepl (x[+]([--] x[+] [--] [--] x)).
 Step_final (x[+][0]).
Qed.
Hint Resolve cg_inv_inv: algebra.

Lemma cg_cancel_lft : forall x y z : G, x[+]y [=] x[+]z -> y [=] z.
Proof.
 intros x y z H.
 astepl ([0][+]y).
 astepl ([--] x[+]x[+]y).
 astepl ([--] x[+](x[+]y)).
 astepl ([--] x[+](x[+]z)).
 astepl ([--] x[+]x[+]z).
 Step_final ([0][+]z).
Qed.

Lemma cg_cancel_rht : forall x y z : G, y[+]x [=] z[+]x -> y [=] z.
Proof.
 intros x y z H.
 astepl (y[+][0]).
 astepl (y[+](x[+] [--] x)).
 astepl (y[+]x[+] [--] x).
 astepl (z[+]x[+] [--] x).
 astepl (z[+](x[+] [--] x)).
 Step_final (z[+][0]).
Qed.

Lemma cg_inv_unique' : forall x y : G, x[+]y [=] [0] -> x [=] [--] y.
Proof.
 intros x y H.
 astepl (x[+][0]).
 astepl (x[+](y[+] [--] y)).
 astepl (x[+]y[+] [--] y).
 Step_final ([0][+] [--] y).
Qed.

Lemma cg_inv_unique_2 : forall x y : G, x [-] y [=] [0] -> x [=] y.
Proof.
 intros x y H.
 generalize (cg_inv_unique _ _ H); intro H0.
 astepl ([--] [--] x).
 Step_final ([--] [--] y).
Qed.

Lemma cg_zero_inv : [--] ([0]:G) [=] [0].
Proof.
 apply eq_symmetric_unfolded; apply cg_inv_unique; algebra.
Qed.

Hint Resolve cg_zero_inv: algebra.

Lemma cg_inv_zero : forall x : G, x [-] [0] [=] x.
Proof.
 intro x.
 unfold cg_minus in |- *.
 Step_final (x[+][0]).
Qed.

Lemma cg_inv_op : forall x y : G, [--] (x[+]y) [=] [--] y[+] [--] x.
Proof.
 intros x y.
 apply (eq_symmetric G).
 apply cg_inv_unique.
 astepl (x[+]y[+] [--] y[+] [--] x).
 astepl (x[+](y[+] [--] y)[+] [--] x).
 astepl (x[+][0][+] [--] x).
 Step_final (x[+] [--] x).
Qed.

(**
Useful for interactive proof development.
*)

Lemma x_minus_x : forall x y : G, x [=] y -> x [-] y [=] [0].
Proof.
 intros x y H; Step_final (x [-] x).
Qed.

(**
** Sub-groups
%\begin{convention}% Let [P] be a predicate on [G] containing
[Zero] and closed under [[+]] and [[--] ].
%\end{convention}%
*)
Section SubCGroups.
Variable P : G -> CProp.
Variable Punit : P [0].
Variable op_pres_P : bin_op_pres_pred _ P csg_op.
Variable inv_pres_P : un_op_pres_pred _ P cg_inv.

Let subcrr : CMonoid := Build_SubCMonoid _ _ Punit op_pres_P.
Let subinv : CSetoid_un_op subcrr := Build_SubCSetoid_un_op _ _ _ inv_pres_P.

Lemma isgrp_scrr : is_CGroup subcrr subinv.
Proof.
 red in |- *. intro x. case x. intros. split; simpl in |- *; algebra.
Qed.

Definition Build_SubCGroup : CGroup := Build_CGroup subcrr _ isgrp_scrr.

End SubCGroups.

End CGroup_basics.

Add Parametric Morphism c : (@cg_minus c) with signature (@cs_eq (cg_crr c)) ==> (@cs_eq c) ==> (@cs_eq c) as cg_minus_wd_morph.
Proof.
 intros.
 apply cg_minus_wd; assumption.
Qed.

#[global]
Hint Resolve cg_rht_inv_unfolded cg_lft_inv_unfolded: algebra.
#[global]
Hint Resolve cg_inv_inv cg_minus_correct cg_zero_inv cg_inv_zero: algebra.
#[global]
Hint Resolve cg_minus_unfolded grp_inv_assoc cg_inv_op: algebra.
#[global]
Hint Resolve cg_minus_wd: algebra_c.

(**
** Associative properties of groups
%\begin{convention}% Let [G] be a group.
%\end{convention}%
*)
Section Assoc_properties.
Variable G : CGroup.

Lemma assoc_2 : forall x y z : G, x[+] (y [-] z) [=] x[+]y [-] z.
Proof.
 intros x y z; unfold cg_minus in |- *; algebra.
Qed.

Lemma zero_minus : forall x : G, [0] [-] x [=] [--] x.
Proof.
 intro x.
 unfold cg_minus in |- *.
 algebra.
Qed.

Lemma cg_cancel_mixed : forall x y : G, x [=] x [-] y[+]y.
Proof.
 intros x y.
 unfold cg_minus in |- *.
 astepr (x[+]([--] y[+]y)).
 Step_final (x[+][0]).
Qed.

Lemma plus_resp_eq : forall x y z : G, y [=] z -> x[+]y [=] x[+]z.
Proof.
 algebra.
Qed.

End Assoc_properties.

#[global]
Hint Resolve assoc_2 minus_plus zero_minus cg_cancel_mixed plus_resp_eq:
  algebra.

(**
** Apartness in Constructive Groups
Specific properties of apartness.
%\begin{convention}% Let [G] be a group.
%\end{convention}%
*)
Section cgroups_apartness.
Variable G : CGroup.

Lemma cg_add_ap_zero : forall x y : G, x[+]y [#] [0] -> x [#] [0] or y [#] [0].
Proof.
 intros x y H.
 apply (cs_bin_op_strext _ csg_op x [0] y [0]).
 astepr ([0]:G).
 auto.
Qed.

Lemma op_rht_resp_ap : forall x y z : G, x [#] y -> x[+]z [#] y[+]z.
Proof.
 intros x y z H.
 cut (x[+]z [-] z [#] y[+]z [-] z).
  intros h.
  case (cs_bin_op_strext _ _ _ _ _ _ h).
   auto.
  intro contra; elim (ap_irreflexive _ _ contra).
 astepl x; astepr y. auto.
Qed.

Lemma cg_ap_cancel_rht : forall x y z : G, x[+]z [#] y[+]z -> x [#] y.
Proof.
 intros x y z H.
 apply ap_wdr_unfolded with (y[+]z [-] z).
  apply ap_wdl_unfolded with (x[+]z [-] z).
   apply (op_rht_resp_ap _ _ [--] z H).
  astepr (x[+][0]).
  Step_final (x[+](z [-] z)).
 astepr (y[+][0]).
 Step_final (y[+](z [-] z)).
Qed.

Lemma plus_cancel_ap_rht : forall x y z : G, x[+]z [#] y[+]z -> x [#] y.
Proof cg_ap_cancel_rht.

Lemma minus_ap_zero : forall x y : G, x [#] y -> x [-] y [#] [0].
Proof.
 intros x y H.
 astepr (y [-] y).
 unfold cg_minus in |- *.
 apply op_rht_resp_ap; assumption.
Qed.

Lemma zero_minus_apart : forall x y : G, x [-] y [#] [0] -> x [#] y.
Proof.
 unfold cg_minus in |- *. intros x y H.
 cut (x[+] [--] y [#] y[+] [--] y). intros h.
  apply (cg_ap_cancel_rht _ _ _ h).
 astepr ([0]:G). auto.
Qed.

Lemma inv_resp_ap_zero : forall x : G, x [#] [0] -> [--] x [#] [0].
Proof.
 intros x H.
 astepl ([0][+] [--] x).
 astepl ([0] [-] x).
 apply minus_ap_zero.
 apply (ap_symmetric G).
 auto.
Qed.

Lemma inv_resp_ap : forall x y : G, x [#] y -> [--] x [#] [--] y.
Proof.
 intros x y H.
 apply (csf_strext _ _ (cg_inv (c:=G))).
 astepl x.
 astepr y.
 auto.
Qed.

Lemma minus_resp_ap_rht : forall x y z : G, x [#] y -> x [-] z [#] y [-] z.
Proof.
 intros x y z H.
 unfold cg_minus in |- *.
 apply op_rht_resp_ap.
 assumption.
Qed.

Lemma minus_resp_ap_lft : forall x y z : G, x [#] y -> z [-] x [#] z [-] y.
Proof.
 intros x y z H.
 astepl ([--] (x [-] z)).
  2: unfold cg_minus in |- *; Step_final ([--] [--] z[+] [--] x).
 astepr ([--] (y [-] z)).
  2: unfold cg_minus in |- *; Step_final ([--] [--] z[+] [--] y).
 apply inv_resp_ap.
 apply minus_resp_ap_rht.
 auto.
Qed.

Lemma minus_cancel_ap_rht : forall x y z : G, x [-] z [#] y [-] z -> x [#] y.
Proof.
 unfold cg_minus in |- *.
 intros x y z H.
 exact (plus_cancel_ap_rht _ _ _ H).
Qed.

End cgroups_apartness.
#[global]
Hint Resolve op_rht_resp_ap: algebra.
#[global]
Hint Resolve minus_ap_zero zero_minus_apart inv_resp_ap_zero: algebra.

Section CGroup_Ops.

(**
** The Group of bijective Setoid functions
*)

Definition PS_Inv (A : CSetoid) : PS_as_CMonoid A -> PS_as_CMonoid A.
Proof.
 simpl in |- *.
 intros f.
 elim f.
 intros fo prfo.
 set (H0 := Inv fo prfo) in *.
 apply Build_subcsetoid_crr with H0.
 unfold H0 in |- *.
 apply Inv_bij.
Defined.

Definition Inv_as_un_op (A : CSetoid) : CSetoid_un_op (PS_as_CMonoid A).
Proof.
 unfold CSetoid_un_op in |- *.
 apply Build_CSetoid_fun with (PS_Inv A).
 unfold fun_strext in |- *.
 intros x y.
 case x.
 case y.
 simpl in |- *.
 intros f H g H0.
 unfold ap_fun in |- *.
 intro H1.
 elim H1.
 clear H1.
 intros a H1.
 exists (Inv g H0 a).
 astepl a.
  2: simpl in |- *.
  2: apply eq_symmetric_unfolded.
  2: apply inv1.
 unfold bijective in H.
 elim H.
 unfold injective in |- *.
 intros H2 H3.
 astepl (f (Inv f H a)).
  apply H2.
  apply ap_symmetric_unfolded.
  exact H1.
 simpl in |- *.
 apply inv1.
Defined.

Lemma PS_is_CGroup :
 forall A : CSetoid, is_CGroup (PS_as_CMonoid A) (Inv_as_un_op A).
Proof.
 intro A.
 unfold is_CGroup in |- *.
 intro x.
 unfold is_inverse in |- *.
 simpl in |- *.
 split.
  case x.
  simpl in |- *.
  intros f H.
  unfold eq_fun in |- *.
  intro a.
  unfold comp in |- *.
  simpl in |- *.
  apply inv2.
 case x.
 simpl in |- *.
 intros f H.
 unfold eq_fun in |- *.
 intro a.
 unfold comp in |- *.
 simpl in |- *.
 apply inv1.
Qed.

Definition PS_as_CGroup (A : CSetoid) :=
  Build_CGroup (PS_as_CMonoid A) (Inv_as_un_op A) (PS_is_CGroup A).

(**
** Functional operations

As before, we lift our group operations to the function space of the group.

%\begin{convention}%
Let [G] be a group and [F,F':(PartFunct G)] with domains given respectively
by [P] and [Q].
%\end{convention}%
*)

Variable G : CGroup.

Variables F F' : PartFunct G.

(* begin hide *)
Let P := Dom F.
Let Q := Dom F'.
(* end hide *)

Section Part_Function_Inv.

Lemma part_function_inv_strext : forall x y (Hx : P x) (Hy : P y),
 [--] (F x Hx) [#] [--] (F y Hy) -> x [#] y.
Proof.
 intros x y Hx Hy H.
 apply pfstrx with F Hx Hy.
 apply un_op_strext_unfolded with (cg_inv (c:=G)); assumption.
Qed.

Definition Finv := Build_PartFunct _ _
 (dom_wd _ F) (fun x Hx => [--] (F x Hx)) part_function_inv_strext.

End Part_Function_Inv.

Section Part_Function_Minus.

Lemma part_function_minus_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y),
 F x (Prj1 Hx) [-] F' x (Prj2 Hx) [#] F y (Prj1 Hy) [-] F' y (Prj2 Hy) -> x [#] y.
Proof.
 intros x y Hx Hy H.
 cut (F x (Prj1 Hx) [#] F y (Prj1 Hy) or F' x (Prj2 Hx) [#] F' y (Prj2 Hy)).
  intro H0.
  elim H0; intro H1; exact (pfstrx _ _ _ _ _ _ H1).
 apply cg_minus_strext; auto.
Qed.

Definition Fminus := Build_PartFunct G _ (conj_wd (dom_wd _ F) (dom_wd _ F'))
 (fun x Hx => F x (Prj1 Hx) [-] F' x (Prj2 Hx)) part_function_minus_strext.

End Part_Function_Minus.

(**
%\begin{convention}% Let [R:G->CProp].
%\end{convention}%
*)

Variable R:G -> CProp.

Lemma included_FInv : included R P -> included R (Dom Finv).
Proof.
 intro; simpl in |- *; assumption.
Qed.

Lemma included_FInv' : included R (Dom Finv) -> included R P.
Proof.
 intro; simpl in |- *; assumption.
Qed.

Lemma included_FMinus : included R P -> included R Q -> included R (Dom Fminus).
Proof.
 intros; simpl in |- *; apply included_conj; assumption.
Qed.

Lemma included_FMinus' : included R (Dom Fminus) -> included R P.
Proof.
 intro H; simpl in H; eapply included_conj_lft; apply H.
Qed.

Lemma included_FMinus'' : included R (Dom Fminus) -> included R Q.
Proof.
 intro H; simpl in H; eapply included_conj_rht; apply H.
Qed.

End CGroup_Ops.

Arguments Finv [G].
Notation "{--} x" := (Finv x) (at level 4, right associativity).

Arguments Fminus [G].
Infix "{-}" := Fminus (at level 50, left associativity).

#[global]
Hint Resolve included_FInv included_FMinus : included.

#[global]
Hint Immediate included_FInv' included_FMinus' included_FMinus'' : included.


(* This file provides an abstract envelope for computability theoretical considerations *)
From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype choice.
From mf Require Import all_mf.
Require Import iseg.
Require Import FunctionalExtensionality.

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

Section FM_operator.
Context (A A' Q Q': Type).
Notation B := (Q -> A).
Notation B' := (Q' -> A').
Notation "B o~> B'" := (nat -> B -> Q' -> option A') (at level 2).

Definition operator (M: B o~> B') :=
	make_mf (fun phi Mphi => forall q', exists c, M c phi q' = Some (Mphi q')).

Notation "\F_ M" := (operator M) (format "'\F_' M", at level 2).

Notation "M '\evaluates_to' F" := ((\F_M) \tightens F) (at level 40).

Lemma eval_FM M: M \evaluates_to \F_M.
Proof. done. Qed.

Lemma exte_sym_F2MF S T (f: S ->> T) g:
	f \is_singlevalued -> f \extends (F2MF g) -> (F2MF g) \extends f.
Proof. by move => sing exte s t fst; rewrite (sing s t (g s)) => //; apply exte. Qed.

Lemma eval_F2MF M F:
	M \evaluates_to (F2MF F) <-> \F_M =~= F2MF F.
Proof.
split => [eval | <-] //; rewrite exte_equiv; split; first exact/sing_tight_exte/eval/F2MF_sing.
move => s t fst; apply /(tight_val eval)/fst/F2MF_tot.
Qed.

Lemma F2MF_mach (F: B -> B'):
	(fun n phi q => Some(F phi q)) \evaluates_to (F2MF F).
Proof.
move => phi _; split => [ | Fphi ev]; first by exists (F phi) => q'; exists 0.
by apply functional_extensionality => q'; have [c val]:= ev q'; apply Some_inj.
Qed.

Definition cost_bound cf (M: B o~> B') :=
	forall phi q', exists n a', n <= cf phi q' /\ M n phi q' = Some a'.

Definition monotone_in (M: B o~> B') phi q' :=
	forall n, M n phi q' <> None -> M n.+1 phi q' = M n phi q'.

Lemma mon_in_spec (M: B o~> B) phi q': monotone_in M phi q' <->
	forall a' n m, n <= m -> M n phi q' = Some a' -> M m phi q' = Some a'.
Proof.
split => [mon a' n m | mon n neq]; last by case E: (M n phi q') neq=>[a' | ]// _; apply/mon/E.
elim: m => [ineq eq | m ih]; first by have/eqP <-: n == 0 by rewrite -leqn0.
rewrite leq_eqVlt; case/orP => [/eqP <- | ineq eq]//.
by rewrite mon => //; rewrite ih; rewrite /pickle /=.
Qed.

Lemma mon_in_eq M phi q' n m a' b':
	monotone_in M phi q' -> M n phi q' = Some a' -> M m phi q' = Some b' -> a' = b'.
Proof.
case/orP: (leq_total n m) => ineq /mon_in_spec mon eq eq'; apply /Some_inj.
	by rewrite -eq'; symmetry; apply/mon/eq.
by rewrite -eq; apply/mon/eq'.
Qed.

Definition monotone M:= make_subset (fun phi => forall q', monotone_in M phi q').
Notation "M '\is_monotone'" := ((dom \F_M) \is_subset_of (monotone M)) (at level 2).

Lemma mon_spec (M: B o~> B'): M \is_monotone <-> forall phi q' a' n m,
	phi \from dom \F_M -> n <= m -> M n phi q' = Some a' -> M m phi q' = Some a'.
Proof.
split => [mon phi q' a' n m phifd| mon phi phfd q'].
	have /mon_in_spec prp: monotone_in M phi q' by apply/mon.
	exact/prp.
by rewrite mon_in_spec => a' n m ineq eq; apply/mon/eq.
Qed.

Lemma mon_sing_restr M: \F_M|_(monotone M) \is_singlevalued.
Proof.
move => phi Fphi Fphi' [mon FphiFphi] [_ FphiFphi'].
apply functional_extensionality => q'.
have [c eq]:= FphiFphi q'.
have [d eq']:= FphiFphi' q'.
exact/mon_in_eq/eq'/eq/mon.
Qed.

Lemma mon_sing (M: B o~> B):
	M \is_monotone -> \F_M \is_singlevalued.
Proof. by move => mon; rewrite -(restr_dom \F_M); exact/restr_sing/mon_sing_restr. Qed.

Lemma mon_eval M F: M \is_monotone -> F \is_singlevalued ->
	M \evaluates_to F <-> \F_M \extends F.
Proof.
move => mon sing; split => [eval | eval]; first exact/sing_tight_exte.
exact/exte_tight/eval/mon_sing.
Qed.

Definition right_away (M: B o~> B') phi :=	make_mf (fun q' a' =>
		M 0 phi q' = some a').

Lemma ra_sing M phi: (right_away M phi) \is_singlevalued.
Proof. by move => q' a' b' /=eq1 eq2; apply/Some_inj; rewrite -eq1 -eq2. Qed.

Definition static (M: B o~> B') phi:= make_mf (fun q a =>
	forall c, M c phi q = some a).

End FM_operator.
Notation "\F_ M" := (operator M) (format "'\F_' M", at level 2).
Notation "M '\evaluates_to' F" := (\F_M \tightens F) (at level 2).
Notation "M '\is_monotone'" := (dom \F_M \is_subset_of (monotone M)) (at level 2).
Notation "cf '\bounds_cost_of' M" := (cost_bound cf M) (at level 2).


(** Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
 *  Jean-Baptiste Tristan, and Edward Gan.
 *
 *  This file is part of RockSalt.
 *
 *  This file is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU General Public License as
 *  published by the Free Software Foundation; either version 2 of
 *  the License, or (at your option) any later version.
 *)

Require Import Coqlib.
Require Import List.
Set Implicit Arguments.

Class Monad(M:Type->Type) : Type := {
  Return : forall (A:Type), A -> M A ;
  Bind : forall (A B:Type), M A -> (A -> M B) -> M B ;
  ret_left_unit : forall A B (x:A) (f:A -> M B), Bind (Return x) f = f x ;
  ret_right_unit : forall A (c:M A), Bind c (@Return _) = c ;
  bind_assoc : forall A B C (f:M A) (g:A -> M B) (h:B -> M C),
    Bind (Bind f g) h = Bind f (fun x => Bind (g x) h)
}.

Notation "'ret' x" := (Return x) (at level 75) : monad_scope.
Notation "x <- c1 ; c2" := (Bind _ c1 (fun x => c2))
  (right associativity, at level 84, c1 at next level) : monad_scope.
Notation "c1 ;; c2" := (Bind _ c1 (fun _ => c2))
  (right associativity, at level 84) : monad_scope.
Notation "[ x , y ] <- c1 ; c2" :=
  (Bind _ c1 (fun v => match v with | (x,y) => c2 end))
  (right associativity, at level 84) : monad_scope.

Instance OptionMonad : Monad option := {
  Return := fun A x => Some x ;
  Bind := fun A B c f => match c with | None => None | Some v => f v end
}.
auto. destruct c ; auto. intros. destruct f ; auto.
Defined.

Definition ST(S A:Type) := S -> S * A.

Instance StateMonad(S:Type) : Monad (ST S) := {
  Return := fun A x s => (s,x) ;
  Bind := fun A B c f s => match c s with | (s',x) => f x s' end
}.
 intros. apply extensionality ; auto.
 intros. apply extensionality. intro. destruct (c x) ; auto.
 intros. apply extensionality ; auto. intros. destruct (f x) ; auto.
Defined.

Instance ListMonad : Monad list := {
  Return := fun A x => x::nil ;
  Bind := fun A B c f => list_flatten (map f c)
}.
  intros. simpl. rewrite app_nil_end. auto.
  intros. induction c ; auto. simpl. rewrite IHc ; auto.
  intros. induction f ; auto. simpl. rewrite map_app.
  rewrite <- flatten_distr. rewrite IHf. auto.
Defined.


Require Import Setoid Morphisms List Arith Lia.
Import ListNotations.

Require Import Undecidability.CFG.CFP.
Require Import Undecidability.CFG.CFG.
Require Import Undecidability.CFG.Util.Facts.

(* bad design : this file has nothing to do with PCP *)
Require Import Undecidability.PCP.PCP.
Require Import Undecidability.PCP.Util.PCP_facts.
Require Import Undecidability.Synthetic.Definitions.

Set Default Goal Selector "!".

Local Hint Resolve in_eq in_nil in_cons in_or_app : core.
Local Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app incl_nil_l : core.

Local Notation "x 'el' A" := (In x A) (at level 70).
Local Notation "A <<= B" := (incl A B) (at level 70).

(* * PCP to CFPP *)
Local Hint Rewrite concat_app map_app map_map rev_app_distr : list.
Local Hint Rewrite <- app_assoc map_rev : list.

Local Hint Constructors rew_cfg : core.
Local Hint Constructors rewt : core.

Lemma nil_app_nil {X} (A : list X) :
  A = [] ++ A ++ [].
Proof.
  now autorewrite with list.
Qed.

Definition gamma (A : stack nat) := map (fun '(x,y) => (x, rev y)) A.

Lemma sigma_eq  s A :
  sigma s A = tau1 A ++ [s] ++ rev (tau2 (gamma A)).
Proof.
  induction A  as [ | [u v] ].
  - reflexivity.
  - cbn. rewrite IHA. rewrite <- !app_assoc. now simpl_list.
Qed.

Lemma tau2_gamma s A :
  s el rev (tau2 (gamma A)) <-> s el tau2 A.
Proof.
  induction A as [ | [u v] ]; cbn.
  - reflexivity.
  - simpl_list. rewrite !in_app_iff, IHA. firstorder.
Qed.

Lemma sigma_inv A s1 s x y :
  sigma s1 A = x ++ [s] ++ y -> ~ s el x -> ~ s el y -> ~ s el sym A ->
  s1 = s.
Proof.
  rewrite sigma_eq. intros.
  cbn in H. assert (s el  tau1 A ++ s1 :: rev (tau2 (gamma A))) by (rewrite H; eauto).
  eapply in_app_iff in H3 as [ | [ | ? % tau2_gamma]]; try firstorder using tau1_sym, tau2_sym.
Qed.

Lemma sigma_snoc A (x y u v: list sig) (s s': sig) :
  sigma s A = x ++ [s] ++ y -> ~ s el x -> ~ s el y ->
  sigma s' (A ++ [(u, v)]) = x ++ u ++ s' ++ v ++ y.
Proof.
  rewrite !sigma_eq. unfold gamma. cbn. simpl_list. cbn. simpl_list. cbn.
  intros. eapply list_prefix_inv in H as [-> <-]; eauto.
  eapply notInZero.
  eapply (f_equal (fun a => count a s)) in H. rewrite <- !countSplit in H. cbn in H.
  rewrite !Nat.eqb_refl in H. eapply notInZero in H0. eapply notInZero in H1.
  rewrite H0, H1 in *. lia.
Qed.

Section CFGs.

  Lemma rewrite_sing R a x :
    (a, x) el rules R -> rew_cfg R [a] x.
  Proof.
    intro. rewrite nil_app_nil, (nil_app_nil [a]). now econstructor.
  Qed.

  #[export] Instance rewtTrans R :
    PreOrder (rewt R).
  Proof.
    split.
    - hnf. econstructor.
    - induction 2; eauto.
  Qed.

  #[export] Instance rewrite_proper R :
    Proper (rewt R ==> rewt R ==> rewt R) (@app sig).
  Proof.
    intros x1 y1 H1 x2 y2 H2.
    induction H1.
    - induction H2.
      + reflexivity.
      + rewrite IHrewt. inversion H; subst. eapply rewtRule.
        * replace (x1 ++ x ++ [a] ++ y0) with ( (x1 ++ x) ++ [a] ++ y0) by now autorewrite with list.
          eauto.
        * replace (x1 ++ x ++ v ++ y0) with ( (x1 ++ x) ++ v ++ y0) by now autorewrite with list. eauto.
    - rewrite IHrewt. inversion H. subst. autorewrite with list. eauto.
  Qed.

  #[export] Instance subrel R :
    subrelation (rew_cfg R) (rewt R).
  Proof.
    intros x y H. econstructor.
    - reflexivity.
    - eassumption.
  Qed.

  Lemma terminal_iff G x :
    terminal G x <-> forall s y, s el x -> ~ (s, y) el rules G.
  Proof.
    split.
    - intros H s y A B. apply H. destruct (@in_split _ _ _ A) as (l1 & l2 & ->).
      exists (l1 ++ y ++ l2). change (s :: l2) with ([s] ++ l2). now econstructor.
    - intros H1 [y H2]. inversion H2. subst. eapply (H1 _ v); eauto.
  Qed.

  Definition sym_G (G : cfg) :=
    startsym G :: flat_map (fun '(a, x) => a :: x) (rules G).

  Lemma sym_G_rewt x G y :
    x <<= sym_G G -> rewt G x y -> y <<= sym_G G.
  Proof.
    intros. induction H0.
    - eauto.
    - destruct H1. destruct R. cbn in *.
      pose (incl_app_inv _ _ IHrewt) as HH.
      eapply incl_app.
      { apply HH. }
      eapply incl_app.
      + unfold sym_G. intros ? ?.
        right. eapply in_flat_map. exists (a, v). eauto.
      + eapply incl_cons_inv, HH.
  Qed.

End CFGs.

Section Post_CFG.

  Variable R : stack nat.
  Variable a : nat.

  Definition Sigma := sym R ++ [a].
  Definition S : nat := fresh Sigma.

  Definition G := (S, (S,[S]) :: map (fun '(u, v) => (S, u ++ [S] ++ v)) R ++ map (fun '(u, v) => (S, u ++ [a] ++ v)) R).

  Lemma terminal_iff_G y :
    terminal G y <-> ~ S el y.
  Proof.
    unfold terminal.
    enough ((exists y0, rew_cfg G y y0) <-> S el y). { firstorder. } split.
    - intros [y0 ?]. inversion H. subst. clear H. cbn in H0.
      destruct H0 as [ | [ [[] []] % in_map_iff | [[] []] % in_map_iff ] % in_app_iff]; inversion H; subst; eauto.
    - intros (u' & v' & ?) % List.in_split.
      subst. exists (u' ++ [S] ++ v'). econstructor. cbn. eauto.
  Qed.

  Lemma rewt_count x :
    rewt G [S] x -> count x S <= 1.
  Proof.
    induction 1.
    - cbn. now rewrite Nat.eqb_refl.
    - inversion H0. subst. clear H0. destruct H1 as [ | [ [[] []] % in_map_iff | [[] []] % in_map_iff ] % in_app_iff]; inversion H0; subst.
      + eauto.
      + unfold Sigma. simpl_list. rewrite <- !countSplit in *. cbn in *.
        rewrite Nat.eqb_refl in *.
        enough (count l S = 0) as ->. { enough (count l0 S = 0) as ->. { lia. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_R in H1. unfold Sigma. eauto. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_l in H1. unfold Sigma. eauto.
      + unfold Sigma. simpl_list. rewrite <- !countSplit in *. cbn in *.
        rewrite Nat.eqb_refl in *.
        assert (S =? a = false) as ->. { eapply Nat.eqb_neq. intros D.
        edestruct fresh_spec with (l := Sigma); try reflexivity.
        unfold S in *. rewrite D. unfold Sigma; eauto. }
        enough (count l S = 0) as ->. { enough (count l0 S = 0) as ->. { lia. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_R in H1. unfold Sigma. eauto. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_l in H1. unfold Sigma. eauto.
  Qed.

  Lemma Post_CFG_1' A :
    A <<= R -> A = [] \/ rewt G [S] (sigma a A).
  Proof.
    induction A.
    - cbn. eauto.
    - intros H.  assert (A <<= R) by (eapply incl_cons_inv; eassumption). eapply IHA in H0.
      destruct a0 as [u v]. destruct H0.
      + subst. right. erewrite rewrite_sing with (x := u ++ [a] ++ v). { reflexivity. }
        right. eapply in_app_iff. right. eapply in_map_iff. exists (u,v); eauto.
      + right. erewrite rewrite_sing with (x := u ++ [S] ++ v).
        { now rewrite H0. } right. eapply in_app_iff. left. eapply in_map_iff. exists (u,v); eauto.
  Qed.

  Lemma Post_CFG_2 x :
    rewt G [S] x ->
    exists A m, A <<= R /\ sigma m A = x /\ (m = S \/ m = a /\ A <> []).
  Proof.
    intros. induction H.
    - cbn.  exists [], S. eauto.
    - inversion H0. subst. clear H0.
      destruct H1 as [ | [(? & ? & ?) % in_map_iff | (? & ? & ?) % in_map_iff] % in_app_iff]; inversion H0; subst.
      + eassumption.
      + destruct x0 as [u' v']. inversion H3. subst.
        destruct IHrewt as (A & m & HA & IHA & Hm).
        exists (A ++ [(u', v')]), S. repeat split.
        * eauto.
        * simpl_list. cbn.
          enough (~ S el x). { enough (~ S el y0). {
          eapply sigma_snoc with (s := S); eauto.
          assert (IH2 := IHA).
          eapply sigma_inv in IHA; eauto. { subst. eauto. }
          intros D.
          edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
          eapply in_app_iff. left. eapply sym_mono. { eauto. } eauto. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia.
        * eauto.
      + destruct x0 as [u' v']. inversion H3. subst.
        destruct IHrewt as (A & m & HA & IHA & Hm).
        exists (A ++ [(u', v')]), a. repeat split.
        * eauto.
        * simpl_list. cbn.
          enough (~ S el x). { enough (~ S el y0). {
          eapply sigma_snoc with (s := S); eauto.
          -- assert (IH2 := IHA).
          eapply sigma_inv in IHA; eauto. { subst. eauto. }
          intros D.
          edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
          eapply in_app_iff. left. eapply sym_mono. { eauto. } eauto. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia.
        * destruct A; cbn; firstorder congruence.
  Qed.

  Lemma reduction_full x :
    (exists A, A <<= R /\ A <> [] /\ sigma a A = x) <->  L G x.
  Proof.
    split.
    - intros (A & ? & ? & ?). subst. destruct Post_CFG_1' with (A := A); intuition.
      split.
      + eassumption.
      + eapply terminal_iff_G. rewrite sigma_eq. intros E.
        edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
        eapply in_app_iff in E as [ | [ | ? % tau2_gamma ] % in_app_iff].
        * eapply in_app_iff. left. eapply sym_mono; eauto. now eapply tau1_sym.
        * eapply in_app_iff. right. eauto.
        * eapply in_app_iff. left. eapply sym_mono; eauto. now eapply tau2_sym.
    - intros [(A & m & HA & HE & Hm) % Post_CFG_2 ?].
      subst. destruct Hm as [-> | [-> ?]].
      + eapply terminal_iff_G in H.  exfalso. rewrite sigma_eq in H.
        eapply H. eauto.
      + exists A. eauto.
  Qed.

End Post_CFG.

Theorem reduction :
  CFPP ⪯ CFP.
Proof.
  exists (fun '(R, a) => (G R a)). intros [R a].
  intuition; cbn in *.
  - destruct H as (A & HR & HA & H).
    exists (sigma a A). split.
    + eapply reduction_full; eauto.
    + eauto.
  - destruct H as (x & Hx & H).
    eapply reduction_full in Hx as (A & HR & HA & H1).
    exists A. subst; eauto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * BigQ: an efficient implementation of rational numbers *)

(** Initial authors: Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)

Require Export BigZ.
Require Import Field Qfield QSig QMake Orders GenericMinMax.

(** We choose for BigQ an implemention with
    multiple representation of 0: 0, 1/0, 2/0 etc.
    See [QMake.v] *)

(** First, we provide translations functions between [BigN] and [BigZ] *)

Module BigN_BigZ <: NType_ZType BigN.BigN BigZ.
 Definition Z_of_N := BigZ.Pos.
 Lemma spec_Z_of_N : forall n, BigZ.to_Z (Z_of_N n) = BigN.to_Z n.
 Proof.
 reflexivity.
 Qed.
 Definition Zabs_N := BigZ.to_N.
 Lemma spec_Zabs_N : forall z, BigN.to_Z (Zabs_N z) = Zabs (BigZ.to_Z z).
 Proof.
 unfold Zabs_N; intros.
 rewrite BigZ.spec_to_Z, Zmult_comm; apply Zsgn_Zabs.
 Qed.
End BigN_BigZ.

(** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *)

Delimit Scope bigQ_scope with bigQ.

Module BigQ <: QType <: OrderedTypeFull <: TotalOrder.
 Include QMake.Make BigN BigZ BigN_BigZ [scope abstract_scope to bigQ_scope].
 Bind Scope bigQ_scope with t t_.
 Include !QProperties <+ HasEqBool2Dec
  <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
End BigQ.

(** Notations about [BigQ] *)

Local Open Scope bigQ_scope.

Notation bigQ := BigQ.t.
Bind Scope bigQ_scope with bigQ BigQ.t BigQ.t_.
(** As in QArith, we use [#] to denote fractions *)
Notation "p # q" := (BigQ.Qq p q) (at level 55, no associativity) : bigQ_scope.
Local Notation "0" := BigQ.zero : bigQ_scope.
Local Notation "1" := BigQ.one : bigQ_scope.
Infix "+" := BigQ.add : bigQ_scope.
Infix "-" := BigQ.sub : bigQ_scope.
Notation "- x" := (BigQ.opp x) : bigQ_scope.
Infix "*" := BigQ.mul : bigQ_scope.
Infix "/" := BigQ.div : bigQ_scope.
Infix "^" := BigQ.power : bigQ_scope.
Infix "?=" := BigQ.compare : bigQ_scope.
Infix "==" := BigQ.eq : bigQ_scope.
Notation "x != y" := (~x==y) (at level 70, no associativity) : bigQ_scope.
Infix "<" := BigQ.lt : bigQ_scope.
Infix "<=" := BigQ.le : bigQ_scope.
Notation "x > y" := (BigQ.lt y x) (only parsing) : bigQ_scope.
Notation "x >= y" := (BigQ.le y x) (only parsing) : bigQ_scope.
Notation "x < y < z" := (x<y /\ y<z) : bigQ_scope.
Notation "x < y <= z" := (x<y /\ y<=z) : bigQ_scope.
Notation "x <= y < z" := (x<=y /\ y<z) : bigQ_scope.
Notation "x <= y <= z" := (x<=y /\ y<=z) : bigQ_scope.
Notation "[ q ]" := (BigQ.to_Q q) : bigQ_scope.

(** [BigQ] is a field *)

Lemma BigQfieldth :
 field_theory 0 1 BigQ.add BigQ.mul BigQ.sub BigQ.opp
  BigQ.div BigQ.inv BigQ.eq.
Proof.
constructor.
constructor.
exact BigQ.add_0_l. exact BigQ.add_comm. exact BigQ.add_assoc.
exact BigQ.mul_1_l. exact BigQ.mul_comm. exact BigQ.mul_assoc.
exact BigQ.mul_add_distr_r. exact BigQ.sub_add_opp.
exact BigQ.add_opp_diag_r. exact BigQ.neq_1_0.
exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l.
Qed.

Lemma BigQpowerth :
 power_theory 1 BigQ.mul BigQ.eq Z_of_N BigQ.power.
Proof.
constructor. intros. BigQ.qify.
replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n).
destruct n. reflexivity.
induction p; simpl; auto; rewrite ?BigQ.spec_mul, ?IHp; reflexivity.
Qed.

Ltac isBigQcst t :=
 match t with
 | BigQ.Qz ?t => isBigZcst t
 | BigQ.Qq ?n ?d => match isBigZcst n with
             | true => isBigNcst d
             | false => constr:false
             end
 | BigQ.zero => constr:true
 | BigQ.one => constr:true
 | BigQ.minus_one => constr:true
 | _ => constr:false
 end.

Ltac BigQcst t :=
 match isBigQcst t with
 | true => constr:t
 | false => constr:NotConstant
 end.

Add Field BigQfield : BigQfieldth
 (decidable BigQ.eqb_correct,
  completeness BigQ.eqb_complete,
  constants [BigQcst],
  power_tac BigQpowerth [Qpow_tac]).

Section TestField.

Let ex1 : forall x y z, (x+y)*z ==  (x*z)+(y*z).
  intros.
  ring.
Qed.

Let ex8 : forall x, x ^ 2 == x*x.
  intro.
  ring.
Qed.

Let ex10 : forall x y, y!=0 -> (x/y)*y == x.
intros.
field.
auto.
Qed.

End TestField.

(** [BigQ] can also benefit from an "order" tactic *)

Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ.
Ltac bigQ_order := BigQ_Order.order.

Section TestOrder.
Let test : forall x y : bigQ, x<=y -> y<=x -> x==y.
Proof. bigQ_order. Qed.
End TestOrder.

(** We can also reason by switching to QArith thanks to tactic
    BigQ.qify. *)

Section TestQify.
Let test : forall x : bigQ, 0+x == 1*x.
Proof. intro x. BigQ.qify. ring. Qed.
End TestQify.


(** * Annotated Terms syntax
In this file, we describe a slightly different syntax for terms: we add two
annotations to applications. If the head of an application if a function from
  [A] to [B], we had both informations in the application, in order to keep
track of the conversion during the typing that would be impossible to rebuild
after.
*)
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt.
Require Import Le.
Require Import Gt.
Require Import Plus.
Require Import Minus.
Require Import Bool.
Require Import base.

Unset Standard Proposition Elimination Names.

(** Term syntax. Notice the two additional [Term] in the application.*)
Module Type term_mod (X:term_sig).
Import X.

Inductive Term : Set:=
 | Var : Vars -> Term
 | Sort : Sorts -> Term
 | App : Term -> Term -> Term -> Term -> Term
 | Pi : Term -> Term -> Term
 | La :Term -> Term -> Term
.

(** this notation means that the product x y is annotated by the function space
A -> B.**)
Notation "x ·( A , B ) y" := (App x A B y) (at level 15, left associativity) : Typ_scope.
Notation "! s" := (Sort s) (at level 1) : Typ_scope.
Notation "# v" := (Var v) (at level 1) : Typ_scope.
Notation "'Π' ( U ) , V " := (Pi U V) (at level 20, U, V at level 30) : Typ_scope.
Notation "'λ' [ U ] , v " := (La U v) (at level 20, U , v at level 30) : Typ_scope.

Reserved Notation " t ↑ x # n " (at level 5, x at level 0, left associativity).

Delimit Scope Typ_scope with Typ.

(** Same as for usual terms, we need lift and subst functions, with the very
same properties. They are just extended to deal with the two annotations.*)

Open Scope Typ_scope.

(* lift c n times *)
Fixpoint lift_rec (n:nat) (k:nat) (T:Term) {struct T} := match T with
   | # x =>  if le_gt_dec k x then Var (n+x) else Var x
   | ! s => Sort s
   | M ·(A, B) N=>  App (M ↑ n # k) (A↑ n # k) (B ↑ n # (S k)) (N ↑ n # k)
   | Π ( A ), B => Π (A ↑ n # k), (B ↑ n # (S k))
   | λ [ A ], M => λ [A ↑ n # k], (M ↑ n # (S k))
 end
   where "t ↑ n # k" := (lift_rec n k t) : Typ_scope.

Notation " t ↑ n " := (lift_rec n 0 t) (at level 5, n at level 0, left associativity) : Typ_scope.

Lemma inv_lift : forall M N n m , M ↑ n # m = N ↑ n # m -> M = N.
intros M; induction M; destruct N; intros;
simpl in *; try (discriminate || intuition); (try (destruct (le_gt_dec m v) ; discriminate)).
destruct (le_gt_dec m v); destruct (le_gt_dec m v0) ; injection H; intros; subst; intuition.
apply plus_reg_l in H0; rewrite H0; trivial.
elim (lt_irrefl m). apply le_lt_trans with v. trivial. induction n; intuition.
elim (lt_irrefl v0). apply lt_le_trans with m. induction n; intuition. trivial.
injection H; intros; subst; clear H. rewrite (IHM1 N1 n m H3); rewrite (IHM2 N2 n m H2);
  rewrite (IHM3 N3 n (S m) H1); rewrite (IHM4 N4 n m H0); reflexivity.
injection H; intros; rewrite (IHM1 N1 n m H1); rewrite (IHM2 N2 n (S m) H0); reflexivity.
injection H; intros; rewrite (IHM1 N1 n m H1); rewrite (IHM2 N2 n (S m) H0); reflexivity.
Qed.

Lemma lift_rec0 : forall M n, M ↑ 0 # n = M.
induction M; intros; simpl.
destruct (le_gt_dec n v); reflexivity.
reflexivity.
rewrite IHM1; rewrite IHM2; rewrite IHM3; rewrite IHM4; reflexivity.
rewrite IHM1; rewrite IHM2; reflexivity.
rewrite IHM1; rewrite IHM2; reflexivity.
Qed.

Lemma lift0 : forall M, M ↑ 0 = M .
intros; apply lift_rec0.
Qed.

Lemma liftP1 : forall M i j  k, (M ↑ j # i) ↑ k # (j+i) = M ↑ (j+k) # i.
intros M; induction M; intros;simpl.
destruct (le_gt_dec i v); simpl.
destruct (le_gt_dec (j+i) (j+v)); simpl.
rewrite plus_assoc. replace (k+j) with (j+k) by (apply plus_comm).  trivial.
apply plus_gt_reg_l in g. elim (lt_irrefl v).
apply lt_le_trans with i; intuition.
simpl; destruct (le_gt_dec (j+i)); intuition.
elim (lt_irrefl v).
apply lt_le_trans with i; intuition. induction j; intuition.
reflexivity.
rewrite IHM1. rewrite IHM2. rewrite IHM4. rewrite <- IHM3.
replace (j+S i) with (S(j+i)) by intuition. trivial.
rewrite IHM1; rewrite <-IHM2 ;replace (j+S i) with (S(j+i)) by intuition; reflexivity.
rewrite IHM1; rewrite <- IHM2 ;replace (j+S i) with (S(j+i)) by intuition; reflexivity.
Qed.

Lemma liftP2: forall M i j k n, i <= n ->
  (M ↑ j # i) ↑ k # (j+n) = (M ↑ k # n) ↑ j # i.
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v); destruct (le_gt_dec n v).
simpl.
destruct le_gt_dec. destruct le_gt_dec.
rewrite 2! plus_assoc. replace (k+j) with (j+k) by (apply plus_comm).  trivial.
elim (lt_irrefl v). apply lt_le_trans with i. induction k; intuition. trivial.
apply plus_gt_reg_l in g. elim (lt_irrefl v).
apply lt_le_trans with n; intuition.
simpl.
destruct le_gt_dec. apply plus_le_reg_l in l0. elim (lt_irrefl v).
apply lt_le_trans with n; intuition. destruct le_gt_dec. trivial.
elim (lt_irrefl v). apply lt_le_trans with i; intuition.
simpl. destruct le_gt_dec. elim (lt_irrefl n). apply lt_le_trans with i.
apply le_lt_trans with v; intuition. trivial. elim (lt_irrefl v).
apply lt_le_trans with n. apply lt_le_trans with i; intuition. trivial.
simpl. destruct le_gt_dec. elim (lt_irrefl v). apply lt_le_trans with n.
intuition. induction j; intuition. destruct le_gt_dec. elim (lt_irrefl i).
apply le_lt_trans with v; intuition. trivial.
trivial.

rewrite IHM1; intuition. replace (S(j+n)) with (j+S n) by intuition.
rewrite IHM2; intuition. rewrite IHM3; intuition. rewrite IHM4; intuition.
rewrite IHM1; intuition.
replace (S(j+n)) with (j+S n) by intuition.
rewrite (IHM2 (S i) j k (S n)); intuition.
rewrite IHM1; intuition.
replace (S(j+n)) with (j+S n) by intuition.
rewrite (IHM2 (S i) j k (S n) ); intuition.
Qed.

Lemma liftP3 : forall M i k j n , i <= k -> k <= (i+n) ->
  (M ↑ n # i) ↑ j # k = M ↑ (j+n) # i.
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v); simpl.
destruct (le_gt_dec k (n+v)); intuition.
elim (lt_irrefl (i+n)). apply lt_le_trans with k.
apply le_lt_trans with (n+v). rewrite plus_comm. intuition. intuition. trivial.
destruct (le_gt_dec k v); intuition. elim (lt_irrefl k).
apply lt_le_trans with i.  apply le_lt_trans with v. trivial. intuition. trivial.
reflexivity.
rewrite IHM1; intuition. rewrite IHM2; intuition. rewrite IHM3; intuition. rewrite IHM4; intuition.
 change (S i + n) with (S (i+n)). intuition.
rewrite IHM1; intuition;rewrite IHM2; intuition. change (S i + n) with (S (i+n)). intuition.
rewrite IHM1; intuition; rewrite IHM2; intuition. change (S i + n) with (S (i+n)). intuition.
Qed.

Lemma lift_lift : forall M n m, (M ↑ m) ↑ n  = M ↑ (n+m).
intros.
apply liftP3; intuition.
Qed.

(* i = index to replace
  t = term we are replacing
 k = limit between free and bound indices
*)
Reserved Notation "M [ n ← N ]" (at level 5, n at level 0, left associativity).

Fixpoint subst_rec U T n {struct T} :=
 match T with
  | # x => match (lt_eq_lt_dec x n) with
      | inleft (left _) => # x (* x < n *)
      | inleft (right _) => U ↑ n  (* x = n *)
      | inright _ => # (x - 1) (* x > n *)
      end
  | ! s => ! s
  | M ·(A,B) N => (M [ n ← U ]) ·(A[n← U], B [ S n ← U]) ( N [ n ← U ])
  | Π ( A ), B => Π ( A [ n ← U ] ), (B [ S n ← U ])
  | λ [ A ], M => λ [ A [ n ← U ] ], (M [ S n ← U ])
end
    where " t [ n ← w ] " := (subst_rec w t n) : Typ_scope.

Notation " t [ ← w ] " := (subst_rec w t 0) (at level 5) : Typ_scope.

Lemma expand_term_with_subst : forall M n, (M ↑ 1 # (S n)) [ n ← #0 ] = M.
induction M; intros.
unfold lift_rec.
destruct (le_gt_dec (S n) v). unfold subst_rec.
destruct (lt_eq_lt_dec (1+v) n) as [[] | ].
apply le_not_lt in l. elim l. intuition.
elim (lt_irrefl v). apply lt_le_trans with (S (S v)). intuition. subst; trivial.
change (1+v) with (S v). destruct v; simpl; trivial.
simpl.
destruct (lt_eq_lt_dec v n) as [[] | ].
trivial.
simpl; subst; trivial.
rewrite <- plus_n_O. trivial.
elim (lt_irrefl n). apply lt_le_trans with v; intuition.
simpl; trivial.
simpl. rewrite IHM1. rewrite IHM2. rewrite IHM3. rewrite IHM4. reflexivity.
simpl. rewrite IHM1. rewrite IHM2. reflexivity.
simpl. rewrite IHM1. rewrite IHM2. reflexivity.
Qed.

Lemma substP1: forall M N i j k ,
  ( M [ j ← N] ) ↑ k # (j+i) = (M ↑ k # (S (j+i))) [ j ← (N ↑ k # i ) ].
intros M; induction M; intros.
simpl (#v [j ← N] ↑ k # (j+i)).
change (#v ↑ k # (S (j+i))) with  (if le_gt_dec (S (j+i)) v then #(k+v) else #v).
destruct (lt_eq_lt_dec v j) as [[] | ].
destruct (le_gt_dec (S (j+i)) v).
elim (lt_irrefl v). apply lt_le_trans with j; intuition.
apply le_trans with (S (j+i)); intuition.
simpl.
destruct (le_gt_dec (j+i) v).
elim (lt_irrefl v). apply lt_le_trans with j; intuition. apply le_trans with (j+i); intuition.
destruct (lt_eq_lt_dec v j) as [[] | ]. trivial.
subst. elim (lt_irrefl j);trivial.
elim (lt_irrefl j); apply lt_trans with v; trivial.
destruct (le_gt_dec (S(j+i)) v). subst.
elim (lt_irrefl j). apply lt_le_trans with (S (j+i)). intuition. trivial.
simpl. destruct (lt_eq_lt_dec v j) as [[] | ].
subst. elim (lt_irrefl j); trivial.
apply liftP2; intuition.
subst. elim (lt_irrefl j); trivial.
destruct (le_gt_dec (S (j+i)) v).
simpl.
destruct (le_gt_dec (j+i) (v-1)). destruct (lt_eq_lt_dec (k+v) j) as [[] | ].
elim (lt_irrefl j). apply lt_le_trans with v. trivial. induction k; intuition.
subst. elim (lt_irrefl v). apply lt_le_trans with (S(k+v+i)). intuition. trivial.
destruct v. apply lt_n_O in l; elim l. rewrite <- 2! pred_of_minus. replace (k+ S v) with (S (k+v)) by intuition.
simpl. trivial.
elim (lt_irrefl v). apply lt_le_trans with (S (j+i)). destruct v. apply lt_n_O in l; elim l.
rewrite <- pred_of_minus in g. simpl in g. intuition. trivial.
simpl.
destruct (le_gt_dec (j+i) (v-1)). destruct (lt_eq_lt_dec v j) as [[] | ].
elim (lt_irrefl j); apply lt_trans with v; trivial.
subst. elim (lt_irrefl j); trivial.
elim (lt_irrefl v). apply lt_le_trans with (S (j+i)). intuition.
destruct v. apply lt_n_O in l; elim l. rewrite <- pred_of_minus in l0. simpl in l0. intuition.
destruct (lt_eq_lt_dec) as [[] | ]. elim (lt_irrefl j); apply lt_trans with v; trivial.
subst. elim (lt_irrefl j); trivial. trivial.
simpl; trivial.
simpl. rewrite IHM1; intuition; rewrite IHM2; intuition. rewrite IHM4; intuition.
replace (S(S(j+i))) with (S((S j)+i)) by intuition.
rewrite <- (IHM3 N i (S j)  k ); intuition.
simpl; rewrite IHM1; intuition.
replace (S(S(j+i))) with (S((S j)+i)) by intuition.
rewrite <- (IHM2 N i (S j)  k ); intuition.
simpl; rewrite IHM1; intuition.
replace (S(S(j+i))) with ((S ((S j)+i))) by intuition.
rewrite <- (IHM2 N i (S j)  k ); intuition.
Qed.

Lemma substP2: forall M N i j n, i <= n ->
  (M ↑ j # i ) [ j+n ← N ] = ( M [ n ← N]) ↑ j # i .
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v); destruct (lt_eq_lt_dec v n) as [[] | ].
simpl.
destruct (le_gt_dec i v).  destruct (lt_eq_lt_dec (j+v) (j+n)) as [[] | ].
reflexivity.
apply plus_reg_l in e. subst. elim (lt_irrefl n); trivial.
apply plus_lt_reg_l in l2. elim (lt_asym v n); trivial.
elim (lt_irrefl i). apply le_lt_trans with v; intuition. subst.
simpl.
destruct (lt_eq_lt_dec (j+n) (j+n)) as [[] | ].
apply lt_irrefl in l0; elim l0.
symmetry.
apply liftP3; intuition.
apply lt_irrefl in l0; elim l0.
simpl.
destruct (le_gt_dec i (v-1)). destruct (lt_eq_lt_dec (j+v) (j+n))as [[] | ].
apply plus_lt_reg_l in l2. elim (lt_asym  v n ); trivial.
apply plus_reg_l in e; subst. elim (lt_irrefl n); trivial.
destruct v. apply lt_n_O in l0; elim l0. rewrite <- 2! pred_of_minus. replace (j+ S v) with (S (j+v)) by intuition.
simpl. trivial.
unfold gt in g. unfold lt in g. rewrite <- pred_of_minus in g.
rewrite <- (S_pred  v n l0) in g.
elim (lt_irrefl n). apply lt_le_trans with v; trivial. apply le_trans with i; trivial.
simpl.
destruct (le_gt_dec i v).  elim (lt_irrefl i). apply le_lt_trans with v; trivial.
destruct (lt_eq_lt_dec v (j+n)) as [[] | ]. reflexivity.
subst. elim (lt_irrefl n). apply le_lt_trans with (j+n); intuition.
elim (lt_irrefl n). apply lt_trans with v.  apply le_lt_trans with (j+n); intuition. trivial.
simpl. subst.
elim (lt_irrefl n). apply lt_le_trans with i; intuition.
simpl. elim (lt_irrefl n). apply lt_le_trans with v; intuition.
apply le_trans with i; intuition.
trivial.

rewrite IHM1; intuition. replace (S(j+n)) with (j+(S n)) by intuition. rewrite IHM3; intuition.
rewrite IHM2; intuition; rewrite IHM4; intuition.
replace (S(j+n)) with (j+(S n)) by intuition.
rewrite IHM1; intuition;
rewrite <- (IHM2 N (S i) j (S n)); intuition.
replace (S(j+n)) with (j+(S n)) by intuition.
rewrite IHM1; intuition;
rewrite <- (IHM2 N (S i) j (S n)); intuition.
Qed.

Lemma substP3: forall M N i  k n, i <= k -> k <= i+n ->
  (M↑ (S n) # i) [ k← N] = M ↑ n # i.
intro M; induction M; intros; simpl.
destruct (le_gt_dec i v).
unfold subst_rec.
destruct (lt_eq_lt_dec (S(n+v)) k) as [[] | ].
elim (lt_irrefl (i+n)). apply lt_le_trans with k; intuition.
apply le_lt_trans with (v+n). intuition. rewrite plus_comm; intuition.
subst. replace (i+n) with (n+i) in H0 by (apply plus_comm) . replace (S (n+v)) with (n + S v) in H0 by intuition.
apply plus_le_reg_l in H0. elim (lt_irrefl i). apply le_lt_trans with v; intuition.
simpl. rewrite <- minus_n_O. trivial.
simpl. destruct (lt_eq_lt_dec v k) as [[] | ].
reflexivity. subst. elim (lt_irrefl i). apply le_lt_trans with k; intuition.
elim (lt_irrefl k). apply lt_trans with v; trivial. apply lt_le_trans with i; intuition.

reflexivity.
rewrite IHM1; intuition;rewrite IHM4; intuition.
rewrite IHM2; intuition. change (S i + n) with (S (i+n)). rewrite IHM3; intuition.
change (S i + n) with (S (i+n)). intuition.
rewrite IHM1; intuition; rewrite <- (IHM2 N (S i) (S k) n); intuition.
change (S i + n) with (S (i+n)). intuition.
rewrite IHM1; intuition; rewrite <- (IHM2 N (S i) (S k) n); intuition.
change (S i + n) with (S (i+n)). intuition.
Qed.

Lemma substP4: forall M N P i j,
   (M [ i← N]) [i+j ← P] = (M [S(i+j) ← P]) [i← N[j← P]].
intro M; induction M; intros; simpl.
destruct (lt_eq_lt_dec v i) as [[] | ] ; destruct (lt_eq_lt_dec v (S(i+j))) as [[] | ].
simpl.
destruct (lt_eq_lt_dec v (i+j)) as [[] | ]. destruct (lt_eq_lt_dec v i) as [[] | ].
trivial.
subst. apply lt_irrefl in l; elim l. elim ( lt_asym v i); trivial.
subst. rewrite plus_comm in l. elim (lt_irrefl i). induction j; simpl in *; intuition.
elim (lt_irrefl i). apply le_lt_trans with v;intuition. rewrite plus_comm in l1; intuition.  induction j; simpl in *; intuition.
subst. elim (lt_irrefl i). apply lt_trans with (S (i+j)); intuition.
elim (lt_irrefl i). apply lt_trans with (S (i+j)); intuition. apply lt_trans with v; trivial.
simpl. subst. destruct (lt_eq_lt_dec i i) as [[] | ].
elim (lt_irrefl i); trivial. apply substP2; intuition.
elim (lt_irrefl i); trivial.
subst v. rewrite plus_comm in e0. apply succ_plus_discr in e0. elim e0.
subst. elim (lt_irrefl i). apply le_lt_trans with (i+j); intuition.
simpl.
destruct (lt_eq_lt_dec (v-1) (i+j)) as  [[] | ]. destruct (lt_eq_lt_dec v i) as [[] | ].
elim (lt_asym v i); trivial. subst. elim (lt_irrefl i); trivial.
trivial. rewrite <- e in l0. rewrite <- pred_of_minus in l0.
rewrite <- (S_pred  v i l) in l0. elim (lt_irrefl v); trivial.
apply lt_n_S in l1. elim (lt_irrefl v).
apply lt_trans with (S(i+j)); trivial.
rewrite <- pred_of_minus in l1. rewrite <- (S_pred  v i l) in l1. trivial.
subst. simpl. rewrite <- minus_n_O.
destruct (lt_eq_lt_dec (i+j) (i+j)) as [[] | ].
elim (lt_irrefl (i+j)) ; trivial.
symmetry. apply substP3; intuition.
elim (lt_irrefl (i+j)) ; trivial.
simpl.
destruct (lt_eq_lt_dec (v-1) (i+j)) as  [[] | ].
elim (lt_irrefl v). apply lt_trans with (S (i+j)) ;trivial.
apply lt_n_S in l1. rewrite <- pred_of_minus in l1. rewrite <- (S_pred v i l) in l1. trivial.
apply eq_S in e. rewrite <- pred_of_minus in e. rewrite <- (S_pred v i l) in e.
subst. elim (lt_irrefl (S(i+j))); trivial.
destruct (lt_eq_lt_dec (v-1) i) as [[] | ].
elim (lt_irrefl v). apply le_lt_trans with i; trivial. destruct v. apply lt_n_O in l; elim l.
rewrite <- pred_of_minus in l2. simpl in l2. trivial.
destruct v. elim (lt_n_O i); trivial. rewrite <- pred_of_minus in e. simpl in e. subst.
rewrite <- pred_of_minus in l1. simpl in l1. elim (lt_irrefl i).
apply le_lt_trans with (i+j); intuition.
trivial.
trivial.
rewrite IHM1; rewrite IHM4; intuition. rewrite IHM2; intuition.
replace (S(S(i+j))) with (S((S i)+ j)) by intuition. rewrite <- IHM3; intuition.
rewrite IHM1; replace (S(S(i+j))) with (S((S i)+ j)) by intuition;
  rewrite <- (IHM2 N P (S i)); replace (S(i+j)) with ((S i)+ j) by intuition; intuition.
rewrite IHM1; replace (S(S(i+j))) with (S((S i)+j)) by intuition;
  rewrite <- (IHM2 N P (S i)); replace (S(i+j)) with ((S i)+ j) by intuition; intuition.
Qed.

Lemma subst_travers :
 forall  M N P n, (M [← N]) [n ← P] = (M [n+1 ← P])[← N[n← P]].
intros.
rewrite plus_comm. change n with (O+n). apply substP4.
Qed.

End term_mod.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 P Cprime B C : Universe, ((wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ C1 C2 /\ (wd_ Cprime P /\ (wd_ B P /\ (wd_ P C /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (wd_ Cprime B1 /\ (wd_ Cprime B2 /\ (wd_ P A1 /\ (wd_ P A2 /\ (wd_ B C /\ (wd_ Cprime C /\ (wd_ A1 Cprime /\ (wd_ A2 Cprime /\ (wd_ A1 C1 /\ (wd_ A1 C2 /\ (wd_ A2 C1 /\ (wd_ A2 C2 /\ (wd_ A2 B1 /\ (wd_ A2 B2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ C1 C2 Cprime /\ (col_ B B1 B2 /\ (col_ B P C /\ (col_ P P A1 /\ (col_ Cprime P C /\ col_ A1 B Cprime))))))))))))))))))))))))))))) -> col_ Cprime B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime S U1 A AX B BX C CX BXMAX CXMAX AB AC IAC T A1 A2 BXprimeprime CXprimeprime ABXprimeprime ACXprimeprime : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A1 A2 /\ (wd_ B BXprimeprime /\ (wd_ A BXprimeprime /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ S U1 /\ (col_ O E AX /\ (col_ O E BX /\ (col_ O E CX /\ (col_ O E BXMAX /\ (col_ O E CXMAX /\ (col_ O E T /\ (col_ O E AB /\ (col_ O E AC /\ (col_ O E IAC /\ (col_ A A1 A2 /\ (col_ A1 A2 BXprimeprime /\ (col_ A1 A2 CXprimeprime /\ (col_ O E ABXprimeprime /\ (col_ O E ACXprimeprime /\ col_ A B C)))))))))))))))))))))))) -> col_ A BXprimeprime CXprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Y P Z Q Qprime Cprime X : Universe, ((wd_ A Y /\ (wd_ P Y /\ (wd_ Q Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ A Z /\ (wd_ B Y /\ (wd_ Y Qprime /\ (wd_ Qprime Cprime /\ (wd_ Y Z /\ (wd_ Z X /\ (wd_ C Y /\ (wd_ P C /\ (wd_ Y Cprime /\ (col_ P Y Q /\ (col_ P Y C /\ (col_ P Q C /\ (col_ Y Q C /\ (col_ A Y B /\ (col_ A Y Z /\ (col_ Z Y X /\ (col_ Qprime Y Cprime /\ (col_ Q Z Qprime /\ col_ X C Cprime))))))))))))))))))))))))) -> col_ A B Z)).
Proof.
  time tac.
Qed.

End FOFProblem.