Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import liblayers.lib.Functor.
Require Import liblayers.lib.Monad.
Require Import liblayers.lib.Lens.
Require Export liblayers.lib.Lift.

(** * Prerequisites *)

(** We're going to lift the memory operations and theorems from a base
  type [bmem] to a "richer" type [mem], which contains [bmem] as a
  component. Formally, this means that we have a [Lens mem bmem] which
  provides us with well-behaved accessors to the [bmem] component
  inside of [mem]. While this is enough to lift most of the memory
  operations and theorems, we also need to know the value of
  the empty memory state of the richer type [mem]; indeed there's no
  way we would be able to construct that just from [empty : bmem].
  However, the simpler memory state contained within this empty [mem]
  should correspond to the empty [bmem] from the base memory states. *)

Class LiftMemoryModelOps {mem bmem: Type} (π: mem -> bmem)
  `{bmem_ops: Mem.MemoryModelOps bmem}
  `{bmem_set: !LensOps π} :=
{
  liftmem_empty: mem
}.

Class LiftMemoryModel {mem bmem: Type} (π: mem -> bmem)
  `{mem_liftops: LiftMemoryModelOps mem bmem π}: Prop :=
{
  liftmem_lens :> Lens π;
  liftmem_get_empty: π liftmem_empty = Mem.empty
}.

(** Using all of this, we can build a set of memory operations on the
  source type [mem] from the operations on the view type [bmem]. *)

Section LIFTOPS.
  Global Instance liftmem_ops `{mem_liftops: LiftMemoryModelOps}:
    Mem.MemoryModelOps mem :=
  {
    empty :=
      liftmem_empty;
    alloc wm lo hi :=
      lift π (fun m => Mem.alloc m lo hi) wm;
    nextblock wm :=
      lift π Mem.nextblock wm;
    free wm b lo hi :=
      lift π (fun m => Mem.free m b lo hi) wm;
    load chunk wm b ofs :=
      lift π (fun m => Mem.load chunk m b ofs) wm;
    store chunk wm b ofs v :=
      lift π (fun m => Mem.store chunk m b ofs v) wm;
    loadbytes wm b ofs n :=
      lift π (fun m => Mem.loadbytes m b ofs n) wm;
    storebytes wm b ofs vs :=
      lift π (fun m => Mem.storebytes m b ofs vs) wm;
    perm wm b ofs k p :=
      lift π (fun m => Mem.perm m b ofs k p) wm;
    valid_pointer wm b ofs :=
      lift π (fun m => Mem.valid_pointer m b ofs) wm;
    drop_perm wm b lo hi p :=
      lift π (fun m => Mem.drop_perm m b lo hi p) wm;
    extends wm1 wm2 :=
      lift π Mem.extends wm1 wm2;
    magree wm1 wm2 ls :=
      lift π (fun m1 m2 => Mem.magree m1 m2 ls) wm1 wm2;
    inject f wm1 wm2 :=
      lift π (Mem.inject f) wm1 wm2;
    inject_neutral thr wm :=
      lift π (Mem.inject_neutral thr) wm;
    unchanged_on P wm1 wm2 :=
      Mem.unchanged_on P (π wm1) (π wm2);
    strong_unchanged_on P wm1 wm2 :=
      lift π (Mem.strong_unchanged_on P) wm1 wm2
  }.
End LIFTOPS.

(** ** Properties of the [inject_incr] relation *)

(** Those are needed to enable rewriting using [liftmem_inject_same_context]. *)

Global Instance: Reflexive inject_incr.
Proof.
  firstorder.
Qed.

Global Instance: Transitive inject_incr.
Proof.
  firstorder.
Qed.

(** * Lifting the properties *)

Section LIFTDERIVED.
  Context `{HW: LiftMemoryModel}.

  (** Show that the operations derived from the [Mem.MemoryBaseOps]
    instance above are equivalent to lifting the operations derived
    from the original [Mem.MemoryBaseOps]. *)

  Theorem lift_loadv chunk wm addr:
    Mem.loadv chunk wm addr =
    lift π (fun m => Mem.loadv chunk m addr) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_storev chunk a v wm:
    Mem.storev chunk wm a v =
    lift π (fun m => Mem.storev chunk m a v) wm.
  Proof.
    unfold Mem.storev.
    destruct a; reflexivity.
  Qed.

  Theorem lift_free_list l wm:
    Mem.free_list wm l =
    lift π (fun m => Mem.free_list m l) wm.
  Proof with lift_auto.
    revert wm.
    induction l as [ | [[b lo] hi] l IHl]; intros...
    destruct (Mem.free (π wm) b lo hi)...
    rewrite IHl...
    destruct (Mem.free_list b0 l)...
  Qed.

  Theorem lift_valid_block (wm: mem) (b: block):
    Mem.valid_block wm b <->
    lift π (fun m => Mem.valid_block m b) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_range_perm (wm: mem) b lo hi k p:
    Mem.range_perm wm b lo hi k p <->
    lift π (fun m => Mem.range_perm m b lo hi k p) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_valid_access (wm: mem) chunk b ofs p:
    Mem.valid_access wm chunk b ofs p <->
    lift π (fun m => Mem.valid_access m chunk b ofs p) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_weak_valid_pointer (wm: mem) b ofs:
    Mem.weak_valid_pointer wm b ofs =
    lift π (fun m => Mem.weak_valid_pointer m b ofs) wm.
  Proof.
    reflexivity.
  Qed.

  Require Import Globalenvs.

  Theorem lift_genv_store_init_data {F V} (ge: Genv.t F V) (wm: mem) b ofs data:
    Genv.store_init_data ge wm b ofs data =
    lift π (fun m => Genv.store_init_data ge m b ofs data) wm.
  Proof.
    destruct data; simpl; eauto.
    - lift_unfold.
      reflexivity.
    - destruct (Genv.find_symbol ge i); eauto.
  Qed.

  Theorem lift_genv_store_init_data_list {F V} ge (wm: mem) b ofs data:
    Genv.store_init_data_list (F:=F) (V:=V) ge wm b ofs data =
    lift π (fun m => Genv.store_init_data_list ge m b ofs data) wm.
  Proof.
    revert wm b ofs.
    induction data; intros; simpl.
    - lift_unfold.
      reflexivity.
    - rewrite lift_genv_store_init_data.
      lift_unfold.
      destruct (Genv.store_init_data _ _ _ _ _); eauto.
      erewrite IHdata.
      lift_unfold.
      destruct (Genv.store_init_data_list _ _ _ _ _); eauto.
      lift_unfold.
      reflexivity.
  Qed.

  Theorem lift_store_zeros (wm: mem) b p n:
    store_zeros wm b p n =
    lift π (fun m => store_zeros m b p n) wm.
  Proof.
    pattern (store_zeros wm b p n).
    revert wm b p n.
    apply store_zeros_ind.
    - intros.
      setoid_rewrite store_zeros_equation.
      rewrite e.
      lift_unfold.
      reflexivity.
    - intros wm b p n Hn Hzle wm' Hwm' H.
      rewrite H; clear H.
      lift_unfold.
      destruct Hwm' as [Hwm' Hwm].
      setoid_rewrite store_zeros_equation at 2.
      rewrite Hzle.
      rewrite Hwm'.
      destruct (store_zeros _ _ _ _); eauto.
      f_equal.
      symmetry.
      apply Hwm.
    - intros wm b p n Hn Hzle H.
      lift_unfold.
      rewrite store_zeros_equation.
      rewrite Hzle.
      destruct (Mem.store _ _ _ _); congruence.
  Qed.

  Theorem lift_genv_alloc_global {F V} (ge: Genv.t F V) (wm: mem) init:
    Genv.alloc_global ge wm init =
    lift π (fun m => Genv.alloc_global ge m init) wm.
  Proof.
    unfold Genv.alloc_global.
    lift_unfold.
    destruct init as [_ [[f|v]|]].
    - destruct (Mem.alloc _ 0 1).
      lift_unfold.
      destruct (Mem.drop_perm _ _ _ _); eauto.
      lift_unfold.
      reflexivity.
    - destruct (Mem.alloc _ _ _) as [m b].
      rewrite lift_store_zeros.
      lift_unfold.
      destruct (store_zeros _ _ _ _); eauto.
      rewrite lift_genv_store_init_data_list.
      lift_unfold.
      destruct (Genv.store_init_data_list _ _ _ _ _); eauto.
      lift_unfold.
      destruct (Mem.drop_perm _ _ _ _ _); eauto.
      lift_unfold.
      reflexivity.
    - destruct (Mem.alloc _ _ _) as [m b].
      reflexivity.
  Qed.

  Theorem lift_genv_alloc_globals {F V} (ge: Genv.t F V) wm l:
    Genv.alloc_globals ge wm l =
    lift π (fun m => Genv.alloc_globals ge m l) wm.
  Proof.
    revert wm.
    induction l; intro wm.
    - simpl.
      lift_unfold.
      reflexivity.
    - simpl.
      rewrite lift_genv_alloc_global.
      lift_unfold.
      destruct (Genv.alloc_global _ _ _); eauto.
      rewrite IHl.
      lift_unfold.
      destruct (Genv.alloc_globals _ _ _); eauto.
      lift_unfold.
      reflexivity.
  Qed.

  Theorem lift_genv_init_mem {F V} (p: AST.program F V):
    Genv.init_mem (mem := mem) p =
    lift π (fun m => Genv.init_mem (mem := bmem) p) Mem.empty.
  Proof.
    unfold Genv.init_mem.
    rewrite lift_genv_alloc_globals.
    lift_unfold.
    rewrite liftmem_get_empty.
    reflexivity.
  Qed.
End LIFTDERIVED.

Hint Rewrite
  @lift_loadv
  @lift_storev
  @lift_free_list
  @lift_valid_block
  @lift_range_perm
  @lift_valid_access
  @lift_weak_valid_pointer
  @lift_genv_store_init_data
  @lift_genv_store_init_data_list
  @lift_store_zeros
  @lift_genv_alloc_global
  @lift_genv_alloc_globals
  @lift_genv_init_mem
  using typeclasses eauto : lift.

(** Replace [(get Mem.empty)] by the underlying [Mem.empty]. *)
Hint Rewrite
  @liftmem_get_empty
  using typeclasses eauto: lens.

Section LIFTMEM.
  Context mem bmem `{Hmem: LiftMemoryModel mem bmem}.

  Local Arguments fmap : simpl never.

  Global Instance liftmem_spec:
    Mem.MemoryModel bmem -> Mem.MemoryModel mem.
  Proof.
    intro Hbmem; esplit.
    lift π Mem.valid_not_valid_diff.
    lift π Mem.perm_implies.
    lift π Mem.perm_cur_max.
    lift π Mem.perm_cur.
    lift π Mem.perm_max.
    lift π Mem.perm_valid_block.
    lift π Mem.range_perm_implies.
    lift π Mem.range_perm_cur.
    lift π Mem.range_perm_max.
    lift π Mem.valid_access_implies.
    lift π Mem.valid_access_valid_block.
    lift π Mem.valid_access_perm.
    lift π Mem.valid_pointer_nonempty_perm.
    lift π Mem.valid_pointer_valid_access.
    lift π Mem.weak_valid_pointer_spec.
    lift π Mem.valid_pointer_implies.
    lift π Mem.nextblock_empty.
    lift π Mem.perm_empty.
    lift π Mem.valid_access_empty.
    lift π Mem.valid_access_load.
    lift π Mem.load_valid_access.
    lift π Mem.load_type.
    lift π Mem.load_cast.
    lift π Mem.load_int8_signed_unsigned.
    lift π Mem.load_int16_signed_unsigned.
    lift π Mem.loadv_int64_split.
    lift π Mem.range_perm_loadbytes.
    lift π Mem.loadbytes_range_perm.
    lift π Mem.loadbytes_load.
    lift π Mem.load_loadbytes.
    lift π Mem.loadbytes_length.
    lift π Mem.loadbytes_empty.
    lift π Mem.loadbytes_concat.
    lift π Mem.loadbytes_split.
    lift π Mem.nextblock_store.
    lift π Mem.store_valid_block_1.
    lift π Mem.store_valid_block_2.
    lift π Mem.perm_store_1.
    lift π Mem.perm_store_2.
    lift π Mem.valid_access_store'.
    lift π Mem.store_valid_access_1.
    lift π Mem.store_valid_access_2.
    lift π Mem.store_valid_access_3.
    lift π Mem.load_store_similar.
    lift π Mem.load_store_similar_2.
    lift π Mem.load_store_same.
    lift π Mem.load_store_other.
    lift π Mem.load_store_pointer_overlap.
    lift π Mem.load_store_pointer_mismatch.
    lift π Mem.load_pointer_store.
    lift π Mem.loadbytes_store_same.
    lift π Mem.loadbytes_store_other.
    lift π Mem.store_signed_unsigned_8.
    lift π Mem.store_signed_unsigned_16.
    lift π Mem.store_int8_zero_ext.
    lift π Mem.store_int8_sign_ext.
    lift π Mem.store_int16_zero_ext.
    lift π Mem.store_int16_sign_ext.
    lift π Mem.storev_int64_split.
    lift π Mem.range_perm_storebytes'.
    lift π Mem.storebytes_range_perm.
    lift π Mem.perm_storebytes_1.
    lift π Mem.perm_storebytes_2.
    lift π Mem.storebytes_valid_access_1.
    lift π Mem.storebytes_valid_access_2.
    lift π Mem.nextblock_storebytes.
    lift π Mem.storebytes_valid_block_1.
    lift π Mem.storebytes_valid_block_2.
    lift π Mem.storebytes_store.
    lift π Mem.store_storebytes.
    lift π Mem.loadbytes_storebytes_same.
    lift π Mem.loadbytes_storebytes_disjoint.
    lift π Mem.loadbytes_storebytes_other.
    lift π Mem.load_storebytes_other.
    lift π Mem.storebytes_concat.
    lift π Mem.storebytes_split.
    lift π Mem.alloc_result.
    lift π Mem.nextblock_alloc.
    lift π Mem.valid_block_alloc.
    lift π Mem.fresh_block_alloc.
    lift π Mem.valid_new_block.
    lift π Mem.valid_block_alloc_inv.
    lift π Mem.perm_alloc_1.
    lift π Mem.perm_alloc_2.
    lift π Mem.perm_alloc_3.
    lift π Mem.perm_alloc_4.
    lift π Mem.perm_alloc_inv.
    lift π Mem.valid_access_alloc_other.
    lift π Mem.valid_access_alloc_same.
    lift π Mem.valid_access_alloc_inv.
    lift π Mem.load_alloc_unchanged.
    lift π Mem.load_alloc_other.
    lift π Mem.load_alloc_same.
    lift π Mem.load_alloc_same'.
    lift π Mem.loadbytes_alloc_unchanged.
    lift π Mem.loadbytes_alloc_same.
    lift π Mem.range_perm_free'.
    lift π Mem.free_range_perm.
    lift π Mem.nextblock_free.
    lift π Mem.valid_block_free_1.
    lift π Mem.valid_block_free_2.
    lift π Mem.perm_free_1.
    lift π Mem.perm_free_2.
    lift π Mem.perm_free_3.
    lift π Mem.valid_access_free_1.
    lift π Mem.valid_access_free_2.
    lift π Mem.valid_access_free_inv_1.
    lift π Mem.valid_access_free_inv_2.
    lift π Mem.load_free.
    lift π Mem.loadbytes_free_2.
    lift π Mem.nextblock_drop.
    lift π Mem.drop_perm_valid_block_1.
    lift π Mem.drop_perm_valid_block_2.
    lift π Mem.range_perm_drop_1.
    lift π Mem.range_perm_drop_2'.
    lift π Mem.perm_drop_1.
    lift π Mem.perm_drop_2.
    lift π Mem.perm_drop_3.
    lift π Mem.perm_drop_4.
    lift π Mem.loadbytes_drop.
    lift π Mem.load_drop.
    lift π Mem.extends_refl.
    lift π Mem.load_extends.
    lift π Mem.loadv_extends.
    lift π Mem.loadbytes_extends.
    lift π Mem.store_within_extends.
    lift π Mem.store_outside_extends.
    lift π Mem.storev_extends.
    lift π Mem.storebytes_within_extends.
    lift π Mem.storebytes_outside_extends.
    lift π Mem.alloc_extends.
    lift π Mem.free_left_extends.
    lift π Mem.free_right_extends.
    lift π Mem.free_parallel_extends.
    lift π Mem.valid_block_extends.
    lift π Mem.perm_extends.
    lift π Mem.valid_access_extends.
    lift π Mem.valid_pointer_extends.
    lift π Mem.weak_valid_pointer_extends.
    lift π Mem.ma_perm.
    lift π Mem.magree_monotone.
    lift π Mem.mextends_agree.
    lift π Mem.magree_extends.
    lift π Mem.magree_loadbytes.
    lift π Mem.magree_load.
    lift π Mem.magree_storebytes_parallel.
    lift π Mem.magree_storebytes_left.
    lift π Mem.magree_store_left.
    lift π Mem.magree_free.
    lift π Mem.magree_valid_access.
    lift π Mem.mi_no_overlap.
    lift π Mem.valid_block_inject_1.
    lift π Mem.valid_block_inject_2.
    lift π Mem.perm_inject.
    lift π Mem.range_perm_inject.
    lift π Mem.valid_access_inject.
    lift π Mem.valid_pointer_inject.
    lift π Mem.weak_valid_pointer_inject.
    lift π Mem.address_inject.
    lift π Mem.address_inject'.
    lift π Mem.valid_pointer_inject_no_overflow.
    lift π Mem.weak_valid_pointer_inject_no_overflow.
    lift π Mem.valid_pointer_inject_val.
    lift π Mem.weak_valid_pointer_inject_val.
    lift π Mem.inject_no_overlap.
    lift π Mem.different_pointers_inject.
    lift π Mem.disjoint_or_equal_inject.
    lift π Mem.aligned_area_inject.
    lift π Mem.load_inject.
    lift π Mem.loadv_inject.
    lift π Mem.loadbytes_inject.
    lift π Mem.store_mapped_inject.
    lift π Mem.store_unmapped_inject.
    lift π Mem.store_outside_inject.
    lift π Mem.storev_mapped_inject.
    lift π Mem.storebytes_mapped_inject.
    lift π Mem.storebytes_unmapped_inject.
    lift π Mem.storebytes_outside_inject.
    lift π Mem.storebytes_empty_inject.
    lift π Mem.alloc_right_inject.
    lift π Mem.alloc_left_unmapped_inject.
    lift π Mem.alloc_left_mapped_inject.
    lift π Mem.alloc_parallel_inject.
    lift π Mem.free_inject.
    lift π Mem.free_left_inject.
    lift π Mem.free_list_left_inject.
    lift π Mem.free_right_inject.
    lift π Mem.free_parallel_inject.
    lift π Mem.drop_outside_inject.
    lift π Mem.self_inject.
    lift π Mem.extends_inject_compose.
    lift π Mem.extends_extends_compose.
    lift π Mem.neutral_inject.
    lift π Mem.empty_inject_neutral.
    lift π Mem.alloc_inject_neutral.
    lift π Mem.store_inject_neutral.
    lift π Mem.drop_inject_neutral.
    lift π Mem.strong_unchanged_on_weak.
    lift π Mem.unchanged_on_nextblock.
    lift π Mem.strong_unchanged_on_refl.
    lift π Mem.unchanged_on_trans.
    lift π Mem.strong_unchanged_on_trans.
    lift π Mem.perm_unchanged_on.
    lift π Mem.perm_unchanged_on_2.
    lift π Mem.loadbytes_unchanged_on_1.
    lift π Mem.loadbytes_unchanged_on.
    lift π Mem.load_unchanged_on_1.
    lift π Mem.load_unchanged_on.
    lift π Mem.store_strong_unchanged_on.
    lift π Mem.storebytes_strong_unchanged_on.
    lift π Mem.alloc_strong_unchanged_on.
    lift π Mem.free_strong_unchanged_on.
    lift π Mem.drop_perm_strong_unchanged_on.
    lift π Mem.unchanged_on_implies.
    lift π Mem.strong_unchanged_on_implies.
    lift π Mem.inject_strong_unchanged_on.
  Qed.
End LIFTMEM.


Global Generalizable All Variables.
Global Set Automatic Introduction.

Require Import MathClasses.theory.CoqStreams.
Require Export Coq.Classes.Morphisms Coq.Setoids.Setoid Coq.Program.Program Coq.Unicode.Utf8 Coq.Unicode.Utf8_core MathClasses.misc.stdlib_hints.

Definition id {A : Type} (a : A) := a.

(* Equality *)
Class Equiv A := equiv: relation A.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

(* Revert to transparency to allow conversions during unification. *)
#[global]
Typeclasses Transparent Equiv.
#[global]
Typeclasses Transparent compose flip.

Set Warnings "+unsupported-attributes".

(* We use this virtually everywhere, and so use "=" for it: *)
Infix "=" := equiv : type_scope.
Notation "(=)" := equiv (only parsing) : mc_scope.
Notation "( x =)" := (equiv x) (only parsing) : mc_scope.
Notation "(= x )" := (λ y, equiv y x) (only parsing) : mc_scope.
Notation "(≠)" := (λ x y, ¬x = y) (only parsing) : mc_scope.
Notation "x ≠ y":= (¬x = y): type_scope.
Notation "( x ≠)" := (λ y, x ≠ y) (only parsing) : mc_scope.
Notation "(≠ x )" := (λ y, y ≠ x) (only parsing) : mc_scope.

Delimit Scope mc_scope with mc.
Global Open Scope mc_scope.

#[global]
Hint Extern 2 (?x = ?x) => reflexivity.
#[global]
Hint Extern 2 (?x = ?y) => auto_symm.
#[global]
Hint Extern 2 (?x = ?y) => auto_trans.

(* Coq sometimes uses an incorrect DefaultRelation, so we override it. *)
#[global]
Instance equiv_default_relation `{Equiv A} : DefaultRelation (=) | 3 := {}.

(*
Because Coq does not support setoid rewriting in Type'd relations
we put apartness in Prop. This has as obvious disadvantage, that when an
implementation actually needs the witness from the apartness relation (e.g. for
division), it has to use something like [constructive_indefinite_description]
to extract it. This is quite inefficient and will also most likely block due
to proofs being Opaque. Nonetheless we do not think this is a problem because
for actual computation, one does not want to rely on some arbitrary witness
obtained by chaining a lot of proofs. Instead one would (and probably should)
specify an optimal witness by hand.

Another advantage of our approach is that classes describing structures (e.g.
Field) can remain in Prop.
*)
Class Apart A := apart: relation A.
Infix "≶" := apart (at level 70, no associativity) : mc_scope.
Notation "(≶)" := apart (only parsing) : mc_scope.
Notation "( x ≶)" := (apart x) (only parsing) : mc_scope.
Notation "(≶ x )" := (λ y, apart y x) (only parsing) : mc_scope.

(* Even for setoids with decidable equality x ≠ y does not imply x ≶ y.
Therefore we introduce the following class. *)
Class TrivialApart A `{Equiv A} {Aap : Apart A} := trivial_apart : ∀ x y, x ≶ y ↔ x ≠ y.

(* For Leibniz equality we use "≡", We do not define it as setoid equality with
low priority because sometimes we are interested in both setoid and Leibniz
equality on the same structure. *)
Infix "≡" := eq (at level 70, no associativity) : mc_scope.
Notation "(≡)" := eq (only parsing) : mc_scope.
Notation "( x ≡)" := (eq x) (only parsing) : mc_scope.
Notation "(≡ x )" := (λ y, eq y x) (only parsing) : mc_scope.
Notation "(≢)" := (λ x y, ¬x ≡ y) (only parsing) : mc_scope.
Notation "x ≢ y":= (¬x ≡ y) (at level 70, no associativity) : mc_scope.
Notation "( x ≢)" := (λ y, x ≢ y) (only parsing) : mc_scope.
Notation "(≢ x )" := (λ y, y ≢ x) (only parsing) : mc_scope.

(* Some common notions of equality *)
Definition ext_equiv `{Equiv A} `{Equiv B} : Equiv (A → B) := ((=) ==> (=))%signature.
#[global]
Hint Extern 10 (Equiv (_ → _)) => apply @ext_equiv : typeclass_instances.
#[global]
Hint Extern 10 (Equiv (relation _)) => apply @ext_equiv : typeclass_instances. (* Due to bug #2491 *)
(** Interestingly, most of the development works fine if this is defined as
  ∀ x, f x = g x.
However, in the end that version was just not strong enough for comfortable rewriting
in setoid-pervasive contexts. *)

Notation "x ↾ p" := (exist _ x p) (at level 20) : mc_scope.
Definition sig_equiv `{Equiv A} (P: A → Prop) : Equiv (sig P) := λ x y, `x = `y.
Ltac simpl_sig_equiv :=
  match goal with
  | |- (@equiv _ (@sig_equiv _ ?e _) (?x↾_) (?y↾_)) => change (@equiv _ e x y)
  end.
#[global]
Hint Extern 10 (Equiv (sig _)) => apply @sig_equiv : typeclass_instances.
#[global]
Hint Extern 4 (@equiv _ (sig_equiv _ _ _) (_↾_) (_↾_)) => simpl_sig_equiv.

Definition sigT_equiv `{Equiv A} (P: A → Type) : Equiv (sigT P) := λ a b, projT1 a = projT1 b.
#[global]
Hint Extern 10 (Equiv (sigT _)) => apply @sigT_equiv : typeclass_instances.

Definition sig_apart `{Apart A} (P: A → Prop) : Apart (sig P) := λ x y, `x ≶ `y.
#[global]
Hint Extern 10 (Apart (sig _)) => apply @sig_apart : typeclass_instances.

Class Cast A B := cast: A → B.
Arguments cast _ _ {Cast} _.
Notation "' x" := (cast _ _ x) (at level 20) : mc_scope.
#[global]
Instance: Params (@cast) 3 := {}.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Cast.

Set Warnings "+unsupported-attributes".

(* Other canonically named relations/operations/constants: *)
Class SgOp A := sg_op: A → A → A.
Class MonUnit A := mon_unit: A.
Class Plus A := plus: A → A → A.
Class Mult A := mult: A → A → A.
Class One A := one: A.
Class Zero A := zero: A.
Class Negate A := negate: A → A.
Class DecRecip A := dec_recip: A → A.
Definition ApartZero R `{Zero R} `{Apart R} := sig (≶ zero).
Class Recip A `{Apart A} `{Zero A} := recip: ApartZero A → A.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent SgOp MonUnit Plus Mult Zero One Negate.

Set Warnings "+unsupported-attributes".

Class Meet A := meet: A → A → A.
Class Join A := join: A → A → A.
Class Top A := top: A.
Class Bottom A := bottom: A.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Meet Join Top Bottom.

Set Warnings "+unsupported-attributes".

Class Contains A B := contains: A → B → Prop.
Class Singleton A B := singleton: A → B.
Class Difference A := difference : A → A → A.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Contains Singleton Difference.

Set Warnings "+unsupported-attributes".

Class Le A := le: relation A.
Class Lt A := lt: relation A.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Le Lt.

Set Warnings "+unsupported-attributes".

Definition NonNeg R `{Zero R} `{Le R} := sig (le zero).
Definition Pos R `{Zero R} `{Equiv R} `{Lt R} := sig (lt zero).
Definition NonPos R `{Zero R} `{Le R} := sig (λ y, le y zero).
Inductive PosInf (R : Type) : Type := finite (x : R) | infinite.

Class Arrows (O: Type): Type := Arrow: O → O → Type.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Arrows. (* Ideally this should be removed *)

Set Warnings "+unsupported-attributes".

Infix "⟶" := Arrow (at level 90, right associativity) : mc_scope.
Class CatId O `{Arrows O} := cat_id: ∀ x, x ⟶ x.
Class CatComp O `{Arrows O} := comp: ∀ x y z, (y ⟶ z) → (x ⟶ y) → (x ⟶ z).
Class RalgebraAction A B := ralgebra_action: A → B → B.

Arguments cat_id {O arrows CatId x} : rename.
Arguments comp {O arrow CatComp} _ _ _ _ _ : rename.

#[global]
Instance: Params (@mult) 2 := {}.
#[global]
Instance: Params (@plus) 2 := {}.
#[global]
Instance: Params (@negate) 2 := {}.
#[global]
Instance: Params (@equiv) 2 := {}.
#[global]
Instance: Params (@apart) 2 := {}.
#[global]
Instance: Params (@le) 2 := {}.
#[global]
Instance: Params (@lt) 2 := {}.
#[global]
Instance: Params (@recip) 4 := {}.
#[global]
Instance: Params (@dec_recip) 2 := {}.
#[global]
Instance: Params (@meet) 2 := {}.
#[global]
Instance: Params (@join) 2 := {}.
#[global]
Instance: Params (@contains) 3 := {}.
#[global]
Instance: Params (@singleton) 3 := {}.
#[global]
Instance: Params (@difference) 2 := {}.

#[global]
Instance plus_is_sg_op `{f : Plus A} : SgOp A := f.
#[global]
Instance mult_is_sg_op `{f : Mult A} : SgOp A := f.
#[global]
Instance one_is_mon_unit `{c : One A} : MonUnit A := c.
#[global]
Instance zero_is_mon_unit `{c : Zero A} : MonUnit A := c.
#[global]
Instance meet_is_sg_op `{f : Meet A} : SgOp A := f.
#[global]
Instance join_is_sg_op `{f : Join A} : SgOp A := f.
#[global]
Instance top_is_mon_unit `{s : Top A} : MonUnit A := s.
#[global]
Instance bottom_is_mon_unit `{s : Bottom A} : MonUnit A := s.
#[global]
Instance singleton_is_cast `{s : Singleton A B} : Cast A B := s.

#[global]
Hint Extern 10 (Equiv (_ ⟶ _)) => apply @ext_equiv : typeclass_instances.
#[global]
Hint Extern 4 (Equiv (ApartZero _)) => apply @sig_equiv : typeclass_instances.
#[global]
Hint Extern 4 (Equiv (NonNeg _)) => apply @sig_equiv : typeclass_instances.
#[global]
Hint Extern 4 (Equiv (Pos _)) => apply @sig_equiv : typeclass_instances.
#[global]
Hint Extern 4 (Equiv (PosInf _)) => apply @sig_equiv : typeclass_instances.
#[global]
Hint Extern 4 (Apart (ApartZero _)) => apply @sig_apart : typeclass_instances.
#[global]
Hint Extern 4 (Apart (NonNeg _)) => apply @sig_apart : typeclass_instances.
#[global]
Hint Extern 4 (Apart (Pos _)) => apply @sig_apart : typeclass_instances.
#[global]
Hint Extern 4 (Apart (PosInf _)) => apply @sig_apart : typeclass_instances.

(* Notations: *)
Notation "R ₀" := (ApartZero R) (at level 20, no associativity) : mc_scope.
Notation "R ⁺" := (NonNeg R) (at level 20, no associativity) : mc_scope.
Notation "R ₊" := (Pos R) (at level 20, no associativity) : mc_scope.
Notation "R ⁻" := (NonPos R) (at level 20, no associativity) : mc_scope.
Notation "R ∞" := (PosInf R) (at level 20, no associativity) : mc_scope.

Infix "&" := sg_op (at level 50, left associativity) : mc_scope.
Notation "(&)" := sg_op (only parsing) : mc_scope.
Notation "( x &)" := (sg_op x) (only parsing) : mc_scope.
Notation "(& x )" := (λ y, y & x) (only parsing) : mc_scope.

Infix "+" := plus : mc_scope.
Notation "(+)" := plus (only parsing) : mc_scope.
Notation "( x +)" := (plus x) (only parsing) : mc_scope.
Notation "(+ x )" := (λ y, y + x) (only parsing) : mc_scope.

Infix "*" := mult : mc_scope.
(* We don't add "( * )", "( * x )" and "( x * )" notations because they conflict with comments. *)
Notation "( x *.)" := (mult x) (only parsing) : mc_scope.
Notation "(.*.)" := mult (only parsing) : mc_scope.
Notation "(.* x )" := (λ y, y * x) (only parsing) : mc_scope.

Notation "- x" := (negate x) : mc_scope.
Notation "(-)" := negate (only parsing) : mc_scope.
Notation "x - y" := (x + -y) : mc_scope.

Notation "0" := zero : mc_scope.
Notation "1" := one : mc_scope.
Notation "2" := (1 + 1) : mc_scope.
Notation "3" := (1 + (1 + 1)) : mc_scope.
Notation "4" := (1 + (1 + (1 + 1))) : mc_scope.
Notation "- 1" := (-(1)) : mc_scope.
Notation "- 2" := (-(2)) : mc_scope.
Notation "- 3" := (-(3)) : mc_scope.
Notation "- 4" := (-(4)) : mc_scope.

Notation "/ x" := (dec_recip x) : mc_scope.
Notation "(/)" := dec_recip (only parsing) : mc_scope.
Notation "x / y" := (x * /y) : mc_scope.

Notation "// x" := (recip x) (at level 35, right associativity) : mc_scope.
Notation "(//)" := recip (only parsing) : mc_scope.
Notation "x // y" := (x * //y) (at level 35, right associativity) : mc_scope.

Notation "⊤" := top : mc_scope.
Notation "⊥" := bottom : mc_scope.

Infix "⊓" := meet (at level 50, no associativity) : mc_scope.
Notation "(⊓)" := meet (only parsing) : mc_scope.
Notation "( X ⊓)" := (meet X) (only parsing) : mc_scope.
Notation "(⊓ X )" := (λ Y, Y ⊓ X) (only parsing) : mc_scope.

Infix "⊔" := join (at level 50, no associativity) : mc_scope.
Notation "(⊔)" := join (only parsing) : mc_scope.
Notation "( X ⊔)" := (join X) (only parsing) : mc_scope.
Notation "(⊔ X )" := (λ Y, Y ⊔ X) (only parsing) : mc_scope.

Infix "≤" := le : mc_scope.
Notation "(≤)" := le (only parsing) : mc_scope.
Notation "( x ≤)" := (le x) (only parsing) : mc_scope.
Notation "(≤ x )" := (λ y, y ≤ x) (only parsing) : mc_scope.

Infix "<" := lt : mc_scope.
Notation "(<)" := lt (only parsing) : mc_scope.
Notation "( x <)" := (lt x) (only parsing) : mc_scope.
Notation "(< x )" := (λ y, y < x) (only parsing) : mc_scope.

Notation "x ≤ y ≤ z" := (x ≤ y ∧ y ≤ z) (at level 70, y at next level) : mc_scope.
Notation "x ≤ y < z" := (x ≤ y ∧ y < z) (at level 70, y at next level) : mc_scope.
Notation "x < y < z" := (x < y ∧ y < z) (at level 70, y at next level) : mc_scope.
Notation "x < y ≤ z" := (x < y ∧ y ≤ z) (at level 70, y at next level) : mc_scope.

Infix "∖" := difference (at level 35) : mc_scope.
Notation "(∖)" := difference (only parsing) : mc_scope.
Notation "( X ∖)" := (difference X) (only parsing) : mc_scope.
Notation "(∖ X )" := (λ Y, Y ∖ X) (only parsing) : mc_scope.

Infix "∈" := contains (at level 70, no associativity) : mc_scope.
Notation "(∈)" := contains (only parsing) : mc_scope.
Notation "( x ∈)" := (contains x) (only parsing) : mc_scope.
Notation "(∈ X )" := (λ x, x ∈ X) (only parsing) : mc_scope.

Notation "x ∉ y" := (¬x ∈ y) (at level 70, no associativity) : mc_scope.
Notation "(∉)" := (λ x X, x ∉ X) : mc_scope.
Notation "( x ∉)" := (λ X, x ∉ X) (only parsing) : mc_scope.
Notation "(∉ X )" := (λ x, x ∉ X) (only parsing) : mc_scope.

Notation "{{ x }}" := (singleton x) : mc_scope.
Notation "{{ x ; y ; .. ; z }}" := (join .. (join (singleton x) (singleton y)) .. (singleton z)) : mc_scope.

Infix "◎" := (comp _ _ _) (at level 40, left associativity) : mc_scope.
  (* Taking over ∘ is just a little too zealous at this point. With our current
   approach, it would require changing all (nondependent) function types A → B
   with A ⟶ B to make them use the canonical name for arrows, which is
   a tad extreme. *)
Notation "(◎)" := (comp _ _ _) (only parsing) : mc_scope.
Notation "( f ◎)" := (comp _ _ _ f) (only parsing) : mc_scope.
Notation "(◎ f )" := (λ g, comp _ _ _ g f) (only parsing) : mc_scope.

(* Haskell style! *)
Notation "(→)" := (λ x y, x → y) : mc_scope.
Notation "t $ r" := (t r) (at level 65, right associativity, only parsing) : mc_scope.
Notation "(∘)" := compose (only parsing) : mc_scope.

(* Agda style! *)
Notation "∞ X" := (Stream X) (at level 23) : mc_scope.
Infix ":::" := Cons (at level 60, right associativity) : mc_scope.
Notation "(:::)" := Cons (only parsing) : mc_scope.
Notation "(::: X )" := (λ x, Cons x X) (only parsing) : mc_scope.
Notation "( x :::)" := (Cons x) (only parsing) : mc_scope.

#[global]
Hint Extern 2 (?x ≤ ?y) => reflexivity.
#[global]
Hint Extern 4 (?x ≤ ?z) => auto_trans.
#[global]
Hint Extern 4 (?x < ?z) => auto_trans.

Class Abs A `{Equiv A} `{Le A} `{Zero A} `{Negate A} := abs_sig: ∀ (x : A), { y : A | (0 ≤ x → y = x) ∧ (x ≤ 0 → y = -x)}.
Definition abs `{Abs A} := λ x : A, ` (abs_sig x).
#[global]
Instance: Params (@abs_sig) 6 := {}.
#[global]
Instance: Params (@abs) 6 := {}.

(* Common properties: *)
Class Inverse `(A → B) : Type := inverse: B → A.
Arguments inverse {A B} _ {Inverse} _.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Inverse.

Set Warnings "+unsupported-attributes".

Notation "f ⁻¹" := (inverse f) (at level 30) : mc_scope.

Class Idempotent `{ea : Equiv A} (f: A → A → A) (x : A) : Prop := idempotency: f x x = x.
Arguments idempotency {A ea} _ _ {Idempotent}.

Class UnaryIdempotent `{Equiv A} (f: A → A) : Prop := unary_idempotent :> Idempotent (@compose A A A) f.

Lemma unary_idempotency `{Equiv A} `{!Reflexive (=)} `{!UnaryIdempotent f} x : f (f x) = f x.
Proof. firstorder. Qed.

Class BinaryIdempotent `{Equiv A} (op: A → A → A) : Prop := binary_idempotent :> ∀ x, Idempotent op x.

Class LeftIdentity {A} `{Equiv B} (op : A → B → B) (x : A): Prop := left_identity: ∀ y, op x y = y.
Class RightIdentity `{Equiv A} {B} (op : A → B → A) (y : B): Prop := right_identity: ∀ x, op x y = x.

Class Absorption `{Equiv A} {B} {C} (op1: A → C → A) (op2: A → B → C) : Prop := absorption: ∀ x y, op1 x (op2 x y) = x.

Class LeftAbsorb `{Equiv A} {B} (op : A → B → A) (x : A): Prop := left_absorb: ∀ y, op x y = x.
Class RightAbsorb {A} `{Equiv B} (op : A → B → B) (y : B): Prop := right_absorb: ∀ x, op x y = y.

Class LeftInverse {A} {B} `{Equiv C} (op : A → B → C) (inv : B → A) (unit : C) := left_inverse: ∀ x, op (inv x) x = unit.
Class RightInverse {A} {B} `{Equiv C} (op : A → B → C) (inv : A → B) (unit : C) := right_inverse: ∀ x, op x (inv x) = unit.

Class Commutative `{Equiv B} `(f : A → A → B) : Prop := commutativity: ∀ x y, f x y = f y x.

Class HeteroAssociative {A B C AB BC} `{Equiv ABC}
     (fA_BC: A → BC → ABC) (fBC: B → C → BC) (fAB_C: AB → C → ABC) (fAB : A → B → AB): Prop
   := associativity : ∀ x y z, fA_BC x (fBC y z) = fAB_C (fAB x y) z.
Class Associative `{Equiv A} f := simple_associativity:> HeteroAssociative f f f f.
Notation ArrowsAssociative C := (∀ {w x y z: C}, HeteroAssociative (◎) (comp z _ _ ) (◎) (comp y x w)).

Class Involutive `{Equiv A} (f : A → A) := involutive: ∀ x, f (f x) = x.

Class TotalRelation `(R : relation A) : Prop := total : ∀ x y : A, R x y ∨ R y x.
Arguments total {A} _ {TotalRelation} _ _.

Class Trichotomy `{Ae : Equiv A} `(R : relation A) := trichotomy : ∀ x y : A, R x y ∨ x = y ∨ R y x.
Arguments trichotomy {A Ae} _ {Trichotomy} _ _.

Arguments irreflexivity {A} _ {Irreflexive} _ _.

Class CoTransitive `(R : relation A) : Prop := cotransitive : ∀ x y, R x y → ∀ z, R x z ∨ R z y.
Arguments cotransitive {A R CoTransitive x y} _ _.

Class AntiSymmetric `{Ae : Equiv A} (R : relation A) : Prop := antisymmetry: ∀ x y, R x y → R y x → x = y.
Arguments antisymmetry {A Ae} _ {AntiSymmetric} _ _ _ _.

Class LeftHeteroDistribute {A B} `{Equiv C} (f : A → B → C) (g_r : B → B → B) (g : C → C → C) : Prop
  := distribute_l : ∀ a b c, f a (g_r b c) = g (f a b) (f a c).
Class RightHeteroDistribute {A B} `{Equiv C} (f : A → B → C) (g_l : A → A → A) (g : C → C → C) : Prop
  := distribute_r: ∀ a b c, f (g_l a b) c = g (f a c) (f b c).
Class LeftDistribute`{Equiv A} (f g: A → A → A) := simple_distribute_l :> LeftHeteroDistribute f g g.
Class RightDistribute `{Equiv A} (f g: A → A → A) := simple_distribute_r :> RightHeteroDistribute f g g.

Class HeteroSymmetric {A} {T : A → A → Type} (R : ∀ {x y}, T x y → T y x → Prop) : Prop :=
  hetero_symmetric `(a : T x y) (b : T y x) : R a b → R b a.

(* Although cancellation is the same as being injective, we want a proper
  name to refer to this commonly used property. *)
Section cancellation.
  Context `{Ae : Equiv A} `{Aap : Apart A} (op : A → A → A) (z : A).

  Class LeftCancellation := left_cancellation : ∀ x y, op z x = op z y → x = y.
  Class RightCancellation := right_cancellation : ∀ x y, op x z = op y z → x = y.

  Class StrongLeftCancellation := strong_left_cancellation : ∀ x y, x ≶ y → op z x ≶ op z y.
  Class StrongRightCancellation := strong_right_cancellation : ∀ x y, x ≶ y → op x z ≶ op y z.
End cancellation.

(* Common names for properties that hold in N, Z, Q, ... *)
Class ZeroProduct A `{Equiv A} `{!Mult A} `{!Zero A} : Prop
  := zero_product : ∀ x y, x * y = 0 → x = 0 ∨ y = 0.

Class ZeroDivisor {R} `{Equiv R} `{Zero R} `{Mult R} (x : R) : Prop
  := zero_divisor : x ≠ 0 ∧ ∃ y, y ≠ 0 ∧ x * y = 0.

Class NoZeroDivisors R `{Equiv R} `{Zero R} `{Mult R} : Prop
  := no_zero_divisors x : ¬ZeroDivisor x.

#[global]
Instance zero_product_no_zero_divisors `{ZeroProduct A} : NoZeroDivisors A.
Proof. intros x [? [? [? E]]]. destruct (zero_product _ _ E); intuition. Qed.

Class RingUnit `{Equiv R} `{Mult R} `{One R} (x : R) : Prop := ring_unit : ∃ y, x * y = 1.

(* A common induction principle for both the naturals and integers *)
Class Biinduction R `{Equiv R} `{Zero R} `{One R} `{Plus R} : Prop
  := biinduction (P : R → Prop) `{!Proper ((=) ==> iff) P} : P 0 → (∀ n, P n ↔ P (1 + n)) → ∀ n, P n.


Require Export ProjectiveGeometry.Dev.fano_matroid_tactics.
Require Export ProjectiveGeometry.Dev.basic_rank_plane_list.

Lemma triple_rk3_to_quadruple_rk3 : forall P Q R S : Point,
rk(P :: Q ::  R :: nil) = 3 -> rk(P :: Q :: R :: S :: nil) = 3.
Proof.
intros.
assert(HH : incl (P :: Q :: R :: nil) (P :: Q :: R :: S :: nil));[my_inO|].
assert(HH0 := matroid2 (P :: Q :: R :: nil) (P :: Q :: R :: S :: nil) HH).
assert(HH1 := rk_quadruple_max_3 P Q R S).
omega.
Qed.

Lemma quadruple_rk2_to_triple_rk2 : forall P Q R S : Point,
~ P = Q -> rk(P :: Q ::  R :: S :: nil) = 2 -> rk(P :: Q :: R :: nil) = 2.
Proof.
intros.
assert(HH : incl (P :: Q :: R :: nil) (P :: Q :: R :: S :: nil));[my_inO|].
assert(HH0 := matroid2 (P :: Q :: R :: nil) (P :: Q :: R :: S :: nil) HH).
assert(HH1 := rk_couple P Q H).
assert(HH2 : incl (P :: Q :: nil) (P :: Q :: R :: nil));[my_inO|].
assert(HH3 := matroid2 (P :: Q :: nil) (P :: Q :: R :: nil) HH2).
omega.
Qed.

Ltac rk_quadruple :=
match goal with
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?A :: ?B :: ?C :: ?D :: nil) = _ => assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?A :: ?B :: ?D :: ?C :: nil) = _ => rewrite <-quadruple_equal_1;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?A :: ?C :: ?A :: ?D :: nil) = _ => rewrite <-quadruple_equal_2;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?A :: ?C :: ?D :: ?A :: nil) = _ => rewrite <-quadruple_equal_3;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?A :: ?D :: ?A :: ?C :: nil) = _ => rewrite <-quadruple_equal_4;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?A :: ?D :: ?C :: ?A :: nil) = _ => rewrite <-quadruple_equal_5;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?B :: ?A :: ?C :: ?D :: nil) = _ => rewrite <-quadruple_equal_6;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?B :: ?A :: ?D :: ?C :: nil) = _ => rewrite <-quadruple_equal_7;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?B :: ?C :: ?A :: ?D :: nil) = _ => rewrite <-quadruple_equal_8;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?B :: ?C :: ?D :: ?A :: nil) = _ => rewrite <-quadruple_equal_9;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?B :: ?D :: ?A :: ?C :: nil) = _ => rewrite <-quadruple_equal_10;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?B :: ?D :: ?C :: ?A :: nil) = _ => rewrite <-quadruple_equal_11;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?C :: ?A :: ?B :: ?D :: nil) = _ => rewrite <-quadruple_equal_12;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?C :: ?A :: ?D :: ?B :: nil) = _ => rewrite <-quadruple_equal_13;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?C :: ?B :: ?A :: ?D :: nil) = _ => rewrite <-quadruple_equal_14;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?C :: ?B :: ?D :: ?A :: nil) = _ => rewrite <-quadruple_equal_15;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?C :: ?D :: ?A :: ?B :: nil) = _ => rewrite <-quadruple_equal_16;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?C :: ?D :: ?B :: ?A :: nil) = _ => rewrite <-quadruple_equal_17;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?D :: ?A :: ?B :: ?C :: nil) = _ => rewrite <-quadruple_equal_18;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?D :: ?A :: ?C :: ?B :: nil) = _ => rewrite <-quadruple_equal_19;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?D :: ?B :: ?A :: ?C :: nil) = _ => rewrite <-quadruple_equal_20;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?D :: ?B :: ?C :: ?A :: nil) = _ => rewrite <-quadruple_equal_21;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?D :: ?C :: ?A :: ?B :: nil) = _ => rewrite <-quadruple_equal_22;assumption
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = _ |- rk(?D :: ?C :: ?B :: ?A :: nil) = _ => rewrite <-quadruple_equal_23;assumption
end.

Ltac rk_quadruple_bis A B C D:=
match goal with
| H0 : rk(A :: B :: C :: D :: nil) = _ |- _ => assumption
| H0 : rk(A :: B :: D :: C :: nil) = _ |- _ => rewrite <-quadruple_equal_1 in H0;assumption
| H0 : rk(A :: C :: B :: D :: nil) = _ |- _ => rewrite <-quadruple_equal_2 in H0;assumption
| H0 : rk(A :: C :: D :: B :: nil) = _ |- _ => rewrite <-quadruple_equal_3 in H0;assumption
| H0 : rk(A :: D :: B :: C :: nil) = _ |- _ => rewrite <-quadruple_equal_4 in H0;assumption
| H0 : rk(A :: D :: C :: B :: nil) = _ |- _ => rewrite <-quadruple_equal_5 in H0;assumption
| H0 : rk(B :: A :: C :: D :: nil) = _ |- _ => rewrite <-quadruple_equal_6 in H0;assumption
| H0 : rk(B :: A :: D :: C :: nil) = _ |- _ => rewrite <-quadruple_equal_7 in H0;assumption
| H0 : rk(B :: C :: A :: D :: nil) = _ |- _ => rewrite <-quadruple_equal_8 in H0;assumption
| H0 : rk(B :: C :: D :: A :: nil) = _ |- _ => rewrite <-quadruple_equal_9 in H0;assumption
| H0 : rk(B :: D :: A :: C :: nil) = _ |- _ => rewrite <-quadruple_equal_10 in H0;assumption
| H0 : rk(B :: D :: C :: A :: nil) = _ |- _ => rewrite <-quadruple_equal_11 in H0;assumption
| H0 : rk(C :: A :: B :: D :: nil) = _ |- _ => rewrite <-quadruple_equal_12 in H0;assumption
| H0 : rk(C :: A :: D :: B :: nil) = _ |- _ => rewrite <-quadruple_equal_13 in H0;assumption
| H0 : rk(C :: B :: A :: D :: nil) = _ |- _ => rewrite <-quadruple_equal_14 in H0;assumption
| H0 : rk(C :: B :: D :: A :: nil) = _ |- _ => rewrite <-quadruple_equal_15 in H0;assumption
| H0 : rk(C :: D :: A :: B :: nil) = _ |- _ => rewrite <-quadruple_equal_16 in H0;assumption
| H0 : rk(C :: D :: B :: A :: nil) = _ |- _ => rewrite <-quadruple_equal_17 in H0;assumption
| H0 : rk(D :: A :: B :: C :: nil) = _ |- _ => rewrite <-quadruple_equal_18 in H0;assumption
| H0 : rk(D :: A :: C :: B :: nil) = _ |- _ => rewrite <-quadruple_equal_19 in H0;assumption
| H0 : rk(D :: B :: A :: C :: nil) = _ |- _ => rewrite <-quadruple_equal_20 in H0;assumption
| H0 : rk(D :: B :: C :: A :: nil) = _ |- _ => rewrite <-quadruple_equal_21 in H0;assumption
| H0 : rk(D :: C :: A :: B :: nil) = _ |- _ => rewrite <-quadruple_equal_22 in H0;assumption
| H0 : rk(D :: C :: B :: A :: nil) = _ |- _ => rewrite <-quadruple_equal_23 in H0;assumption
end.

Ltac rk_quadruple_bis_bis :=
match goal with
| H : _ |- rk(?A :: ?B :: ?C :: ?D :: nil) = 2 => solve[rk_quadruple_bis A B C D]
end.

Ltac rk_quadruple_2_3_bis HH0 A B C D:=
match goal with
| H0 : rk(A :: B :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A B C D H0));rewrite HH in HH0;inversion HH0
| H0 : rk(A :: B :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A B D C H0));rewrite <-quadruple_equal_1 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(A :: C :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A C B D H0));rewrite <-quadruple_equal_2 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(A :: C :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A C D B H0));rewrite <-quadruple_equal_3 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(A :: D :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A D B C H0));rewrite <-quadruple_equal_4 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(A :: D :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A D C B H0));rewrite <-quadruple_equal_5 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(B :: A :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B A C D H0));rewrite <-quadruple_equal_6 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(B :: A :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B A D C H0));rewrite <-quadruple_equal_7 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(B :: C :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B C A D H0));rewrite <-quadruple_equal_8 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(B :: C :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B C D A H0));rewrite <-quadruple_equal_9 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(B :: D :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B D A C H0));rewrite <-quadruple_equal_10 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(B :: D :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B D C A H0));rewrite <-quadruple_equal_11 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(C :: A :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C A B D H0));rewrite <-quadruple_equal_12 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(C :: A :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C A D B H0));rewrite <-quadruple_equal_13 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(C :: B :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C B A D H0));rewrite <-quadruple_equal_14 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(C :: B :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C B D A H0));rewrite <-quadruple_equal_15 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(C :: D :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C D A B H0));rewrite <-quadruple_equal_16 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(C :: D :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C D B A H0));rewrite <-quadruple_equal_17 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(D :: A :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D A B C H0));rewrite <-quadruple_equal_18 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(D :: A :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D A C B H0));rewrite <-quadruple_equal_19 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(D :: B :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D B A C H0));rewrite <-quadruple_equal_20 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(D :: B :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D B C A H0));rewrite <-quadruple_equal_21 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(D :: C :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D C A B H0));rewrite <-quadruple_equal_22 in HH;rewrite HH in HH0;inversion HH0
| H0 : rk(D :: C :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D C B A H0));rewrite <-quadruple_equal_23 in HH;rewrite HH in HH0;inversion HH0
end.

Ltac rk_quadruple_2_3_bis_bis :=
match goal with
| H : rk(?A :: ?B :: ?C :: ?D :: nil) = 2 |- _ => solve[rk_quadruple_2_3_bis H A B C D]
end.

Ltac rk_quadruple_to_triple_bis A B C D:=
match goal with
| H0 : rk(A :: B :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A B C D H0));assumption
| H0 : rk(A :: B :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A B D C H0));rewrite <-quadruple_equal_1 in HH;assumption
| H0 : rk(A :: C :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A C B D H0));rewrite <-quadruple_equal_2 in HH;assumption
| H0 : rk(A :: C :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A C D B H0));rewrite <-quadruple_equal_3 in HH;assumption
| H0 : rk(A :: D :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A D B C H0));rewrite <-quadruple_equal_4 in HH;assumption
| H0 : rk(A :: D :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 A D C B H0));rewrite <-quadruple_equal_5 in HH;assumption
| H0 : rk(B :: A :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B A C D H0));rewrite <-quadruple_equal_6 in HH;assumption
| H0 : rk(B :: A :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B A D C H0));rewrite <-quadruple_equal_7 in HH;assumption
| H0 : rk(B :: C :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B C A D H0));rewrite <-quadruple_equal_8 in HH;assumption
| H0 : rk(B :: C :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B C D A H0));rewrite <-quadruple_equal_9 in HH;assumption
| H0 : rk(B :: D :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B D A C H0));rewrite <-quadruple_equal_10 in HH;assumption
| H0 : rk(B :: D :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 B D C A H0));rewrite <-quadruple_equal_11 in HH;assumption
| H0 : rk(C :: A :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C A B D H0));rewrite <-quadruple_equal_12 in HH;assumption
| H0 : rk(C :: A :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C A D B H0));rewrite <-quadruple_equal_13 in HH;assumption
| H0 : rk(C :: B :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C B A D H0));rewrite <-quadruple_equal_14 in HH;assumption
| H0 : rk(C :: B :: D :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C B D A H0));rewrite <-quadruple_equal_15 in HH;assumption
| H0 : rk(C :: D :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C D A B H0));rewrite <-quadruple_equal_16 in HH;assumption
| H0 : rk(C :: D :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 C D B A H0));rewrite <-quadruple_equal_17 in HH;assumption
| H0 : rk(D :: A :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D A B C H0));rewrite <-quadruple_equal_18 in HH;assumption
| H0 : rk(D :: A :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D A C B H0));rewrite <-quadruple_equal_19 in HH;assumption
| H0 : rk(D :: B :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D B A C H0));rewrite <-quadruple_equal_20 in HH;assumption
| H0 : rk(D :: B :: C :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D B C A H0));rewrite <-quadruple_equal_21 in HH;assumption
| H0 : rk(D :: C :: A :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D C A B H0));rewrite <-quadruple_equal_22 in HH;assumption
| H0 : rk(D :: C :: B :: nil) = 3 |- _ => let HH := fresh in (assert(HH := triple_rk3_to_quadruple_rk3 D C B A H0));rewrite <-quadruple_equal_23 in HH;assumption
end.

Ltac rk_quadruple_to_triple_bis_bis:=
match goal with
| H : _ |- rk(?A :: ?B :: ?C :: ?D :: nil) = 3 => solve[rk_quadruple_to_triple_bis A B C D]
end.

Ltac rk_triple_to_quadruple_bis A B C :=
match goal with
| H0 : rk(A :: B :: C :: ?D :: nil) = 2 |- _ => let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(A :: B :: ?D :: C :: nil) = 2 |- _ => rewrite <-quadruple_equal_1 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(A :: C :: B :: ?D :: nil) = 2 |- _ => rewrite <-quadruple_equal_2 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(A :: C :: ?D :: B :: nil) = 2 |- _ => rewrite <-quadruple_equal_3 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(A :: ?D :: B :: C :: nil) = 2 |- _ => rewrite <-quadruple_equal_4 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(A :: ?D :: C :: B :: nil) = 2 |- _ => rewrite <-quadruple_equal_5 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(B :: A :: C :: ?D :: nil) = 2 |- _ => rewrite <-quadruple_equal_6 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(B :: A :: ?D :: C :: nil) = 2 |- _ => rewrite <-quadruple_equal_7 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(B :: C :: A :: ?D :: nil) = 2 |- _ => rewrite <-quadruple_equal_8 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(B :: C :: ?D :: A :: nil) = 2 |- _ => rewrite <-quadruple_equal_9 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(B :: ?D :: A :: C :: nil) = 2 |- _ => rewrite <-quadruple_equal_10 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(B :: ?D :: C :: A :: nil) = 2 |- _ => rewrite <-quadruple_equal_11 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(C :: A :: B :: ?D :: nil) = 2 |- _ => rewrite <-quadruple_equal_12 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(C :: A :: ?D :: B :: nil) = 2 |- _ => rewrite <-quadruple_equal_13 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(C :: B :: A :: ?D :: nil) = 2 |- _ => rewrite <-quadruple_equal_14 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(C :: B :: ?D :: A :: nil) = 2 |- _ => rewrite <-quadruple_equal_15 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(C :: ?D :: A :: B :: nil) = 2 |- _ => rewrite <-quadruple_equal_16 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(C :: ?D :: B :: A :: nil) = 2 |- _ => rewrite <-quadruple_equal_17 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(?D :: A :: B :: C :: nil) = 2 |- _ => rewrite <-quadruple_equal_18 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(?D :: A :: C :: B :: nil) = 2 |- _ => rewrite <-quadruple_equal_19 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(?D :: B :: A :: C :: nil) = 2 |- _ => rewrite <-quadruple_equal_20 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(?D :: B :: C :: A :: nil) = 2 |- _ => rewrite <-quadruple_equal_21 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(?D :: C :: A :: B :: nil) = 2 |- _ => rewrite <-quadruple_equal_22 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
| H0 : rk(?D :: C :: B :: A :: nil) = 2 |- _ => rewrite <-quadruple_equal_23 in H0;let HH := fresh in assert(HH : rk(A :: B :: C :: nil) = 2) by (apply (quadruple_rk2_to_triple_rk2 A B C D);assumption);assumption
end.

Ltac rk_triple_to_quadruple_bis_bis :=
match goal with
| H : _ |- rk(?A :: ?B :: ?C :: nil) = 2 => solve[rk_triple_to_quadruple_bis A B C]
end.

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

Lemma eq_neg_reverse :
forall A B : Point, ~ A = B -> ~ B = A /\ ~ A = B.
Proof.
intros.
intuition.
Qed.

Ltac eq_duplicate :=
repeat match goal with
| H : ~ ?X = ?Y  |- _ => let HH := fresh in (assert(HH := eq_neg_reverse X Y H));clear H
end.

Lemma triple_rk2_1 : forall P R, P <> R -> rk(P :: P :: R :: nil) = 2.
Proof.
intros.
assert(HH : equivlist (P :: P :: R :: nil) (P :: R :: nil));[my_inO|];rewrite HH;apply rk_couple;intuition.
Qed.

Lemma triple_rk2_2 : forall P R, P <> R -> rk(P :: R :: P :: nil) = 2.
Proof.
intros.
assert(HH : equivlist (P :: R :: P :: nil) (P :: R :: nil));[my_inO|];rewrite HH;apply rk_couple;intuition.
Qed.

Lemma triple_rk2_3 : forall P R, P <> R -> rk(R :: P :: P :: nil) = 2.
Proof.
intros.
assert(HH : equivlist (R :: P :: P :: nil) (P :: R :: nil));[my_inO|];rewrite HH;apply rk_couple;intuition.
Qed.

Lemma col_degen_1 : forall P R, rk(P :: P :: R :: nil) = 3 -> False.
Proof.
intros.
assert(HH : equivlist (P :: R :: nil) (P :: P :: R :: nil));[my_inO|].
rewrite <-HH in H.
assert(HH0 := rk_couple_2 P R).
omega.
Qed.

Lemma col_degen_2 : forall P R, rk(P :: R :: P :: nil) = 3 -> False.
Proof.
intros.
assert(HH : equivlist (P :: R :: nil) (P :: R :: P :: nil));[my_inO|].
rewrite <-HH in H.
assert(HH0 := rk_couple_2 P R).
omega.
Qed.

Lemma col_degen_3 : forall P R, rk(R :: P :: P :: nil) = 3 -> False.
Proof.
intros.
assert(HH : equivlist (P :: R :: nil) (R :: P :: P :: nil));[my_inO|].
rewrite <-HH in H.
assert(HH0 := rk_couple_2 P R).
omega.
Qed.

Lemma quadruple_permut_1 : forall P A B C, rk(P :: A :: B :: C :: nil) = rk(P :: A :: C :: B ::nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_permut_2 : forall P A B C, rk(P :: A :: B :: C :: nil) = rk(P :: B :: A :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_permut_3 : forall P A B C, rk(P :: A :: B :: C :: nil) = rk(P :: B :: C :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_permut_4 : forall P A B C, rk(P :: A :: B :: C :: nil) = rk(P :: C :: A :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_permut_5 : forall P A B C, rk(P :: A :: B :: C :: nil) = rk(P :: C :: B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_1 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: A :: B :: D :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_2 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: A :: C :: B :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_3 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: A :: C :: D :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_4 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: A :: D :: B :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_5 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: A :: D :: C :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_6 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: B :: A :: C :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_7 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: B :: A :: D :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_8 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: B :: C :: A :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_9 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: B :: C :: D :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_10 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: B :: D :: A :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_11 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: B :: D :: C :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_12 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: C :: A :: B :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_13 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: C :: A :: D :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_14 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: C :: B :: A :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_15 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: C :: B :: D :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_16 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: C :: D :: A :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_17 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: C :: D :: B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_18 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: D :: A :: B :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_19 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: D :: A :: C :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_20 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: D :: B :: A :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_21 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: D :: B :: C :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_22 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: D :: C :: A :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quintuple_permut_23 : forall P A B C D, rk(P :: A :: B :: C :: D :: nil) = rk(P :: D :: C :: B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                            2004 -2005                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export Eqdep_dec.
Require Export apply_rule_props.
Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Lemma proof_irrelevanceA:forall(A:Set)(eqdecA:eqdec A)
                          (a :A)(p1:a=a), p1=refl_equal a.
 intros.
 apply eq_proofs_unicity.
 intros; case (eqdecA x y); tauto.
Qed.

Lemma eqdecX_rw:forall (X:Set)(decX:eqdec X)(i:X),
decX i i=left (i<>i) (refl_equal i).
 intros.
 case (decX i i).
 intros.
 rewrite (proof_irrelevanceA decX e).
 auto.
 intro n; case n.
 auto.
Qed.

Hint Rewrite eqdecX_rw:rw.

(* tactic for solving rewriting lemmas *)
Ltac solve_rw:=
let Ivar:=fresh "I" in
(let Jvar:=fresh "J" in
(let decIvar:=fresh "decI" in
(let decJvar:= fresh "decJ" in
(let rew1:=fresh "Ri" in
(let rew2:=fresh"Rj" in
(intros Ivar Jvar decIvar decJvar; intros;
 simpl; generalize (eqdecX_rw decIvar);
generalize (eqdecX_rw decJvar);intros rew2 rew1;
repeat rewrite rew1;repeat rewrite rew2;auto)))))).

Ltac inverse_same :=match goal with
| H:(same_shape (pcomma _ ?r1 ?r2) ?t)|-_ =>
  elim (sameShapeCom H); clear H; let Gamma:=fresh "Gamma" in (let
  Gamma':=fresh "Gamma" in (let x:=fresh "R" in (intros
  Gamma H;elim H; clear H; intros Gamma' H; elim H; clear H; intro; intro
  x; elim x; clear x; intros;subst;inverse_same)))
|H:(same_shape (pdiam _ ?r1) ?t) |- _ =>
 elim (sameShapeDiam H); clear H; let Gamma:=fresh "Gamma" in
(intros Gamma H; elim H; clear H; intros;subst);inverse_same
| _ => idtac
end.

Ltac solve_Inv:=match goal with |H: (apply_rule ?ru ?decI ?decJ ?t)=Some ?t' |-?any
=>
match eval compute in ru with
|(?r1, ?r2) =>cut (same_shape r1 t);
 [intro;inverse_same; repeat econstructor;eauto
 |apply apply_rule_same_shape with decI decJ r2 t'; auto]
end
end.

Ltac solve_inv:=intros; solve_Inv.

Ltac solve_Img:=match goal with
|H: (apply_rule ?ru ?decI ?decJ ?t)=Some ?t' |-?any
=>
match eval compute in ru with
|(?r1, ?r2) =>cut (same_shape r1 t);[intro;inverse_same;generalize
H;clear H;autorewrite
with ctl_db;injection 1;intros;subst;auto
 |apply apply_rule_same_shape with decI decJ r2 t'; auto]
end
end.

Ltac solve_img_inv:=intros;solve_Img.

(* tactic to solve goals of the form (weakSahlqvist ?rule) *)
Ltac solve_ws:=intros;simpl;auto with arith.

(*********************)
(* tests             *)
(*********************)

Ltac solve_aux I J decI decJ:=
match goal with
|i:I |- _=>case (decI i i);
[generalize i;clear i;solve_aux I J decI decJ |induction 1;auto]
|j:J |- _=>case (decJ j j);
[generalize j;clear j;solve_aux I J decI decJ |induction 1;auto]
| _=>auto
end.

Ltac solve_rw_bis:=
 let Ivar:=fresh "I" in
(let Jvar:=fresh "J" in
(let decIvar:=fresh "decI" in
(let decJvar:= fresh "decJ" in
(intros Ivar Jvar decIvar decJvar;intros; simpl;solve_aux Ivar Jvar decIvar decJvar)))).


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Basic definitions: float and rounding property *)
Require Import Fcore_Raux.

Section Def.

(** Definition of a floating-point number *)
Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }.

Arguments Fnum [beta].
Arguments Fexp [beta].

Variable beta : radix.

Definition F2R (f : float beta) :=
  (Z2R (Fnum f) * bpow beta (Fexp f))%R.

(** Requirements on a rounding mode *)
Definition round_pred_total (P : R -> R -> Prop) :=
  forall x, exists f, P x f.

Definition round_pred_monotone (P : R -> R -> Prop) :=
  forall x y f g, P x f -> P y g -> (x <= y)%R -> (f <= g)%R.

Definition round_pred (P : R -> R -> Prop) :=
  round_pred_total P /\
  round_pred_monotone P.

End Def.

Arguments Fnum [beta].
Arguments Fexp [beta].
Arguments F2R [beta].

Section RND.

(** property of being a round toward -inf *)
Definition Rnd_DN_pt (F : R -> Prop) (x f : R) :=
  F f /\ (f <= x)%R /\
  forall g : R, F g -> (g <= x)%R -> (g <= f)%R.

Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_DN_pt F x (rnd x).

(** property of being a round toward +inf *)
Definition Rnd_UP_pt (F : R -> Prop) (x f : R) :=
  F f /\ (x <= f)%R /\
  forall g : R, F g -> (x <= g)%R -> (f <= g)%R.

Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_UP_pt F x (rnd x).

(** property of being a round toward zero *)
Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) :=
  ( (0 <= x)%R -> Rnd_DN_pt F x f ) /\
  ( (x <= 0)%R -> Rnd_UP_pt F x f ).

Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_ZR_pt F x (rnd x).

(** property of being a round to nearest *)
Definition Rnd_N_pt (F : R -> Prop) (x f : R) :=
  F f /\
  forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R.

Definition Rnd_N (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_N_pt F x (rnd x).

Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  ( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ).

Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_NG_pt F P x (rnd x).

Definition Rnd_NA_pt (F : R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R.

Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_NA_pt F x (rnd x).

End RND.


Require Export parser.
Require Export refine.

Definition client: IA := parse
"IA [c1,c2,c3,c4,c5] (c1)
[ok,ack,error] [login,req,arg] []
[c1->(login)c2, c2->(error)c1, c2->(ok)c3,
c3->(req)c4, c4->(arg)c5, c5->(ack)c1]".

Definition adapter: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11] (s1)
[login,req,connected,arg,service]
[usr,pass,ok,ack,value,query] []
[s1->(login)s2, s2->(usr)s3, s3->(pass)s4,
s4->(connected)s5, s5->(ok)s6, s6->(req)s7,
s7->(arg)s8, s8->(value)s9, s9->(query)s10,
s10->(service)s11, s11->(ack)s1]".

Eval compute in IAutomaton.b_compatible client adapter. (*true*)

Definition client_adapter: IA := IAutomaton.composition client adapter.
(*Eval compute in IAutomaton.display client_adapter.
"IA [c5_s11, c5_s10, c5_s9, c5_s8, c4_s7, c3_s6, c2_s5, c2_s4, c2_s3, c1_s1, c2_s2]
 (c1_s1) [service, connected, error] [query, value, pass, usr]
[arg, req, login, ack, ok]
[c1_s1->(login)c2_s2, c2_s2->(usr)c2_s3, c2_s3->(pass)c2_s4,
c2_s4->(connected)c2_s5, c2_s5->(ok)c3_s6, c3_s6->(req)c4_s7,
c4_s7->(arg)c5_s8, c5_s8->(value)c5_s9, c5_s9->(query)c5_s10,
c5_s10->(service)c5_s11, c5_s11->(ack)c1_s1]"*)

Definition client_adapter_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement client_adapter (&"tau") (ASet.GenActs [&"service"]) )
 (ASet.GenActs [&"query",&"value"]).

Definition client_adapter_hid: IA :=
 IAutomaton.hiding client_adapter (ASet.GenActs [&"service",&"query",&"value"]).

Eval compute in SMENI_refinement client_adapter_rep client_adapter_hid. (*false*)


Require Import List.
Import ListNotations.

Require Import Nat.

Require Import Ascii.
Require Import String.
Open Scope string_scope.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlString.

From VLG Require Import lexer.
From VLG Require Import matcher.
From VLG Require Import sigma.
From VLG Require Import coredefs.

(*** Some ascii helpers ***)
Fixpoint toS (s : string) : String
  := match s with
     | EmptyString => nil
     | String.String ch s => cons ch (list_ascii_of_string s)
     end.

Fixpoint range' (n : nat) : (list nat) :=
  match n with
  | 0 => []
  | S n' => (range' n') ++ [n']
  end.

Fixpoint range (n1 n2 : nat) : (list nat) := map (plus n1) (range' (n2 - n1 + 1)).

(*** Some regex helpers ***)
Definition Plus (r : regex) : regex := App r (Star r).

Fixpoint IterUnion (rs : list regex) :=
match rs with
| [] => EmptySet
| h::t => Union h (IterUnion t)
end.

Fixpoint IterApp (rs : list regex) :=
match rs with
| [] => EmptyStr
| h::t => App h (IterApp t)
end.

(* r? *)
Definition Optional (r : regex) := Union EmptyStr r.

(**)

(*** White Space ***)
(* [ \t\n\r] *)
Definition chars_ws := map Char (map ascii_of_nat [9;10;13;32]).
Definition ru_ws : Rule := (toS "WS", Plus (IterUnion chars_ws)).
(**)

(*** Numbers ***)
(* [0-9] *)
Definition ascii_digit := range 48 57.
Definition chars_digit := map Char (map ascii_of_nat ascii_digit).
Definition regex_digit := IterUnion chars_digit.

(* [1-9], nz = non-zero *)
Definition ascii_nz_digit := range 49 57.
Definition chars_nz_digit := map Char (map ascii_of_nat ascii_nz_digit).
Definition regex_nz_digit := IterUnion chars_nz_digit.

(* "fragment INT" *)
Definition regex_zero := Char (ascii_of_nat 48).
Definition regex_nzero := App regex_nz_digit (Star regex_digit).
Definition regex_int := Union regex_zero regex_nzero.

(* '-'? *)
Definition regex_sign := Char (ascii_of_nat 45).
Definition regex_sign_option := Optional regex_sign.
(* ('.' [0-9] +)? *)
Definition regex_dec_point := Char (ascii_of_nat 46).
Definition regex_dec := App regex_dec_point (Plus regex_digit).
Definition regex_dec_option := Optional regex_dec.
(* fragment EXP : [Ee] [+\-]? INT *)
Definition regex_Ee := Union (Char (ascii_of_nat 69)) (Char (ascii_of_nat 101)).
Definition regex_pm := Union (Char (ascii_of_nat 43)) (Char (ascii_of_nat 45)).
Definition regex_pm_option := Optional regex_pm.
Definition regex_exp := IterApp [regex_Ee;regex_pm_option;regex_int].
Definition regex_exp_option := Optional regex_exp.

(* NUMBER : '-'? INT ('.' [0-9] +)? EXP? *)
Definition regex_number := IterApp [regex_sign_option;regex_int;regex_dec_option;regex_exp_option].
Definition ru_number := (toS "NUMBER", regex_number).
(**)

(*** STRING ***)
Definition ascii_lower := range 97 122.
Definition chars_lower := map Char (map ascii_of_nat ascii_lower).
Definition regex_lower := IterUnion chars_lower.
Definition ascii_upper := range 65 90.
Definition chars_upper := map Char (map ascii_of_nat ascii_upper).
Definition regex_upper := IterUnion chars_upper.
(* not sure what to include for punctuation, but here's almost all of it. *)
(* Maybe too much, and no consideration for escaping characters. *)
(* In theory this is meant to support unicode... *)
Definition ascii_punc : (list nat) := [32;33] ++ (range 35 47) ++ (range 58 64) ++ (range 91 96) ++ (range 123 126).
Definition chars_punc := map Char (map ascii_of_nat ascii_punc).
Definition regex_punc := IterUnion chars_punc.
Definition regex_char := IterUnion [regex_lower;regex_upper;regex_digit;regex_punc].
Definition regex_par := Char (ascii_of_nat 34).
(* ru_string *)
Definition regex_string := IterApp [regex_par;(Star regex_char);regex_par].
Definition ru_string := (toS "STRING", regex_string).
(**)

(*** keywords ***)
Definition regex_true := IterApp (map Char (toS "true")).
Definition ru_true := (toS "TRUE", regex_true).
Definition regex_false := IterApp (map Char (toS "false")).
Definition ru_false := (toS "FALSE", regex_false).
Definition regex_null := IterApp (map Char (toS "null")).
Definition ru_null := (toS "NULL", regex_null).

(*** brack, brace, colon, comma ***)
Definition regex_colon := IterApp (map Char (toS ":")).
Definition ru_colon := (toS "COLON", regex_colon).
Definition regex_comma := IterApp (map Char (toS ",")).
Definition ru_comma := (toS "COMMA", regex_comma).
Definition regex_lbrack := IterApp (map Char (toS "[")).
Definition ru_lbrack := (toS "LEFT_BRACKET", regex_lbrack).
Definition regex_rbrack := IterApp (map Char (toS "]")).
Definition ru_rbrack := (toS "RIGHT_BRACKET", regex_rbrack).
Definition regex_lbrace := IterApp (map Char (toS "{")).
Definition ru_lbrace := (toS "LEFT_BRACE", regex_lbrace).
Definition regex_rbrace := IterApp (map Char (toS "}")).
Definition ru_rbrace := (toS "RIGHT_BRACE", regex_rbrace).

(*** Compile rules and export ***)
Definition rus : list Rule := [ru_ws;ru_number;ru_string;ru_true;ru_false;ru_null;ru_colon;ru_comma;ru_lbrack;ru_rbrack;ru_lbrace;ru_rbrace].
Extraction "evaluation/instance.ml" lex rus.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                                                                                *)
(************************************************************************************)

Require Import Arith NArith ZArith String.
Require Import OrderedSet FiniteSet.

Require Import compcert.lib.Integers.

(** Types a.k.a domains in the database textbooks. *)
Inductive type :=
 | type_string
 | type_ptrofs.

Definition type_dec_eq : forall x y : type, {x = y} + {x <> y}. decide equality. Qed.

(** Embedding several coq datatypes (corresponding to domains) into a single uniform
    type for values.
*)
Inductive value : Set :=
  | Value_string : string -> value
  | Value_ptrofs : ptrofs -> value.

Definition type_of_value v :=
match v with
  | Value_string _  => type_string
  | Value_ptrofs _ => type_ptrofs
  end.

(** Default values for each type. *)
Definition default_value d :=
  match d with
    | type_string => Value_string EmptyString
    | type_ptrofs => Value_ptrofs Ptrofs.zero
  end.

(** injection of domain names into natural numbers in order to
    build an ordering on them.
*)

Open Scope N_scope.

Definition N_of_type :=
    fun d =>
    match d with
    | type_string => 0
    | type_ptrofs => 1
    end.

Definition OT : Oset.Rcd type.
apply Oemb with N_of_type.
intros d1 d2; case d1; case d2;
(exact (fun _ => refl_equal _) || (intro Abs; discriminate Abs)).
Defined.

(** Comparison over values, in order to build an ordered type over values, and then
    finite sets.
 *)

Definition value_compare x y :=
  match x, y with
    | Value_string s1, Value_string s2 => string_compare s1 s2
    | Value_string _, Value_ptrofs _ => Lt
    | Value_ptrofs n1, Value_ptrofs n2 => ptrofs_compare n1 n2
    | Value_ptrofs _, Value_string _ => Gt
  end.

Definition OVal : Oset.Rcd value.
split with value_compare.
(* 1/3 *)
intros [s1 | p1] [s2 | p2]; try discriminate.
generalize (Oset.eq_bool_ok Ostring s1 s2); simpl; case (string_compare s1 s2).
apply f_equal.
intros H1 H2; injection H2; apply H1.
intros H1 H2; injection H2; apply H1.
generalize (Oset.eq_bool_ok Optrofs p1 p2); simpl; case (ptrofs_compare p1 p2).
apply f_equal.
intros H1 H2; injection H2; apply H1.
intros H1 H2; injection H2; apply H1.
(* 1/2 *)
intros [s1 | p1 ] [s2 | p2 ] [s3 | p3 ]; trivial; try discriminate; simpl.
apply (Oset.compare_lt_trans Ostring).
apply (Oset.compare_lt_trans Optrofs).
(* 1/1 *)
intros [s1 | p1] [s2 | p2]; trivial; simpl.
apply (Oset.compare_lt_gt Ostring).
apply (Oset.compare_lt_gt Optrofs).
Defined.

Definition FVal := Fset.build OVal.


Require Import compcert.lib.Coqlib.
Require Import liblayers.lib.Decision.
Require Export liblayers.logic.Structures.
Require Export liblayers.logic.PseudoJoin.
Require Export liblayers.logic.OptionOrders.
Require Import liblayers.compcertx.ErrorMonad.
Require Import liblayers.logic.GlobalVars.

(** * Modules *)

(** Modules are essentially maps from identifiers to definitions of
  global variable and function definitions. The file [PTreeModules]
  provides an implementation with [positive] identifiers. *)

Class ModuleOps ident F V module
  `{gv_ops: GlobalVarsOps V} :=
  {
    module_le :> Le module;
    module_empty :> Emptyset module;
    module_oplus :> Oplus module;
    module_mapsto_fundef :> Mapsto ident F module;
    module_mapsto_vardef :> Mapsto ident V module;

    get_module_function (i: ident) (M: module): res (option F);
    get_module_variable (i: ident) (M: module): res (option V);

    module_decide_function (P: res (option F) -> Prop) :>
      (forall κ, Decision (P κ)) ->
      (forall L, Decision (forall i, P (get_module_function i L)));
    module_decide_function_name (P: ident -> Prop) :>
      (forall i, Decision (P i)) ->
      (forall M, Decision (forall i, get_module_function i M <> OK None -> P i));
    module_decide_variable (P: res (option V) -> Prop) :>
      (forall τ, Decision (P τ)) ->
      (forall L, Decision (forall i, P (get_module_variable i L)));
    module_decide_variable_name (P: ident -> Prop) :>
      (forall i, Decision (P i)) ->
      (forall M, Decision (forall i, get_module_variable i M <> OK None -> P i))
  }.

(** * Properties of modules *)

Class Modules ident F V module `{mops: ModuleOps ident F V module} :=
  {
    modules_pseudojoin :> PseudoJoin module ∅;

    get_module_function_empty i:
      get_module_function i ∅ = OK None;
    get_module_function_mapsto i (κ: F):
      get_module_function i (i ↦ κ) = OK (Some κ);
    get_module_function_mapsto_other_function i j (κ: F):
      i <> j -> get_module_function i (j ↦ κ) = OK None;
    get_module_function_mapsto_variable i j (τ: V):
      get_module_function i (j ↦ τ) = OK None;
    get_module_function_oplus i M1 M2:
      get_module_function i (M1 ⊕ M2) =
      get_module_function i M1 ⊕ get_module_function i M2;
    get_module_function_monotonic :>
      Monotonic get_module_function (- ==> (≤) ++> res_le (option_le eq));
    get_module_variable_empty i:
      get_module_variable i ∅ = OK None;
    get_module_variable_mapsto i (τ: V):
      get_module_variable i (i ↦ τ) = OK (Some τ);
    get_module_variable_mapsto_other_variable i j (τ: V):
      i <> j -> get_module_variable i (j ↦ τ) = OK None;
    get_module_variable_mapsto_function i j (κ: F):
      get_module_variable i (j ↦ κ) = OK None;
    get_module_variable_oplus i M1 M2:
      get_module_variable i (M1 ⊕ M2) =
      get_module_variable i M1 ⊕ get_module_variable i M2;
    get_module_variable_monotonic :>
      Monotonic get_module_variable (- ==> (≤) ++> res_le (option_le eq))
  }.

Global Instance get_module_function_monotonic_params:
  Params (@get_module_function) 2.

Global Instance get_module_variable_monotonic_params:
  Params (@get_module_variable) 2.

Ltac get_module_normalize :=
  repeat rewrite
    ?get_module_function_empty,
    ?get_module_function_mapsto,
    ?get_module_function_mapsto_other_function,
    ?get_module_function_mapsto_variable,
    ?get_module_function_oplus,
    ?get_module_variable_empty,
    ?get_module_variable_mapsto,
    ?get_module_variable_mapsto_other_variable,
    ?get_module_variable_mapsto_function,
    ?get_module_variable_oplus by congruence.

Ltac get_module_normalize_in H :=
  repeat rewrite
    ?get_module_function_empty,
    ?get_module_function_mapsto,
    ?get_module_function_mapsto_other_function,
    ?get_module_function_mapsto_variable,
    ?get_module_function_oplus,
    ?get_module_variable_empty,
    ?get_module_variable_mapsto,
    ?get_module_variable_mapsto_other_variable,
    ?get_module_variable_mapsto_function,
    ?get_module_variable_oplus in H by congruence.

(** * Well-formed modules *)

Section MODULE_OK.
  Context `{Hmod: Modules}.
  Context `{Hident_dec: EqDec ident}.

  (** [ModuleOK] denotes the property that at every identifier, at most
    one of the variable or function is defined, and that the module
    contains no errors. *)

  Record ModuleOK_at M i :=
    {
      module_ok_function:
        isOK (get_module_function i M);
      module_ok_variable:
        isOK (get_module_variable i M);
      module_ok_disjoint:
        isOKNone (get_module_function i M) \/
        isOKNone (get_module_variable i M)
    }.

  Class ModuleOK (M: module): Prop :=
    module_ok_at: forall i, ModuleOK_at M i.

  (** ** [ModuleOK] is decidable *)

  (** Alternative definition of [ModuleOK] that can be decided
    automatically. *)
  Definition ModuleOK_alt (M: module) :=
    (forall i, isOK (get_module_function i M)) /\
    (forall i, isOK (get_module_variable i M)) /\
    (forall i, get_module_function i M <> OK None ->
               isOKNone (get_module_variable i M)) /\
    (forall i, get_module_variable i M <> OK None ->
               isOKNone (get_module_function i M)).

  Lemma ModuleOK_alt_iff (M: module):
    ModuleOK_alt M <-> ModuleOK M.
  Proof.
    split.
    * intros (HMf & HMv & HMd & HMd') i.
      split; eauto.
      destruct (decide (isOKNone (get_module_function i M))) as [HMi|HMi]; eauto.
    * intros HM.
      split; [|split]; [| |split]; intros i; destruct (HM i); tauto.
  Qed.

  Global Instance module_ok_dec (M: module):
    Decision (ModuleOK M) := _.
  Proof.
    eapply decide_rewrite.
    * apply ModuleOK_alt_iff.
    * unfold ModuleOK_alt.
      typeclasses eauto.
  Defined.

  (** ** Monotonicity *)

  Global Instance module_ok_at_antitonic:
    Monotonic ModuleOK_at ((≤) --> - ==> impl).
  Proof.
    intros M1 M2 HM i [HMif HMiv HMifv].
    red in HM.
    split.
    - revert HMif; rauto.
    - revert HMiv; rauto.
    - revert HMifv; rauto.
  Qed.

  Global Instance module_ok_antitonic:
    Proper ((≤) --> impl) ModuleOK.
  Proof.
    intros M1 M2 HM HM1 i.
    rewrite <- HM.
    eauto.
  Qed.

  (** ** Basic instances *)

  Global Instance empty_ok:
    ModuleOK ∅.
  Proof.
    intros i.
    split; get_module_normalize; repeat econstructor.
  Qed.

  Global Instance mapsto_function_ok (i: ident) (κ: F):
    ModuleOK (i ↦ κ).
  Proof.
    intros j.
    destruct (decide (j = i)); subst;
    split; get_module_normalize; eauto.
  Qed.

  Global Instance mapsto_variable_ok (i: ident) (τ: V):
    ModuleOK (i ↦ τ).
  Proof.
    intros j.
    destruct (decide (j = i)); subst;
    split; get_module_normalize; eauto.
  Qed.

  (** These instances should not be added to the hint database
    directly because that would cause a loop, however we can use them
    in conjunction with [Hint Immediate]. *)

  Local Instance module_oplus_ok_left M1 M2:
    ModuleOK (M1 ⊕ M2) ->
    ModuleOK M1.
  Proof.
    intros H.
    rewrite (left_upper_bound M1 M2).
    assumption.
  Qed.

  Local Instance module_oplus_ok_right M1 M2:
    ModuleOK (M1 ⊕ M2) ->
    ModuleOK M2.
  Proof.
    intros H.
    rewrite (right_upper_bound M1 M2).
    assumption.
  Qed.

  (** ** Other lemmas *)

  Lemma get_module_function_variable_disjoint M `{ModuleOK M} i:
    isOKNone (get_module_function i M) \/ isOKNone (get_module_variable i M).
  Proof.
    destruct (H i) as [_ _ Hdisj].
    assumption.
  Qed.

  Lemma module_oplus_function_ok_elim (M: module) (i: ident) (f: F):
    ModuleOK (M ⊕ i ↦ f) ->
    isOKNone (get_module_function i M) /\
    isOKNone (get_module_variable i M).
  Proof.
    intros HMif.
    destruct (HMif i) as [Hf _ Hd].
    get_module_normalize_in Hf.
    get_module_normalize_in Hd.
    rewrite <- right_upper_bound in Hd.
    destruct Hd as [Hd|Hd]; try discriminate.
    rewrite <- left_upper_bound in Hd.
    split; try assumption; clear Hd.
    destruct (get_module_function i M) as [[|]|]; eauto;
    simpl in Hf; monad_norm; apply isOK_Error in Hf;
    elim Hf.
  Qed.

  Lemma module_oplus_function_same (M: module) (i: ident) (κ: F):
    ModuleOK (M ⊕ i ↦ κ) ->
    get_module_function i (M ⊕ i ↦ κ) = OK (Some κ).
  Proof.
    intros MOK.
    destruct (MOK i) as [Hf _ Hdisj]; clear MOK.
    get_module_normalize_in Hf.
    get_module_normalize_in Hdisj.
    rewrite <- right_upper_bound in Hdisj.
    destruct Hdisj; try discriminate.
    destruct Hf as [x Hx].
    get_module_normalize.
    destruct (get_module_function i M) as [[|]|]; try discriminate.
    reflexivity.
  Qed.

  Lemma module_oplus_function_other (M: module) (i j: ident) (κ: F):
    i <> j ->
    get_module_function i (M ⊕ j ↦ κ) = get_module_function i M.
  Proof.
    intros Hij.
    get_module_normalize.
    destruct (get_module_function i M) as [[|]|]; reflexivity.
  Qed.

  Lemma module_oplus_variable (M: module) (i j: ident) (κ: F):
    get_module_variable i (M ⊕ j ↦ κ) = get_module_variable i M.
  Proof.
    get_module_normalize.
    destruct (get_module_variable i M) as [[|]|]; reflexivity.
  Qed.
End MODULE_OK.

Hint Immediate module_oplus_ok_left : typeclass_instances.
Hint Immediate module_oplus_ok_right : typeclass_instances.

Section AuxLemma.

  Lemma get_module_variable_left `{mo_ops: Modules}:
    forall i a b v,
      get_module_variable i a = OK (Some v) ->
      isOK (get_module_variable i (a ⊕ b)) ->
      get_module_variable i (a ⊕ b) = OK (Some v).
  Proof.
    intros. destruct H0 as [? Hcom].
    specialize (get_module_variable_oplus i a b).
    rewrite Hcom. rewrite H.
    destruct (get_module_variable i b) as [ [ v' | ] | ].
    + destruct (globalvar_eq_dec v v').
      - subst. autorewrite with res_option_globalvar. auto.
      - rewrite res_option_globalvar_oplus_diff; congruence.
    + autorewrite with res_option_globalvar. auto.
    + autorewrite with res_option_globalvar. discriminate.
  Qed.

  Lemma get_module_variable_right `{mo_ops: Modules}:
    forall i a b v,
      get_module_variable i b = OK (Some v) ->
      isOK (get_module_variable i (a ⊕ b)) ->
      get_module_variable i (a ⊕ b) = OK (Some v).
  Proof.
    intros. destruct H0 as [? Hcom].
    specialize (get_module_variable_oplus i a b).
    rewrite Hcom. rewrite H.
    destruct (get_module_variable i a) as [ [ v' | ] | ].
    + destruct (globalvar_eq_dec v' v).
      - subst. autorewrite with res_option_globalvar. auto.
      - rewrite res_option_globalvar_oplus_diff; congruence.
    + autorewrite with res_option_globalvar. auto.
    + autorewrite with res_option_globalvar. discriminate.
  Qed.

  Lemma get_module_variable_none `{mo_ops: Modules}:
    forall i a b,
      get_module_variable i b = OK None ->
      get_module_variable i a = OK None ->
      isOK (get_module_variable i (a ⊕ b)) ->
      get_module_variable i (a ⊕ b) = OK None.
  Proof.
    intros. destruct H1 as [? Hcom].
    specialize (get_module_variable_oplus i a b).
    rewrite Hcom. rewrite H. rewrite H0.
    autorewrite with res_option_globalvar.
    auto.
  Qed.

  Lemma get_module_variable_isOK `{mo_ops: Modules}:
    forall i a b,
      isOK (get_module_variable i (a ⊕ b)) ->
      isOK (get_module_variable i a)
      /\ isOK (get_module_variable i b).
  Proof.
    intros. destruct H as [? Hcom].
    specialize (get_module_variable_oplus i a b).
    rewrite Hcom.
    destruct (get_module_variable i a);
      destruct (get_module_variable i b);
      res_option_globalvar_red; try congruence; eauto.
  Qed.

  Lemma get_module_varible_OK_Some_left `{mo_ops: Modules}:
    forall v i a b v',
      get_module_variable i a = OK (Some v) ->
      get_module_variable i (a ⊕ b) = OK (Some v') ->
      v' = v.
  Proof.
    intros.
    specialize (get_module_variable_oplus i a b).
    rewrite H. rewrite H0.
    destruct (get_module_variable i b) as [ [ v0 | ] | ] ;
      res_option_globalvar_red;
      try congruence.
    destruct (globalvar_eq_dec v v0).
    + subst. autorewrite with res_option_globalvar. congruence.
    + rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_module_varible_OK_Some_right `{mo_ops: Modules}:
    forall v i a b v',
      get_module_variable i b = OK (Some v) ->
      get_module_variable i (a ⊕ b) = OK (Some v') ->
      v' = v.
  Proof.
    intros.
    specialize (get_module_variable_oplus i a b).
    rewrite H. rewrite H0.
    destruct (get_module_variable i a) as [ [ v0 | ] | ] ;
      res_option_globalvar_red;
      try congruence.
    destruct (globalvar_eq_dec v v0).
    + subst. autorewrite with res_option_globalvar. congruence.
    + rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_module_function_cancel `{mo_ops: Modules}:
    forall i a b,
      get_module_function i (a ⊕ b) = OK None ->
      get_module_function i b = OK None /\
      get_module_function i a = OK None.
  Proof.
    intros.
    specialize (get_module_function_oplus i a b).
    rewrite H.
    intros.
    destruct (get_module_function i a); try destruct o;
    destruct (get_module_function i b); try destruct o;
    inv_monad H0.
    split; reflexivity.
  Qed.

  Lemma get_module_variable_cancel `{mo_ops: Modules}:
    forall i a b,
      get_module_variable i (a ⊕ b) = OK None ->
      get_module_variable i b = OK None /\
      get_module_variable i a = OK None.
  Proof.
    intros.
    specialize (get_module_variable_oplus i a b).
    rewrite H.
    destruct (get_module_variable i a) as [ [ va | ] | ] ;
    destruct (get_module_variable i b) as [ [ vb | ] | ] ;
    res_option_globalvar_red; try congruence; auto.
    destruct (globalvar_eq_dec va vb).
    + subst. autorewrite with res_option_globalvar. congruence.
    + rewrite res_option_globalvar_oplus_diff; congruence.
  Qed.

  Lemma get_module_function_none_oplus `{mo_ops: Modules}:
    forall i CTXT M,
      isOKNone (get_module_function i (CTXT ⊕ M)) <->
      isOKNone (get_module_function i CTXT)
      /\ isOKNone (get_module_function i M).
  Proof.
    intros.
    rewrite (get_module_function_oplus i CTXT M).
    destruct (get_module_function i CTXT) as [ [ | ] | ] ;
      destruct (get_module_function i M) as [ [ | ] | ] ;
      simpl;
      monad_norm;
    unfold isOKNone;
    clear;
    intuition congruence.
  Qed.

  Lemma get_module_variable_none_oplus `{mo_ops: Modules}:
    forall i CTXT M,
      isOKNone (get_module_variable i (CTXT ⊕ M)) <->
      isOKNone (get_module_variable i CTXT)
      /\ isOKNone (get_module_variable i M).
  Proof.
    intros.
    rewrite (get_module_variable_oplus i CTXT M).
    destruct (get_module_variable i CTXT) as [ [ gc | ] | ] ;
      destruct (get_module_variable i M) as [ [ gm | ] | ] ;
      simpl;
      res_option_globalvar_red;
      unfold isOKNone;
      clear;
      try intuition congruence.
    destruct (decide (gc = gm)).
    + subst.
      res_option_globalvar_red.
      intuition congruence.
    + rewrite res_option_globalvar_oplus_diff by assumption.
      intuition congruence.
  Qed.

  Lemma get_module_function_isOK `{mo_ops: Modules}:
    forall i a b,
      isOK (get_module_function i (a ⊕ b)) ->
      isOK (get_module_function i a)
      /\ isOK (get_module_function i b).
  Proof.
    intros. destruct H as [? Hcom].
    specialize (get_module_function_oplus i a b).
    rewrite Hcom.
    intros.
    destruct (get_module_function i a);
      destruct (get_module_function i b); inv_monad H.
    split; esplit; eauto.
  Qed.

End AuxLemma.


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 I H1 H2 : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (wd_ I A /\ (wd_ I C /\ (col_ B C H2 /\ (col_ B H1 H2 /\ col_ B H1 A)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.