(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Structural Rules (Focused System)
This files proves some permutation lemmas for the negative connectives.
*)

(* Add LoadPath "../../". *)
Require Import Arith.
Require Import Omega.
Require Import TriSystem.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

Ltac EquivPosCase H IH m L Hinv :=
  match goal with
    [_ : AsynchronousF _ = false |- _] =>
    inversion H; subst;
    apply IH  with(m:=L_weight L) in Hinv;auto  using le_plus_r;
    destruct Hinv;
    eexists;
    simpl; eapply tri_store;auto;
    eassumption
  end.

Theorem EquivAuxBot : forall B  L L' M  n,  n |-F- B ; M ; UP (L ++ L') -> exists m, m |-F- B ; M ;  UP (L ++ [Bot] ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent n .
  generalize dependent w .

  induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l].
  + simpl. simpl in H.
    eexists.
    eapply tri_bot;auto.
    apply H.
  + simpl in Hw. (* Heqw is inconsisten *)
    destruct l; simpl in Hw; inversion Hw.
  + simpl in Hw. inversion Hw.
  + destruct l;inversion Hw as [Hw'];inversion H; subst;auto;try (EquivPosCase H IH m L H6).
    ++ (* TOP *)
      simpl.
      eexists.
      eapply tri_top.
    ++ (* BOT *)
      apply IH  with(m:=L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_bot ;auto.
      eassumption.
    ++ (* PAR *)
      apply IH  with (L:= l1 :: l2 :: L) (m:= exp_weight l1 + exp_weight l2 + L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_par;auto.
      eassumption.
      simpl.
      apply plus_assoc_reverse.
    ++ (* WITH *)
      apply IH with (L:= l1 :: L) (m:= exp_weight l1 + L_weight L) in H5;auto.
      apply IH with (L:= l2 :: L) (m:= exp_weight l2 + L_weight L) in H7;auto.
      destruct H5. destruct H7.
      eexists.
      simpl.
      apply tri_with;eassumption.
      omega.
      omega.
    ++  (* QUEST *)
      apply IH  with(m:=L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_quest ;auto.
      eassumption.
      omega.
Qed.

Ltac EquivAuxWithPosCases IH H H' L n1 n0 H6 H13 :=
  inversion H;
  inversion H'; subst;
  generalize(IH (L_weight L) (le_n (L_weight L)) n1 n0 _ _ _ _ H6 H13 (eq_refl (L_weight L))) as Hp;intros;auto;
  destruct Hp;
  eexists;
  eapply tri_store;eauto.

Theorem EquivAuxWith : forall B  L L' M  n n' F G ,  n |-F- B ; M ; UP (L ++ [F] ++ L') ->
                                                                    n' |-F- B ; M ; UP (L ++ [G] ++ L') ->

                                                                                exists m, m |-F- B ; M ;  UP (L ++ [F & G] ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent n .
  generalize dependent n' .
  generalize dependent w .

  induction w as [| w' IH] using strongind  ; intros n' n M B L' L H H' Hw  ;  destruct L as [|l].
  + simpl. simpl in H.
    eexists.
    eapply tri_with;auto;eassumption.
  + simpl in Hw. (* Heqw is inconsisten *)
    destruct l; simpl in Hw; inversion Hw.
  + simpl in Hw. inversion Hw.
  + destruct l; inversion Hw as [Hw']; try(EquivAuxWithPosCases IH H H' L n1 n0 H6 H13).

    ++ (* TOP *)
      simpl.
      eexists.
      eapply tri_top.
    ++ (* BOT *)
      inversion H.
      inversion H'.
      subst.
      assert(exists m0 : nat, m0 |-F- B; M ; UP (L ++ [F & G] ++ L')) as Hp.
      eapply IH with (m:= L_weight L) ;eauto.
      destruct Hp.
      eexists.
      simpl.
      eapply tri_bot;auto; eassumption.
      subst.
      inversion H10.
      subst.
      inversion H5.
    ++  (* tensor *)
      inversion H; inversion H';subst.
      assert(exists m0 : nat, m0 |-F- B; M ++ [l1 ** l2]; UP (L ++ [F & G] ++ L')) as Hp.
      eapply IH with  (m:= L_weight L);eauto.
      omega.
      destruct Hp.
      eexists.
      simpl. eapply tri_store;auto; eassumption.
    ++ (* PAR *)
      inversion H.
      inversion H'.
      subst.
      assert(exists m0 : nat, m0 |-F- B; M ; UP ((l1 :: l2 :: L) ++ [F & G] ++ L')) as Hp.
      eapply IH with (m:= exp_weight l1 + exp_weight l2 + L_weight L ) ;eauto.
      simpl. omega.

      destruct Hp.
      eexists.
      simpl.
      eapply tri_par;auto; eassumption.

      subst.
      inversion H12.
      subst.
      inversion H5.

    ++ (* OPLUS  the same *)
      inversion H; inversion H';subst.
      assert(exists m0 : nat, m0 |-F- B; M ++ [l1 ⊕ l2]; UP (L ++ [F & G] ++ L')) as Hp.
      eapply IH with  (m:= L_weight L);eauto.
      omega.
      destruct Hp.
      eexists.
      simpl. eapply tri_store;auto; eassumption.
    ++  (* WITH *)
      inversion H.
      inversion H'.
      subst.

      assert(exists m0 : nat, m0 |-F- B; M ; UP ((l1 :: L) ++ [F & G] ++ L')) as Hp1.
      eapply IH with (m:= exp_weight l1 + L_weight L ) ;eauto.
      simpl. omega.
      assert(exists m0 : nat, m0 |-F- B; M ; UP ((l2 :: L) ++ [F & G] ++ L')) as Hp2.
      eapply IH with (m:= exp_weight l2 + L_weight L ) ;eauto.
      simpl. omega.

      destruct Hp1.
      destruct Hp2.

      eexists.
      simpl.
      eapply tri_with;auto; eassumption.

      subst.
      inversion H13.
      subst.
      inversion H5.
    ++ (* Bang the same *)
      inversion H; inversion H';subst.
      assert(exists m0 : nat, m0 |-F- B; M ++ [! l]; UP (L ++ [F & G] ++ L')) as Hp.
      eapply IH with  (m:= L_weight L);eauto.
      omega.
      destruct Hp.
      eexists.
      simpl. eapply tri_store;auto; eassumption.

    ++  (* quest *)
      inversion H.
      inversion H'.
      subst.
      assert(exists m0 : nat, m0 |-F- B ++ [l]; M ; UP (L ++ [F & G] ++ L')) as Hp.
      eapply IH with (m:= L_weight L) ;eauto.
      omega.

      destruct Hp.
      eexists.
      simpl.
      eapply tri_quest;auto; eassumption.
      subst.
      inversion H11.
      subst.
      inversion H5.
Qed.

(* This proof is exactly the same as the one of bottom *)
Theorem EquivAuxPar : forall B  L L' M F G  n,  n |-F- B ; M ; UP (L ++ [F ; G] ++ L') -> exists m, m |-F- B ; M ;  UP (L ++ [F $ G] ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent n .
  generalize dependent w .

  induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l].
  + simpl. simpl in H.
    eexists.
    eapply tri_par;auto.
    apply H.
  + simpl in Hw. (* Heqw is inconsisten *)
    destruct l; simpl in Hw; inversion Hw.
  + simpl in Hw. inversion Hw.
  + destruct l;inversion Hw as [Hw'];inversion H; subst;auto;try (EquivPosCase H IH m L H6).
    ++ (* TOP *)
      simpl.
      eexists.
      eapply tri_top.
    ++ (* BOT *)
      apply IH  with(m:=L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_bot ;auto.
      eassumption.
    ++ (* PAR *)
      apply IH  with (L:= l1 :: l2 :: L) (m:= exp_weight l1 + exp_weight l2 + L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_par;auto.
      eassumption.
      simpl.
      apply plus_assoc_reverse.
    ++ (* WITH *)
      apply IH with (L:= l1 :: L) (m:= exp_weight l1 + L_weight L) in H5;auto.
      apply IH with (L:= l2 :: L) (m:= exp_weight l2 + L_weight L) in H7;auto.
      destruct H5. destruct H7.
      eexists.
      simpl.
      apply tri_with;eassumption.
      omega.
      omega.
    ++  (* QUEST *)
      apply IH  with(m:=L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_quest ;auto.
      eassumption.
      omega.
Qed.

Ltac EquivAuxSyncPosCases IH F H8 :=
  match goal with
    [ H1 : _ |-F- _ ; ?M ++ [?F] ; UP ((?G :: ?L) ++ _) |- _ ] =>
    inversion H1;subst;
    assert ( (M ++ [F]) ++ [G] =mul=  (M ++ [G]) ++ [F]) by solve_permutation;
    eapply TriExchange with (M':= (M ++ [G]) ++ [F]) in H8; auto using le_plus_r, le_plus_l;
    apply IH  with  (m:=L_weight L) in H8 ;auto;
    destruct H8;
    eexists; simpl; eapply tri_store;auto; eassumption
  end.

Theorem EquivAuxSync : forall B  L L' M  n F ,  AsynchronousF F = false -> n |-F- B ; M ++ [F] ; UP (L ++ L') -> exists m, m |-F- B ; M ;  UP (L ++ [F] ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent n .
  generalize dependent w .

  induction w as [| w' IH] using strongind; intros n  M   B  L'  L  H1 Hw; destruct L as [|l].
  + simpl. simpl in H1.
    eexists.
    eapply tri_store;auto.
    apply H1.
  + simpl in Hw. (* Hw is inconsisten *)
    destruct l; simpl in Hw; inversion Hw.
  + simpl in Hw. inversion Hw.
  + destruct l;
      inversion Hw as [Hw'];
      inversion H; subst; auto; try (EquivAuxSyncPosCases IH F H8).
    ++ (* TOP *)
      simpl.
      eexists.
      eapply tri_top.
    ++ (* BOT *)
      inversion H1;subst.
      apply IH  with(m:=L_weight L) in H6;auto.
      destruct H6.
      eexists.
      simpl. eapply tri_bot ;auto;eassumption.
      inversion H7.
    ++ (* Tensor *)
      inversion H1;subst.
      assert ( (M ++ [F]) ++ [l1 ** l2] =mul=  (M ++ [l1 ** l2]) ++ [F]) by solve_permutation.
      eapply TriExchange with (M':= (M ++ [l1 ** l2]) ++ [F]) in H8; auto using le_plus_r.
      apply IH  with  (m:=L_weight L) in H8 ;auto using le_plus_r.
      destruct H8.
      eexists; simpl; eapply tri_store;auto; eassumption.

    ++ (* PAR *)
      inversion H1;subst.
      apply IH  with (L:= l1 :: l2 :: L) (m:= exp_weight l1 + exp_weight l2 + L_weight L) in H6;auto.
      destruct H6.
      eexists.
      simpl. eapply tri_par;auto;eassumption.
      simpl.
      apply plus_assoc_reverse.
      inversion H7.
    ++ (* OPLUS *) (* Tactic should solve this one *)
      inversion H1;subst.
      assert ( (M ++ [F]) ++ [l1 ⊕ l2] =mul=  (M ++[l1 ⊕ l2]) ++ [F]) by solve_permutation.
      eapply TriExchange with (M':= (M ++ [l1 ⊕ l2]) ++ [F]) in H8; auto using le_plus_r.
      apply IH  with  (m:=L_weight L) in H8 ;auto using le_plus_r.
      destruct H8.
      eexists; simpl; eapply tri_store;auto;eassumption.
    ++ (* WITH *)
      inversion H1;subst.
      apply IH with (L:= l1 :: L) (m:= exp_weight l1 + L_weight L) in H7;auto.
      apply IH with (L:= l2 :: L) (m:= exp_weight l2 + L_weight L) in H9;auto.
      destruct H7. destruct H9.
      eexists.
      simpl.
      apply tri_with;eassumption.
      omega.
      omega.
      inversion H7.
    ++ (* BANG *) (* Tactic should solve this one *)
      inversion H1;subst.
      assert ( (M ++ [F]) ++ [! l] =mul=  (M ++ [! l]) ++ [F]) by solve_permutation.
      eapply TriExchange with (M':= (M ++ [! l]) ++ [F]) in H8; auto using le_plus_r.
      apply IH  with  (m:=L_weight L) in H8 ;auto using le_plus_r.
      destruct H8.
      eexists; simpl; eapply tri_store;auto;eassumption.

    ++  (* QUEST *)
      inversion H1;subst.
      apply IH  with(m:=L_weight L) in H6;auto.
      destruct H6.
      eexists.
      simpl. eapply tri_quest ;auto;eassumption.
      omega.
      inversion H7.
Qed.

Theorem EquivAuxQuest : forall B  L L' M  n F,  n |-F- B ++ [F] ; M ; UP (L ++ L') -> exists m, m |-F- B ; M ;  UP (L ++ [? F] ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent n .
  generalize dependent w .

  induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l].
  + simpl. simpl in H.
    eexists.
    eapply tri_quest;auto.
    apply H.
  + simpl in Hw. (* Heqw is inconsisten *)
    destruct l; simpl in Hw; inversion Hw.
  + simpl in Hw. inversion Hw.
  + destruct l;inversion Hw as [Hw'];inversion H; subst;auto;try (EquivPosCase H IH m L H6).
    ++ (* TOP *)
      simpl.
      eexists.
      eapply tri_top.
    ++ (* BOT *)
      apply IH  with(m:=L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_bot ;auto.
      eassumption.
    ++ (* PAR *)
      apply IH  with (L:= l1 :: l2 :: L) (m:= exp_weight l1 + exp_weight l2 + L_weight L) in H4;auto.
      destruct H4.
      eexists.
      simpl. eapply tri_par;auto.
      eassumption.
      simpl.
      apply plus_assoc_reverse.
    ++ (* WITH *)
      apply IH with (L:= l1 :: L) (m:= exp_weight l1 + L_weight L) in H5;auto.
      apply IH with (L:= l2 :: L) (m:= exp_weight l2 + L_weight L) in H7;auto.
      destruct H5. destruct H7.
      eexists.
      simpl.
      apply tri_with;eassumption.
      omega.
      omega.
    ++  (* QUEST *)
      assert ((B ++ [F]) ++ [l] =mul= (B ++ [l]) ++ [F]) by solve_permutation.
      assert ( n0 |-F- (B ++ [l]) ++ [F] ; M ; UP (L ++ L')).
      eapply TriExchange.
      apply H4.
      auto.
      auto.
      apply IH with (m:= L_weight L) in H1 ;auto.
      destruct H1.
      eexists.
      simpl. eapply tri_quest ;auto.
      eassumption.
      apply le_plus_r.
Qed.

Theorem EquivAuxTop : forall B  L L' M ,   exists m, m |-F- B ; M ;  UP (L ++ [Top] ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent w .

  induction w as [| w' IH] using strongind;  intros M B L' L Hw ;  destruct L as [|l].
  + simpl.
    eexists.
    eapply tri_top;auto.
  + simpl in Hw. (* Heqw is inconsisten *)
    destruct l; simpl in Hw; inversion Hw.
  + simpl in Hw. inversion Hw.
  + destruct l;inversion Hw as [Hw'];auto.
    ++  (* ATOM *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [v ⁺] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* ATOM *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [v ⁻] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* TOP *)
      eexists. simpl. eapply tri_top.
    ++ (* bottom *)
      assert( exists m0 : nat, m0 |-F- B; M ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      destruct H.
      eexists. simpl. eapply tri_bot. eassumption.
    ++ (* Zero *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [0] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* One *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [1] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* tensor *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [l1 ** l2] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);auto.
      omega.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* Par *)
      assert( exists m0 : nat, m0 |-F- B; M ; UP ((l1 :: l2  :: L) ++ [⊤] ++ L')).
      apply IH with (m := exp_weight l1 + exp_weight l2 + L_weight L);subst;auto.
      simpl. omega.
      destruct H.
      eexists. simpl. eapply tri_par;auto. eassumption.
    ++ (* Oplus *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [l1 ⊕ l2] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      omega.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* with *)
      assert( exists m0 : nat, m0 |-F- B; M ; UP ((l1 ::L) ++ [⊤] ++ L')).
      apply IH with (m := exp_weight l1 + L_weight L);auto.
      omega.
      assert( exists m0 : nat, m0 |-F- B; M ; UP ((l2 ::L) ++ [⊤] ++ L')).
      apply IH with (m := exp_weight l2 + L_weight L);auto.
      omega.
      destruct H. destruct H0.
      eexists. simpl. eapply tri_with;auto;eassumption.
    ++ (* Bang *)
      assert( exists m0 : nat, m0 |-F- B; M ++ [! l] ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      omega.
      destruct H.
      eexists; simpl;eapply tri_store;auto;eassumption.
    ++ (* Quest *)
      assert( exists m0 : nat, m0 |-F- B ++ [l]; M ; UP (L ++ [⊤] ++ L')).
      apply IH with (m := L_weight L);subst;auto.
      omega.
      destruct H.
      eexists. simpl. eapply tri_quest;auto. eassumption.
Qed.

Ltac EquivAuxPosCases Heqw H IH H6 F L L' :=
  inversion Heqw; subst;
  simpl in H;
  inversion H;subst;
  apply IH with (m:= L_weight L)in H6 ;auto;
  destruct H6 as [m H6];
  assert( H1:  F::L ++ L' = [F] ++ (L ++ L'));auto;
  rewrite H1 in H6;
  eapply EquivAuxSync in H6;auto.

Theorem EquivAux : forall B L L' F M n, n |-F- B ; M ; UP (L ++ [F] ++ L')  -> exists m, m |-F- B ; M ;  UP(F :: L ++ L').
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent n .
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent w .

  induction w as [| w' IH] using strongind;  intros ;  destruct L as [|l].
  + simpl in H.
    simpl.
    eexists;eassumption.
  + inversion Heqw.
    generalize(exp_weight0 l);intros.
    omega.
  + simpl in H.
    simpl.
    eexists;eassumption.
  + destruct l; try(EquivAuxPosCases Heqw H IH H6 F L L').

    ++ (* Top *)
      assert (F :: (⊤ :: L) ++ L' = [F] ++ [⊤] ++ ( L ++ L')) by reflexivity.
      rewrite H0.
      apply EquivAuxTop.

    ++ (* bot *)

      inversion Heqw. subst.
      simpl in H.
      inversion H;firstorder; subst.
      apply IH with (m:= L_weight L)in H4 ;auto.
      destruct H4.

      assert( F::L ++ L' = [F] ++ (L ++ L'));auto.
      rewrite H1 in H0.
      eapply EquivAuxBot in H0;auto.

    ++ (* tensor *)
      inversion Heqw. subst.
      simpl in H.
      inversion H;subst.
      apply IH with (m:= L_weight L)in H6 ;auto.
      destruct H6.

      assert( F::L ++ L' = [F] ++ (L ++ L'));auto.
      rewrite H1 in H0.
      eapply EquivAuxSync in H0;auto.
      omega.
    ++ (* par *)
      inversion Heqw. subst.
      simpl in H.
      inversion H;firstorder; subst.
      apply IH with (L:= l1 :: l2 :: L) (m:= exp_weight l1 + exp_weight l2 + L_weight L)in H4 ; auto.
      destruct H4.

      assert( F :: (l1 :: l2 :: L) ++ L' = [F] ++ [l1 ; l2] ++ (L ++ L'));auto.
      rewrite H1 in H0.
      eapply EquivAuxPar in H0;auto.
      simpl.
      omega.
    ++ (* OPLUS *)
      inversion Heqw. subst.
      simpl in H.
      inversion H;subst.
      apply IH with (m:= L_weight L)in H6 ;auto.
      destruct H6.

      assert( F::L ++ L' = [F] ++ (L ++ L'));auto.
      rewrite H1 in H0.
      eapply EquivAuxSync in H0;auto.
      omega.
    ++ (* with *)
      inversion Heqw. subst.
      simpl in H.
      inversion H;firstorder; subst.
      apply IH with (L:= l1 :: L) (m:= exp_weight l1 + L_weight L)in H5 ;auto.
      apply IH with (L:= l2 :: L) (m:= exp_weight l2 + L_weight L)in H7 ;auto.

      destruct H5.
      destruct H7.
      assert( F :: (l1 :: L) ++ L' = [F] ++ [l1 ] ++ (L ++ L'));auto.
      assert( F :: (l2 :: L) ++ L' = [F] ++ [l2 ] ++ (L ++ L'));auto.
      rewrite H2 in H0.
      rewrite H3 in H1.

      eapply EquivAuxWith with (F:=l1) (G:=l2) in H0;eauto.
      omega.
      omega.
    ++ (* bang *)
      inversion Heqw. subst.
      simpl in H.
      inversion H;subst.
      apply IH with (m:= L_weight L)in H6 ;auto.
      destruct H6.

      assert( F::L ++ L' = [F] ++ (L ++ L'));auto.
      rewrite H1 in H0.
      eapply EquivAuxSync in H0;auto.
      omega.
    ++ (* quest *)
      inversion Heqw. subst.
      simpl in H.
      inversion H;firstorder; subst.
      apply IH with (m:= L_weight L)in H4 ;auto.
      destruct H4.

      assert( F::L ++ L' = [F] ++ (L ++ L'));auto.
      rewrite H1 in H0.
      eapply EquivAuxQuest in H0;auto.
      omega.
Qed.

Theorem EquivUpArrow : forall B L L' M n, n |-F- B ; M ; UP L -> L =mul= L' -> exists m, m |-F- B ; M ;  UP L'.
Proof.
  intros.
  remember (L_weight L) as w.
  generalize dependent n .
  generalize dependent L .
  generalize dependent L' .
  generalize dependent B .
  generalize dependent M .
  generalize dependent w .

  induction w as [| w' IH] using strongind;  intros ;  destruct L as [|l].
  +assert (L'= []) by( apply emp_mult;auto).
   subst.
   eexists.
   eassumption.
  + inversion Heqw.
    generalize(exp_weight0 l);intros.
    omega.
  + assert (L'= []) by( apply emp_mult;auto).
    subst.
    eexists.
    eassumption.
  + destruct L' as [_| l'].
    (* H0 is inconsisten *)
    apply DestructMulFalse in H0. contradiction.

    apply DestructMSet2 in H0 as Heq.

    destruct Heq as [Heq | Heq].
    ++ destruct Heq;subst.
       inversion H;subst.
       +++  (* top *)
         eexists. eapply tri_top.
       +++ (* bottom *)
         eapply IH with (L' :=L') in H6;auto.
         destruct H6.
         eexists. eapply tri_bot;eauto.
       +++ (* par *)
         eapply IH with (L' := F::G::L') in H6;auto.
         destruct H6.
         eexists. eapply tri_par;eauto.
         simpl in Heqw. inversion Heqw. simpl. omega.
       +++ (* with *)
         eapply IH with (m:= L_weight (F::L)) (L:= F ::L) (L' := F :: L') in H7;auto.
         eapply IH with (m:= L_weight (G::L)) (L := G :: L) (L' := G :: L') in H8;auto.
         destruct H7. destruct H8.
         eexists. eapply tri_with;eauto.

         simpl in Heqw. inversion Heqw. simpl. omega.
         simpl in Heqw. inversion Heqw. simpl. omega.
       +++  (* quest *)
         eapply IH with (m:= L_weight L) (L' :=L') in H6;auto.
         destruct H6.
         eexists. eapply tri_quest;eauto.
         simpl in Heqw. inversion Heqw. simpl. omega.
       +++  (* store *)
         eapply IH with (m:= L_weight L) (L' :=L') in H8;auto.
         destruct H8.
         eexists. eapply tri_store;eauto.
         simpl in Heqw. inversion Heqw.
         generalize(exp_weight0 l');intro.
         omega.
    ++
      destruct Heq as [L1 [L2 [L1' [L2' Heq]]]].

      destruct Heq as [Heq [Heq1 Heq2]];subst.

      inversion H;subst.
      +++ (* top *)

        eapply EquivAuxTop with (L:= l' :: L1').
      +++ (* bottom *)
        eapply IH with (m:= L_weight(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H5 .
        destruct H5.
        simpl in H1.
        eapply EquivAuxBot with (L:= l' :: L1');eauto.

        simpl in Heqw. inversion Heqw. auto.
        rewrite <-Heq2.
        perm_simplify.
        reflexivity.
      +++ (* par *)
        eapply IH with (m:= L_weight(F :: G :: L1 ++ l' :: L2))
                         (L:=F :: G :: L1 ++ l' :: L2)
                         (L' := [l'] ++ L1' ++ [F ; G] ++ L2') in H5 .
        destruct H5.

        eapply EquivAuxPar with (L:= l' :: L1');eauto.
        simpl in Heqw. inversion Heqw. auto.
        simpl. omega.
        assert( L1' ++ [F; G] ++ L2' =mul= [F; G] ++ L1' ++ L2') by auto.
        rewrite H1. rewrite <- Heq2.
        solv_P.
        apply union_right.
        change ([F; G]) with ([F] ++ [G]).
        solve_permutation.
        reflexivity.

      +++ (* with *)
        eapply IH with (m:= L_weight(F :: L1 ++ l' :: L2))
                         (L:=F :: L1 ++ l' :: L2)
                         (L' := [l'] ++ L1' ++ [F ] ++ L2') in H6 .
        eapply IH with (m:= L_weight(G :: L1 ++ l' :: L2))
                         (L:=G :: L1 ++ l' :: L2)
                         (L' := [l'] ++ L1' ++ [G ] ++ L2') in H7 .

        destruct H6. destruct H7.
        eapply EquivAuxWith with (L := l' :: L1'); eauto.
        simpl in Heqw. inversion Heqw. auto.
        simpl. omega.
        assert(HC : [l'] ++ L1' ++ [G] ++ L2' =mul= [l'] ++ [G] ++ L1' ++ L2') by solve_permutation.
        rewrite HC. clear HC.
        solv_P.
        solve_permutation.
        reflexivity.
        simpl in Heqw. inversion Heqw. simpl. omega.
        assert(HC : L1' ++ [F] ++ L2' =mul=  [F] ++ L1' ++ L2') by solve_permutation.
        rewrite HC. clear HC.
        solv_P.
        solve_permutation.
        reflexivity.

      +++ (* quest *)
        eapply IH with (m:= L_weight(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H5 .
        destruct H5.
        eapply EquivAuxQuest with (L := l' :: L1');eauto.

        simpl in Heqw. inversion Heqw. auto.
        simpl. omega.
        rewrite <- Heq2. solve_permutation.
        reflexivity.

      +++ (* copy *)
        eapply IH with (m:= L_weight(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H7 .
        destruct H7.
        eapply EquivAuxSync with (L:=l' :: L1');eauto.

        simpl in Heqw. rewrite L_weightApp in Heqw. simpl in Heqw.
        rewrite L_weightApp.

        generalize(exp_weight0 l);intro.
        apply GtZero in H1.
        destruct H1.
        rewrite H1 in Heqw. simpl in Heqw.

        inversion Heqw.
        simpl. omega.
        rewrite <- Heq2.
        solve_permutation.

        reflexivity.
Qed.

(* Weakening *)
Theorem TriWeakening : forall B L F X n, n |-F- B ; L ; X -> n |-F- B ++ [F] ; L ; X.
  intros.
  generalize dependent L .
  generalize dependent B .
  generalize dependent F .
  generalize dependent X .
  generalize dependent n .
  induction n using strongind;intros.
  + (* Base *)
    inversion H;subst.
    ++ eapply tri_init1.
    ++ apply tri_init2 with (B' := B' ++ [F]);auto.
       rewrite H0.  solve_permutation.
    ++ eapply tri_one.
    ++ eapply tri_top.
  + (* Inductive *)
    inversion H0;subst.
    ++ eapply H in H3;auto.
       eapply H in H4;auto.
       eapply tri_tensor;eauto.
    ++ eapply H in H2;auto.
       eapply tri_plus1;eauto.
    ++ eapply H in H2;auto.
       eapply tri_plus2;eauto.
    ++ eapply H in H2;auto.
       eapply tri_bang;eauto.
    ++ eapply H in H3;auto.
       eapply tri_rel;eauto.
    ++ eapply H in H2;auto.
       eapply tri_bot;eauto.
    ++ eapply H in H2;auto.
       eapply tri_par;eauto.
    ++ eapply H in H2;auto.
       eapply H in H3;auto.
       eapply tri_with;eauto.
    ++  eapply H with (B := B ++ [F0]) (F:=F) in H2;auto.
        eapply tri_quest;auto.
        assert((B ++ [F]) ++ [F0] =mul= (B ++ [F0]) ++ [F]) by solve_permutation.
        rewrite H1. auto.
    ++  eapply H  with (L:= L ++ [F0]) (F:=F) in H3;auto.
        eapply tri_store;auto.
    ++ eapply H in H4;auto.
       eapply tri_dec1 with (F:=F0);eauto.
    ++ eapply H with (F:=F) in H4;auto.
       eapply TriExchange with (B := [F0] ++ B' ++ [F]);eauto.
       eapply tri_dec2 with (F:=F0);eauto.
       eapply TriExchange with (B' := [F0] ++ B' ++ [F]);eauto.
Qed.

(* Up and Down relation *)
Lemma UpExtension: forall B M L F n, lexpPos (M ++ [F]) -> n |-F- B; M ++ [F] ; UP L ->
                                                                                exists m, m<= S n /\ m |-F- B; M ; UP (L ++ [F]).
  intros.
  remember (L_weight L) as w.
  generalize dependent L .
  generalize dependent B .
  generalize dependent M .
  generalize dependent n .
  generalize dependent w .

  induction w as [| w' IH] using strongind .  intros n  M HPos  B L HD Hw.
  + (* w = 0 *)
    destruct L. (* L must be empty. The second case is trivial *)
    exists ((S n)).
    split;auto.
    simpl.
    eapply tri_store;auto.

    generalize(LPos3 M [F] (meq_refl (M ++ [F])) HPos);intro.
    inversion H;auto.

    simpl in Hw.
    apply exp_weight0LF in Hw;contradiction.

  + intros.
    destruct L. (* L cannot be empty *)
    inversion Heqw.
    inversion H0;auto;subst;inversion Heqw;subst.
    ++ (* top *)
      exists 0%nat;split;auto.
      eapply tri_top.
    ++ (* bot *)
      apply IH with (m:= L_weight L) in H5;auto.
      destruct H5 as [n'  [IHn IHd]].
      exists (S n');split;auto. omega. simpl. eapply tri_bot;auto.
    ++  (* PAR *)
      apply IH with (m:= exp_weight F0 + exp_weight G + L_weight L) in H5;auto.
      destruct H5 as [n'  [IHn IHd]].
      exists (S n');split;auto. omega. simpl. eapply tri_par;auto.
      simpl. omega.
    ++ (* with *)
      apply IH with (m:= exp_weight F0 + L_weight L) in H6;auto.
      apply IH with (m:= exp_weight G + L_weight L) in H7;auto.
      destruct H6 as [n'  [IHn IHd]].
      destruct H7 as [m'  [IHn' IHd']].
      simpl.

      exists (S (Init.Nat.max n' m'));split;auto. simpl.
      apply le_n_S.
      rewrite Max.succ_max_distr.
      apply Nat.max_le_compat;auto.

      eapply tri_with;auto.
      omega.
      omega.
    ++  (* quest *)
      apply IH with (m:= L_weight L) in H5;auto.
      destruct H5 as [n'  [IHn IHd]].
      exists (S n');split;auto. omega. simpl. eapply tri_quest;auto.
      omega.
    ++ (* Store *)
      assert(exists m0 : nat, m0 <= S n0 /\ m0 |-F- B; M ++ [l]; UP (L ++ [F])).
      apply IH with (m:= L_weight L);eauto using WeightLeq.
      apply LPos1 with (L:= [l] ++ (M ++ [F]));auto.
      rewrite app_assoc_reverse.
      solve_permutation.

      apply lexpPosUnion;auto.
      apply AsynchronousFlexpPos;auto.
      assert((M ++ [l]) ++ [F] =mul= (M ++ [F]) ++ [l]) by solve_permutation.
      rewrite H1;auto.

      destruct H1 as [n'  [IHn IHd]].
      exists (S n');split;auto. omega. simpl. eapply tri_store;auto.
Qed.

Lemma StoreInversion : forall n B M F,  n |-F- B; M; UP [F] -> PosOrPosAtom F -> n -1 |-F- B ; M ++ [F] ; UP [].
  intros.
  inversion H;subst;try(inversion H0);subst;simpl;try(rewrite Nat.sub_0_r);auto.
Qed.
Lemma StoreInversionL : forall n B M N L,  n |-F- B; M; UP (N ++ L) -> lexpPos N -> exists m, m |-F- B ; M ++ N ; UP L.
  intros.
  generalize dependent M.
  generalize dependent n.
  induction N;intros.
  + simpl in *.
    eexists.
    rewrite app_nil_r.
    eauto.
  + inversion H;subst; try(
                           inversion H0;
                           simpl in H1;
                           intuition).
    apply H3 in H7.
    destruct H7.
    eexists.
    assert( M ++ a :: N =mul=  (M ++ [a]) ++ N) by solve_permutation.
    rewrite H5.
    eassumption.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                              Arith_Compl.v                               *)
(****************************************************************************)

Require Import Arith.
Require Import Lib_Minus.

Set Implicit Arguments.
Unset Strict Implicit.

Lemma Ex_n_lt_gen : forall n m : nat, S m = n -> 0 < n.
intros n m H; elim H; auto with arith.
Qed.

Lemma lt_S_le : forall n m : nat, S n <= m -> n < m.
auto with arith.
Qed.

Lemma lt_eq_lt : forall p q n : nat, p < n -> q = n -> p < q.
intros p q n H1 H2.
rewrite H2; try trivial.
Qed.

Lemma le_minusS : forall n m : nat, 0 < n -> n <= m -> S (m - n) <= m.
intros n m H1 H2.
apply lt_n_Sm_le.
auto with arith.
Qed.

Lemma le_le_Sminus : forall n m k : nat, m <= k -> S (m - n) <= S (k - n).
auto with arith.
Qed.

Lemma le_leS : forall n m : nat, n <= m -> n <= S m.
auto with arith.
Qed.

Lemma le_S_lt_O : forall n m : nat, S m <= n -> 0 < n.
intros n m H.
apply lt_le_trans with (S m); auto with arith.
Qed.

Lemma lt_le_pred : forall n m : nat, n < m -> n <= pred m.
simple induction n; simple induction m; auto with arith.
Qed.
Hint Immediate lt_le_pred.

Lemma le_Sn_le_n_pred : forall n m : nat, S n <= m -> n <= pred m.
auto with arith.
Qed.

Lemma le_mult_l : forall n m : nat, 0 < m -> n <= m * n.
intros.
rewrite (S_pred m 0); trivial.
simpl in |- *; auto with arith.
Qed.
Hint Immediate le_mult_l.

Lemma le_n_mult_S_n : forall n m : nat, n <= S m * n.
auto with arith.
Qed.

Lemma S_pred : forall n : nat, n <> 0 -> S (pred n) = n.
simple destruct n; simpl in |- *; trivial.
intro H; absurd (0 = 0); trivial.
Qed.

Lemma le_minusSS :
 forall n m k : nat, 0 < n -> m <= k -> n <= m -> S (k - n) <= k.
intros n m k H1 H2 H3.
apply lt_n_Sm_le.
apply lt_n_S.
apply lt_minus.
apply le_trans with m; auto with arith.
try trivial.
Qed.


Require Import ZProperty Confluence LambdaES lx CompositionProblemLemmas OpenPoints Lia.

Require Import Arith MSetList Setoid Lia.

Fixpoint llc_at (k:nat) (t:pterm) : Prop :=
  match t with
  | pterm_bvar i    => i < k
  | pterm_fvar x    => True
  | pterm_app t1 t2 => llc_at k t1 /\ llc_at k t2
  | pterm_abs t1    => llc_at (S k) t1
  | pterm_sub t1 t2 => False
  end.

Lemma llc_at_open_var_rec : forall t x k,
  llc_at k (open_rec k x t) -> llc_at (S k) t.
Proof.
  intro t; induction t.
  - intros x k.
    simpl.
    bdall.
  - intros x k H.
    auto.
  - intros x k H.
    simpl in *.
    destruct H as [H1 H2].
    split.
    + apply IHt1 with x; assumption.
    + apply IHt2 with x; assumption.
  - intros x k H.
    simpl in *.
    apply IHt with x; assumption.
  - intros x k H.
    simpl in *.
    auto.
Qed.

Lemma llc_at_weaken_ind : forall k1 k2 t,
  llc_at k1 t -> k1 <= k2 -> llc_at k2 t.
Proof.
  intros k1 k2 t.
  generalize dependent k2.
  generalize dependent k1.
  induction t.
  - intros k1 k2 Hllc_at Hle.
    simpl in *.
    apply Nat.lt_le_trans with k1; assumption.
  - intros k1 k2 Hllc_at Hle.
    simpl; auto.
  - intros k1 k2 Hllc_at Hle.
    simpl in *.
    destruct Hllc_at as [H1 H2].
    split.
    + apply IHt1 with k1; assumption.
    + apply IHt2 with k1; assumption.
  - intros k1 k2 Hllc_at Hle.
    simpl.
    simpl in Hllc_at.
    apply IHt with (S k1).
    + assumption.
    + apply Peano.le_n_S; assumption.
  - intros k1 k2 Hllc_at Hle.
    inversion Hllc_at.
Qed.


(** * Varieties. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)
(**
This file contains a formalization of equational algebras, i.e., algebra which are
models of an equation system.
*)

Require Import UniMath.MoreFoundations.Notations.

Require Export UniMath.Algebra.Universal.Algebras.
Require Export UniMath.Algebra.Universal.Equations.

Section Varieties.

  Definition holds {σ: signature} {V: varspec σ} (a: algebra σ) (e: equation σ V) : UU
    := ∏ α, fromterm (ops a) α (eqsort e) (lhs e) =
            fromterm (ops a) α (eqsort e) (rhs e).

  Definition is_eqalgebra {σ : eqspec} (a : algebra σ) : UU
    := ∏ e: equations σ, holds a (geteq e).

  Definition eqalgebra (σ : eqspec) : UU
    := ∑ a : algebra σ, is_eqalgebra a.

  Definition algebra_of_eqalgebra {σ : eqspec}
    : eqalgebra σ -> algebra σ
    := pr1.
  Coercion algebra_of_eqalgebra : eqalgebra >-> algebra.

  Definition eqalgebra_proof {σ : eqspec} (a : eqalgebra σ)
    : is_eqalgebra a := pr2 a.

  Definition make_eqalgebra {σ : eqspec} (a : algebra σ) (H : is_eqalgebra a)
    : eqalgebra σ
    := tpair is_eqalgebra a H.

End Varieties.


From mathcomp Require Import all_ssreflect all_algebra complex.
Require Import lens tpower.

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

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

Section unitary.
Variable R : rcfType.
Let C := [comRingType of R[i]].
Let Co := [lmodType C of C^o].
Variable I : finType.
Variable dI : I.

Notation tsquare n := (tmatrix I C n n).
Notation idts := (idts I C).
Notation tmatrixmx := (tmatrixmx dI).
Notation mor := (mor I C).
Notation endo n := (mor n n).
Notation focus := (focus dI).

Definition hadjmx n m (M : 'M[C]_(n,m)) := \matrix_(i,j) (M j i)^*.

Definition unitarymx n M := @hadjmx n n M *m M == 1%:M.

Lemma hadjmx_mul n m p (M : 'M[C]_(n,m)) (N : 'M[C]_(m,p)) :
  hadjmx (M *m N) = hadjmx N *m hadjmx M.
Proof.
apply/matrixP => i j; rewrite !mxE.
rewrite rmorph_sum; apply eq_bigr => /= k _.
by rewrite !mxE -rmorphM /= mulrC.
Qed.

Lemma unitarymx_mul n (M N : 'M[C]_n) :
  unitarymx M -> unitarymx N -> unitarymx (M *m N).
Proof.
move => /eqP UM /eqP UN; apply/eqP.
by rewrite hadjmx_mul mulmxA -(mulmxA (hadjmx N)) UM mulmx1.
Qed.

Section unitary_tmatrix.
Variable n : nat.
Variable M : tsquare n.

Definition hadjts m (N : tmatrix I C m n) : tmatrix I C n m :=
  [ffun vi => [ffun vj => (N vj vi)^*]].

Definition unitaryts := mults (hadjts M) M == idts n.

Lemma hadjtsE m (N : tmatrix I C m n) :
  tmatrixmx (hadjts N) = hadjmx (tmatrixmx N).
Proof. apply/matrixP => i j; by rewrite !mxE !ffunE. Qed.

Lemma unitarytsE : unitaryts = unitarymx (tmatrixmx M).
Proof.
case/boolP: unitaryts => /eqP Hts; apply/esym/eqP.
- by rewrite -hadjtsE -tmatrixmx_mul Hts tmatrixmx_id.
- move=> Hmx; elim Hts.
  by rewrite -mxtmatrix_id // -Hmx mxtmatrix_mul // -hadjtsE !tmatrixmxK.
Qed.

Lemma unitary_invP : hadjts M = M ->
  reflect (forall T, involutive (tsmor M T)) unitaryts.
Proof.
rewrite /unitaryts => ->.
apply: (iffP idP) => [/eqP|] Hinv.
- move=> T v.
  move: (f_equal (fun M => tsmor M T v) Hinv).
  by rewrite tsmor_comp -idmorE.
- apply/eqP.
  rewrite -[LHS]tsmorK -[RHS]tsmorK.
  apply morts_eq => T v.
  rewrite tsmor_comp -idmorE /=.
  by have /= -> := Hinv T.
Qed.
End unitary_tmatrix.

Lemma hadjts_mul n m p M N : hadjts (M *t N) = @hadjts p m N *t @hadjts m n M.
Proof.
rewrite -[LHS](tmatrixmxK dI) hadjtsE tmatrixmx_mul.
by rewrite hadjmx_mul -!hadjtsE -tmatrixmx_mul tmatrixmxK.
Qed.

Lemma unitaryts_mul n (M N : tsquare n) :
  unitaryts M -> unitaryts N -> unitaryts (mults M N).
Proof. rewrite !unitarytsE tmatrixmx_mul; exact/unitarymx_mul. Qed.

Lemma unitarymxE n (M : 'M[C]_(#|I|^n)) : unitarymx M = unitaryts (mxtmatrix M).
Proof. by rewrite unitarytsE mxtmatrixK. Qed.

Section unitary_endo.
Definition tinner n (s t : tpower I n Co) := \sum_i (s i)^* * (t i).
Definition unitary_endo m n (f : mor m n) :=
  forall s t, tinner (f Co s) (f Co t) = tinner s t.

Lemma idmorU n : unitary_endo (idmor I n).
Proof. done. Qed.

Lemma unitary_endoP n M : reflect (@unitary_endo n n (tsmor M)) (unitaryts M).
Proof.
rewrite /unitaryts /unitary_endo.
apply/(iffP idP).
- move=> Uf s t; move/eqP: Uf.
  move/(f_equal (fun ts => mults (hadjts (curryn0 s)) (mults ts (curryn0 t)))).
  rewrite !multsA -multsA -hadjts_mul mul1ts //.
  move/(f_equal (fun M : tsquare 0 => M [tuple] [tuple])).
  rewrite !ffunE. under [RHS]eq_bigr do rewrite !ffunE.
  move=> Uf; rewrite -{}[RHS]Uf.
  apply eq_bigr => vi _; rewrite !ffunE !tsmorE.
  by congr (_^* * _); apply eq_bigr => vj _; rewrite !ffunE.
- move=> Uf; apply/eqP/ffunP => vi; apply/ffunP => vj.
  rewrite !ffunE; under eq_bigr do rewrite !ffunE.
  have := Uf (tpbasis C vi) (tpbasis C vj).
  rewrite /tinner.
  under eq_bigr do rewrite !tsmorE !sum_tpbasisKo.
  move ->.
  under eq_bigr do rewrite !ffunE.
  by rewrite sum_muleqr [LHS]conjc_nat.
Qed.

Lemma unitary_comp m n p (f : mor n p) (g : mor m n) :
  unitary_endo f -> unitary_endo g -> unitary_endo (f \v g).
Proof. move=> Hf Hg s t /=; by rewrite Hf. Qed.

Lemma unitary_focus n m (l : lens n m) (f : endo m) :
  naturality f -> unitary_endo f -> unitary_endo (focus l f).
Proof.
rewrite /unitary_endo /tinner => /= Nf Uf s t.
rewrite 2!(reindex_merge_indices _ dI l) /=.
rewrite [LHS]exchange_big [RHS]exchange_big /=.
apply eq_bigr => vj _.
pose sel s : tpower I m Co := map_tpower (tpsel vj) (curry dI l s).
transitivity (\sum_i (sel s i)^* * sel t i); last first.
  apply eq_bigr => vi _; by rewrite !ffunE /tpsel !ffunE.
rewrite -Uf; apply eq_bigr => vi _.
rewrite focusE /= /focus_fun.
rewrite /uncurry !ffunE !extract_merge !extract_lothers_merge.
by rewrite -!Nf !ffunE.
Qed.
End unitary_endo.

Section projection.
Variables (n m : nat) (l : lens n m).

Let norm p := fun s : tpower I p Co => (sqrtc (tinner s s) : Co).

Definition proj (t : tpower I n Co) : tpower I m Co :=
  map_tpower (@norm _) (curry dI l t).

Lemma proj_focusE p (l' : lens n p) (f : endo p) (t : tpower I n Co) :
  [disjoint l & l'] -> naturality f -> unitary_endo f ->
  proj (focus l' f Co t) = proj t.
Proof.
move=> Hdisj Nf Uf.
rewrite /proj -(lmake_compE Hdisj) focus_others // uncurryK /=.
apply/ffunP => vi.
by rewrite !ffunE /norm unitary_focus.
Qed.
End projection.
End unitary.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory
     bicategory.examples.full_sub
     lax_functor.examples.factor_full_sub
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     general_category.

Section Factor.
  Context {C D : BiCategory}
          {F G : LaxFunctor C D}.
  Variable (P : D -> hProp)
           (η : LaxTransformation F G)
           (FH : forall (X : C), P (F X))
           (GH : forall (X : C), P (G X)).

  Definition lax_factor_transformation_d
    : LaxTransformation_d (lax_factor F P FH) (lax_factor G P GH).
  Proof.
    simple refine (Build_LaxTransformation_d _ _).
    - exact (fun X => η X).
    - exact (fun X Y => laxnaturality_of η).
  Defined.

  Definition lax_factor_transformation_is_lax
    : is_lax_transformation lax_factor_transformation_d.
  Proof.
    split ; intros ; apply η.
  Qed.

  Definition lax_factor_transformation
    : LaxTransformation (lax_factor F P FH) (lax_factor G P GH)
    := Build_LaxTransformation
         lax_factor_transformation_d
         lax_factor_transformation_is_lax.
End Factor.

Global Instance factor_transformation_is_pseudo
           `{Univalence}
           {C D : BiCategory}
           {F G : LaxFunctor C D}
           (P : D -> hProp)
           (η : LaxTransformation F G)
           `{is_pseudo_transformation _ _ _ _ η}
           (FH : forall (X : C), P (F X))
           (GH : forall (X : C), P (G X))
  : is_pseudo_transformation (lax_factor_transformation P η FH GH).
Proof.
  intros X Y f ; cbn ; apply _.
Defined.

Definition pseudo_factor_transformation
           `{Univalence}
           {C D : BiCategory}
           {F G : LaxFunctor C D}
           (P : D -> hProp)
           (η : PseudoTransformation F G)
           (FH : forall (X : C), P (F X))
           (GH : forall (X : C), P (G X))
  : PseudoTransformation (lax_factor F P FH) (lax_factor G P GH).
Proof.
  make_pseudo_transformation_lax.
  - exact (lax_factor_transformation P η FH GH).
  - exact (factor_transformation_is_pseudo P η FH GH).
Defined.


(* then/else switched *)
Definition update_map(M1 M2: map K V): map K V :=
  (filter (fun '(k1, v1) =>
             if (find (fun '(k2, v2) => if keq k1 k2 then false else true) M2)
             then false else true) M1) ++ M2.


Require Import List.
Import ListNotations.

Require Import Undecidability.CFG.CFP.
Require Import Undecidability.CFG.CFG.
Require Undecidability.CFG.Reductions.CFPP_to_CFP.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction :
  CFPI ⪯ CFI.
Proof.
  exists (fun '(R1, R2, a) => (CFPP_to_CFP.G R1 a, CFPP_to_CFP.G R2 a)). intros [[R1 R2] a].
  intuition; cbn in *.
  - destruct H as (A1 & A2 & HR1 & HR2 & HA1 & HA2 & H).
    exists (sigma a A1). split; eapply CFPP_to_CFP.reduction_full; eauto.
  - destruct H as (x & HR1 & HR2).
    eapply CFPP_to_CFP.reduction_full in HR1 as (A1 & HR1 & HA1 & H1).
    eapply CFPP_to_CFP.reduction_full in HR2 as (A2 & HR2 & HA2 & H2).
    exists A1, A2. subst; eauto.
Qed.


Require Import Util Computable Containers.OrderedTypeEx.

Instance equiv_computable X `{OrderedType X} (x y: X) : Computable (_eq x y).
hnf.
pose proof (_compare_spec x y).
destruct (_cmp x y); intros.
- left. inversion H0; eauto.
- right. inversion H0. intro. rewrite H2 in H1.
  eapply (StrictOrder_Irreflexive _ _ H1). reflexivity.
- right. inversion H0. intro. rewrite H2 in H1.
  eapply (StrictOrder_Irreflexive _ _ H1). reflexivity.
Defined.

Instance ordered_type_lt_dec A `{OrderedType A} (a b: A)
  : Computable (_lt a b).
Proof.
pose proof (_compare_spec a b).
destruct (_cmp a b).
right; inv H0. hnf; intros. eapply (lt_not_eq H2 H1).
left. inv H0; eauto.
right; inv H0. intro. eapply (lt_not_gt H1 H2).
Defined.

Hint Extern 0 =>
match goal with
  [ H : _lt ?x ?x |- _ ] =>
  exfalso; eapply OrderedType.StrictOrder_Irreflexive in H; eauto
end.


Require Import
  Algebra.FrameC
  FormTopC.Product
  FormTopC.Discrete
  FormTopC.Bundled.

Module Scott.

Section Scott.

Variable A B : IGT.

Definition le_Open (U V : Subset (S B)) :=
  V ⊆ FormTop.Sat (Cov B) U.

Lemma Sat_Cov : forall U V,
  U ⊆ FormTop.Sat (Cov B) V
  -> FormTop.Sat (Cov B) U ⊆ FormTop.Sat (Cov B) V.
Proof.
intros. unfold FormTop.Sat, Included, pointwise_rel, arrow in *.
intros. FormTop.trans X0. apply X; assumption.
Qed.

Local Instance PreOrder_le_Open : PreO.t le_Open.
Proof.
unfold le_Open; constructor;
  unfold Reflexive, Transitive; intros.
- apply (FormTop.Sat_mono _ _ _).
- rewrite X0. apply Sat_Cov; assumption.
Qed.

Definition eq_Open := PO.eq_PreO le_Open.

(** Define abstraction to Sierpinski space
    S * T ~~> Σ   -->    S ~~> Open T
*)

Existing Instances Sierpinski.ops Sierpinski.SML.

Let prod_le := prod_op leS leT.
Let prodC := Product.C _ _ IxS IxT CS CT.
Let prodCov := FormTop.GCov prod_le prodC.
Let sierpCov := FormTop.GCov MeetLat.le Sierpinski.C.

Variable F : Contmap (S * T) (discrete bool).
Hypothesis contF : Cont.t
   prod_le MeetLat.le prodCov sierpCov F.

(** "false" is the smallest open set in the Sierpinski space,
    which confusingly is the open set surrounding the
    "top" or "true" point. *)

Definition absF (subset : Subset T) (s : S) : Type :=
  le_Open (fun t => F false (s, t)) subset.

Let OpenCov := FormTop.GCov le_Open (InfoBase.C
  (leS := le_Open)
  (eqS := eq_Open)).

Local Instance FTS : FormTop.t leS CovS.
Proof.
apply FormTop.GCov_formtop.
Qed.

Lemma le_Open_mono U V :
  V ⊆ U -> le_Open U V.
Proof.
intros H. unfold le_Open.
rewrite H. apply (FormTop.Sat_mono leT CovT).
Qed.

Local Instance PO_le_eq : PO.t le_Open eq_Open
  := PO.fromPreO _.
Existing Instance PO.fromPreO.

(** This seems really suspicious. It's probably wrong. *)
Theorem absF_cont : Cont.t leS le_Open CovS OpenCov absF.
Proof.
constructor; intros.
- apply FormTop.grefl. constructor 1 with (fun _ => False).
  constructor. unfold absF. unfold le_Open.
  unfold Included, pointwise_rel, arrow; intros.
  contradiction.
- unfold absF in *. rewrite <- X0.
  apply le_Open_mono.
  unfold Included, pointwise_rel, arrow; intros.
  eapply (Cont.le_left contF (a, a0) false (c, a0)).
  unfold prod_le, prod_op. simpl. split. eassumption.
  reflexivity. assumption.
- unfold absF in *.
  apply FormTop.grefl.
  exists (b ∪ c). split; apply le_Open_mono.
  apply Union_Included_l.
  apply Union_Included_r.
  unfold Included, In in *.
  unfold le_Open in *.
  unfold Included, pointwise_rel, arrow; intros.
  destruct X1. apply X. assumption. apply X0. assumption.
- induction X0; simpl in *.
  + apply FormTop.grefl. constructor 1 with a0; assumption.
  + apply IHX0. unfold absF.
    unfold absF in X.
    unfold le_Open in *.
    rewrite l. apply Sat_Cov. assumption.
  + destruct i; simpl in *.
    apply (X0 t). reflexivity.
    unfold absF, le_Open in *.
    rewrite l. apply Sat_Cov. assumption.
Qed.

End Scott.

End Scott.

(** Spaces of open sets (using Scott topology *)
Definition Open (A : IGT) : IGT :=
  let LE := @Scott.le_Open (S A) (le A) (Ix A) (C A) in
  let PreO : PreO.t (le A) := IGT_PreO A in
  let PO :=
   @PO.PreO (Subset (S A)) LE _ (Scott.PO_le_eq (POT := PreO)
  (locT := localized A)) in
  {| S := Subset (S A)
   ; le := LE
   ; PO := PO
   ; Ix := InfoBase.Ix
   ; C := InfoBase.C (leS := LE) (eqS := PO.eq_PreO LE)
   ; localized := InfoBase.loc (PO := PO.fromPreO LE)
   ; pos := InfoBase.Pos (PO := PO.fromPreO LE)
  |}.

Definition open_abstract_mp {Γ A : IGT}
  (f : Cont.map (S (Γ * A)) (S Σ))
     : Cont.map (S Γ) (S (Open A))
  := Scott.absF (leT := le A) (IxT := Ix A) (CT := C A) f.

Existing Instances Bundled.PO Bundled.local.

Definition open_abstract_mp_ok {Γ A : IGT}
  (f : Cont.map (S (Γ * A)) (S Σ))
  : Cont.t (le (Γ * A)) (le Σ) (Cov (Γ * A)) (Cov Σ) f
  -> Cont.t (le Γ) (le (Open A)) (Cov Γ) (Cov (Open A))
    (open_abstract_mp f).
Proof.
intros H.
apply Scott.absF_cont. apply H.
Qed.

Definition open_abstract {Γ A : IGT} (f : Γ * A ~~> Σ) : Γ ~~> Open A
  :=
  {| mp := open_abstract_mp (mp f)
   ; mp_ok := open_abstract_mp_ok (mp f) (mp_ok f)
  |}.


Require Import List.
Import ListNotations.
Require Import String.
Require Import Flocq.Appli.Fappli_IEEE_bits.
Require Import Flocq.Appli.Fappli_IEEE.
Require Import ZArith.

Require Import v1.Multi.
Require Import v1.NeutronTactics.
Require Import v1.FloatAux.
Require Import v1.Util.

Require Import epics.SpecTypes.
Require Import expr.Expr.
Require Import floatabs.Records.
Require Import floatabs.RecordData.

Local Open Scope Z_scope.

Definition check_overflow x0 x1 : abs_value :=
    if Z_le_gt_dec x0 (-2 ^ 52) then None
    else if Z_ge_lt_dec x1 (2 ^ 52) then None
    else Some (x0, x1).

Definition abs_opp (x : abs_value) : abs_value :=
    match x with
    | Some (x0, x1) => check_overflow (Z.opp x1) (Z.opp x0)
    | _ => None
    end.

Definition abs_plus (x y : abs_value) : abs_value :=
    match x, y with
    | Some (x0, x1), Some (y0, y1) => check_overflow (x0 + y0) (x1 + y1)
    | _, _ => None
    end.

Definition abs_minus (x y : abs_value) : abs_value :=
    match x, y with
    | Some (x0, x1), Some (y0, y1) => check_overflow (x0 - y1) (x1 - y0)
    | _, _ => None
    end.

Definition abs_mult (x y : abs_value) : abs_value :=
    match x, y with
    | Some (x0, x1), Some (y0, y1) =>
            let z0 := Z.min (Z.min (x0 * y0) (x0 * y1)) (Z.min (x1 * y0) (x1 * y1)) in
            let z1 := Z.max (Z.max (x0 * y0) (x0 * y1)) (Z.max (x1 * y0) (x1 * y1)) in
            check_overflow z0 z1
    | _, _ => None
    end.

Definition abs_join (x y : abs_value) : abs_value :=
    match x, y with
    | Some (x0, x1), Some (y0, y1) => check_overflow (Z.min x0 y0) (Z.max x1 y1)
    | _, _ => None
    end.

Definition abs_min (x y : abs_value) : abs_value :=
    match x, y with
    | Some (x0, x1), Some (y0, y1) => check_overflow (Z.min x0 y0) (Z.min x1 y1)
    | _, _ => None
    end.

Definition abs_max (x y : abs_value) : abs_value :=
    match x, y with
    | Some (x0, x1), Some (y0, y1) => check_overflow (Z.max x0 y0) (Z.max x1 y1)
    | _, _ => None
    end.

Fixpoint abs_minimum (xs : list abs_value) :=
    match xs with
    | [] => Some (0, 0)
    | x :: xs => abs_min x (abs_minimum xs)
    end.

Fixpoint abs_maximum (xs : list abs_value) :=
    match xs with
    | [] => Some (0, 0)
    | [x] => x
    | x :: xs => abs_max x (abs_maximum xs)
    end.

(*
Definition abs_eq (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Eq => one
    | _ => zero
    end.

Definition b64_ne (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt | Some Datatypes.Gt => one
    | _ => zero
    end.

Definition b64_lt (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt => one
    | _ => zero
    end.

Definition b64_le (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Lt | Some Datatypes.Eq => one
    | _ => zero
    end.

Definition b64_gt (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Gt => one
    | _ => zero
    end.

Definition b64_ge (x y : e_double) :=
    match Bcompare _ _ x y with
    | Some Datatypes.Gt | Some Datatypes.Eq => one
    | _ => zero
    end.

Definition b64_and (x y : e_double) :=
    if is_zero x then zero else (if is_zero y then zero else one).

Definition b64_or (x y : e_double) :=
    if is_zero x then (if is_zero y then zero else one) else one.
*)

Inductive abs_tydesc := Nil | Abs.
Scheme Equality for abs_tydesc.

Definition abs_ty_denote ty :=
    match ty with
    | Nil => unit
    | Abs => abs_value
    end.

Definition abs_bool : abs_value := Some (0, 1).

Definition double_abs (d : e_double) : abs_value :=
    match B2Z_safe d with
    | Some z => Some (z, z)
    | None => None
    end.

Definition abs_eval_bits : eval_bits e_double :=
    {| tydesc := abs_tydesc
    ; tydesc_eq_dec := abs_tydesc_eq_dec
    ; ty_denote := abs_ty_denote

    ; var_ty := Abs
    ; xvar_ty := Nil
    ; convert_lit := fun d => existT abs_ty_denote Abs (double_abs d)

    ; nil_ty := Nil
    ; nil_value := tt

    ; unop_denote := fun op ty1 =>
        match ty1 with
        | Abs =>
                let mk f := Some (existT (unop_impl _ Abs) Abs f) in
                match op with
                | NotAlg => mk abs_opp
                | NotLog => mk (fun _ => abs_bool)
                end
        | Nil => None
        end

    ; binop_denote := fun op ty1 ty2 =>
        match ty1, ty2 with
        | Abs, Abs =>
                let mk f := Some (existT (binop_impl _ Abs Abs) Abs f) in
                match op with
                | Add => mk abs_plus
                | Sub => mk abs_minus
                | Mul => mk abs_mult
                | Div => mk (fun _ _ => None)
                | Ge => mk (fun _ _ => abs_bool)
                | Gt => mk (fun _ _ => abs_bool)
                | Le => mk (fun _ _ => abs_bool)
                | Lt => mk (fun _ _ => abs_bool)
                | Ne => mk (fun _ _ => abs_bool)
                | Eq => mk (fun _ _ => abs_bool)
                | AndLog => mk (fun _ _ => abs_bool)
                | OrLog => mk (fun _ _ => abs_bool)
                end
        | _, _ => None
        end

    ; ternop_denote := fun op ty1 ty2 ty3 =>
        match ty1, ty2, ty3 with
        | Abs, Abs, Abs =>
                let mk f := Some (existT (ternop_impl _ Abs Abs Abs) Abs f) in
                match op with
                | Cond => mk (fun _ x y => abs_join x y)
                end
        | _, _, _ => None
        end

    ; varop_denote := fun op ty1 =>
        match ty1 with
        | Abs =>
                let mk f := Some (existT (varop_impl _ Abs) Abs f) in
                match op with
                | Min => mk (fun xs => abs_minimum xs)
                | Max => mk (fun xs => abs_maximum xs)
                end
        | _ => None
        end
    |}.

Definition denote {n} (e : expr e_double n) :
        option (multi n abs_value -> multi n abs_value * abs_value) :=
    unpack_ty abs_eval_bits Abs (denote' abs_eval_bits e)
        (fun f =>
            let f' sv :=
                let '(sv, sx, r) := f sv (multi_rep n tt) in
                (sv, r) in
            Some f').


Require Export projective_plane_inst.
Require Export FSets.

Module Export uniq := (uniqueness_axioms AbstractProjectivePlane).
Module uniqdec := (decidability AbstractProjectivePlane).

Definition line A B := (proj1_sig (a1_exist A B)).
Definition inter l m := (proj1_sig (a2_exist l m)).

Definition on_inter A P Q R S := Incid A (line P Q) /\ Incid A (line R S).
Definition on_inter' A P Q R S := A = inter (line P Q) (line R S).

Definition Col A B C :=
 exists l : Line,
 Incid A l /\ Incid B l /\ Incid C l.

Definition Meet l1 l2 l3 :=
 exists P : Point, Incid P l1 /\ Incid P l2 /\ Incid P l3.

Definition is_transverse A' B' C' A B C :=
Col A' B' C' /\ Col A B' C /\ Col A C' B /\ Col B A' C.

Definition is_on_inter P A B C D :=
Col P A B /\ Col P C D.

Definition is_on_proper_inter P A B C D :=
Col P A B /\ Col P C D /\ A<>B /\ C<>D /\ line A B <> line C D.

Definition is_hexamy A B C D E F :=
  (A<>B /\ A<>C /\ A<>D /\ A<>E /\ A<>F /\
  B<>C /\ B<>D /\ B<>E /\ B<>F /\
  C<>D /\ C<>E /\ C<>F /\
  D<>E /\ D<>F /\
  E<>F) /\
  let a:= inter (line B C) (line E F) in
  let b:= inter (line C D) (line F A) in
  let c:= inter (line A B) (line D E) in
Col a b c.

Definition hexamy := forall A B C D E F,
is_hexamy A B C D E F ->
is_hexamy B A C D E F.

Ltac apply_unicity_hyps := match goal with
H1: ?A <> ?B,
H2: ?Incid ?A ?l,
H3: ?Incid ?B ?l,
H4 : ?Incid ?A ?m,
H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: l=m); try apply (uniq.a1_unique A B l m H1 H2 H3 H4 H5);idtac "we have " l " = " m;subst l
| H1: ?l <> ?m,
  H2: ?Incid ?A ?l,
  H3: ?Incid ?A ?m,
  H4 : ?Incid ?B ?l,
  H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: A=B); try apply (uniq.a2_unique l m A B H1 H2 H3 H4 H5);idtac "we have : " A " = " B;subst A
end.

Ltac collapse_hyps :=  progress (repeat (apply_unicity_hyps; CleanDuplicatedHyps)).

Ltac solve_eq := solve [intro; repeat subst; try collapse_hyps;intuition].

Ltac apply_unicity_no_hyps := match goal with
HAl: ?Incid ?A ?l,
HBl: ?Incid ?B ?l,
HAm: ?Incid ?A ?m,
HBm: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: l=m)
by ( apply (uniq.a1_unique A B l m);
[solve_eq| apply HAl | apply HBl| apply HAm| apply HBm]);
idtac "we have " l " = " m;subst l
|
HAl: ?Incid ?A ?l,
HBl: ?Incid ?B ?l,
HAm: ?Incid ?A ?m,
HBm: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: A=B)
by ( apply (uniq.a2_unique l m A B);
[solve_eq| apply HAl | apply HAm| apply HBl| apply HBm]);
idtac "we have " A " = " B;subst A
end.

Ltac aide :=
 match goal with
H2: ?Incid ?A ?l,
H3: ?Incid ?B ?l,
H4: ?Incid ?A ?m,
H5: ?Incid ?B ?m |- _ => idtac A " = " B " ou " l "=" m
end.

Ltac collapse_no_hyps := progress (repeat (apply_unicity_no_hyps; CleanDuplicatedHyps)).

Ltac collapse := progress ( try collapse_hyps; try collapse_no_hyps).

Ltac not_eq A B:= assert (A<>B) by solve_eq.

Definition Col_on A B C l := Incid A l /\ Incid B l /\ Incid C l.

Ltac geo_norm :=
 unfold Col_on,
            is_on_inter, is_on_proper_inter,
            dist3, dist4, dist6,
            Col in * |-; use_all.

Ltac cases_line l m :=
   elim (uniqdec.eq_line_dec l m); intro;
   [subst;try collapse|idtac].

Ltac cases_point A B :=
   elim (uniqdec.eq_point_dec A B); intro;
   [subst;try collapse|idtac].

Lemma line_wd : forall A B l,
 Incid A l ->
 Incid B l ->
 A<>B ->
 line A B = l.
Proof.
intros.
unfold line.
elim a1_exist;simpl.
intros.
use_all.
collapse.
trivial.
Qed.

Lemma line_wd_sym : forall A B l,
 Incid A l ->
 Incid B l ->
 B<>A ->
 line A B = l.
Proof.
intros.
unfold line.
elim a1_exist;simpl.
intros.
use_all.
collapse.
trivial.
Qed.

Ltac create_line A B l := elim (a1_exist A B);intros l Hl;decompose[and] Hl;clear Hl.

Ltac create_point l m P := elim (a2_exist l m);intros P HP;decompose[and] HP;clear HP.

Ltac create_inter A B C D P :=
  let AB:=fresh "l" in
  let CD:= fresh "l" in
  create_line A B AB; create_line C D CD; create_point AB CD P.

Ltac create_non_existing_line A B := progress first [ (match goal with
 HA : Incid A ?l , HB : Incid B ?l |- _ => idtac
end) | (let id:= fresh "l" in create_line A B id) ].

Ltac add_non_existing_lines := repeat (match goal with
_: context[line ?A ?B] |- _ => create_non_existing_line A B
| _: _ |- context[line ?A ?B] => create_non_existing_line A B
end).

Ltac remove_line_occ := repeat ( match goal with
 HAB: ?A<>?B, HA: Incid ?A ?l, HB: Incid ?B ?l,
 H: context[line ?A ?B] |- _ => rewrite (line_wd A B l) in * by assumption
| HAB: ?B<>?A, HA: Incid ?A ?l, HB: Incid ?B ?l,
 H: context[line ?A ?B] |- _ => rewrite (line_wd_sym A B l) in * by assumption
| HAB: ?A<>?B, HA: Incid ?A ?l, HB: Incid ?B ?l
 |- context[line ?A ?B] => rewrite (line_wd A B l) in * by assumption
| HAB: ?B<>?A, HA: Incid ?A ?l, HB: Incid ?B ?l
 |- context[line ?A ?B] => rewrite (line_wd_sym A B l) in * by assumption
end).

Lemma test2 : forall A B  C D l , line A B = l -> line C D = l -> True.
Proof.
intros.
add_non_existing_lines.
auto.
Qed.

Lemma on_inter_points_wd : forall A B C D P l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid P l ->
 Incid P m ->
 l <> m ->
 A <> B ->
 C <> D ->
 P = inter (line A B) (line C D).
Proof.
intros.
remove_line_occ.
unfold inter.
elim a2_exist.
intros.
simpl in *.
use_all.
collapse.
Qed.

Lemma on_inter_points_wd_spec_1 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid A m ->
 l <> m ->
 A <> B ->
 C <> D ->
 A = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma on_inter_points_wd_spec_2 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid B m ->
 l <> m ->
 A <> B ->
 C <> D ->
 B = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma on_inter_points_wd_spec_3 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid C l ->
 l <> m ->
 A <> B ->
 C <> D ->
 C = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma on_inter_points_wd_spec_4 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid D l ->
 l <> m ->
 A <> B ->
 C <> D ->
 D = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma not_eq_sym_point : forall A B : Point, A<>B -> B<>A.
Proof.
 auto.
Qed.

Lemma not_eq_sym_line : forall A B : Line, A<>B -> B<>A.
Proof.
 auto.
Qed.

Ltac assumption_or_sym :=
  assumption ||
  (apply not_eq_sym_point;assumption) ||
  (apply not_eq_sym_line;assumption).

Ltac assumptions_or_sym := repeat split;try assumption_or_sym.

Ltac remove_inter_points_occ := repeat (match goal with

HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP1 : Incid ?P ?l,
HP2 : Incid ?P ?m |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd A B C D P l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?A ?m |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_1 A B C D l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?B ?m |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_2 A B C D l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?C ?l |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_3 A B C D l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?D ?l |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_4 A B C D l m) in *; try assumption_or_sym

|

HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP1 : Incid ?P ?l,
HP2 : Incid ?P ?m ,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd A B C D P l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?A ?m,
H: context[inter (line ?A ?B) (line ?C ?D)]|- _ =>
rewrite <- (on_inter_points_wd_spec_1 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?B ?m,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_2 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?C ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_3 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?D ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_4 A B C D l m) in H; try assumption_or_sym

end).

Lemma on_inter_wd : forall P l m,
 Incid P l ->
 Incid P m ->
 l <> m ->
 inter l m = P.
Proof.
intros.
unfold inter.
elim a2_exist.
simpl.
intros.
use_all.
collapse.
trivial.
Qed.

Lemma on_inter_wd_sym : forall P l m,
 Incid P l ->
 Incid P m ->
 l <> m ->
 inter m l = P.
Proof.
intros.
unfold inter.
elim a2_exist.
simpl.
intros.
use_all.
collapse.
trivial.
Qed.

Ltac remove_inter_occ :=
first [erewrite on_inter_wd_sym in * by eassumption |
       erewrite on_inter_wd     in * by eassumption].

Lemma col_col_on_inter : forall A B C D I,
 Col A B I -> Col C D I ->
 A<>B -> C<>D -> (line A B) <> (line C D) ->
 I = inter (line A B) (line C D).
Proof.
intros.
geo_norm.
remove_line_occ.
remove_inter_occ.
trivial.
Qed.

Lemma incid_line_left : forall A B, Incid A (line A B).
Proof.
intros.
intros; unfold line.
repeat (elim a1_exist); simpl; intuition.
Qed.

Lemma incid_line_right : forall A B, Incid B (line A B).
intros; unfold line.
repeat (elim a1_exist); simpl; intuition.
Qed.

Hint Resolve incid_line_left incid_line_right.

Lemma col_incid : forall A B C, B<>C -> Col A B C -> Incid A (line B C).
intros.
geo_norm.
remove_line_occ.
auto.
Qed.

Lemma col_comm : forall A B C, Col A B C -> Col B A C.
Proof.
intros; firstorder.
Qed.

Lemma col_comm2 : forall A B C, Col A B C -> Col A C B.
Proof with (intros; firstorder).
intros...
Qed.

Lemma col_comm3 : forall A B C, Col A B C -> Col B C A.
Proof.
intros; firstorder.
Qed.

Lemma col_comm4 : forall A B C, Col A B C -> Col C A B.
Proof.
intros; firstorder.
Qed.

Lemma col_comm5 : forall A B C, Col A B C -> Col C B A.
Proof.
intros; firstorder.
Qed.

Lemma inter_comm : forall l m, inter l m = inter m l.
Proof.
intros;
elim (uniqdec.eq_line_dec l m).
intro;subst.
trivial.
intros.

intros; unfold inter;firstorder.
repeat (elim a2_exist); simpl;intros.
use_all.
collapse.
Qed.

Lemma line_comm : forall A B, (line A B)=(line B A).
Proof.
intros; elim (uniqdec.eq_point_dec A B).
intros; subst; auto.
intros ; unfold line; repeat (elim a1_exist); simpl; intros; use_all.
collapse.
Qed.

Hint Resolve inter_comm line_comm
                          col_comm col_comm2 col_comm3 col_comm4 col_comm5.

Lemma  line_neq_neq :
 forall A B C D, forall l m, A<>B -> C<>D ->
 Incid A l -> Incid B l -> Incid C m -> Incid D m -> (line A B) <> (line C D) -> l<>m.
Proof.
intros.
unfold line in *; revert H5.
repeat (elim a1_exist); simpl;firstorder.
collapse.
auto.
Qed.

Lemma incid_inter_left :
forall A B C D, Incid (inter (line A B) (line C D)) (line A B).
Proof.
intros; unfold inter; repeat (elim a2_exist); simpl; firstorder.
Qed.

Lemma incid_inter_right :
forall A B C D, Incid (inter (line A B) (line C D)) (line C D).
Proof.
intros; unfold inter; repeat (elim a2_exist); simpl; firstorder.
Qed.

Hint Resolve incid_inter_left incid_inter_right.

(* Invariance by permutation of hexamy property *)

Lemma hexamy_rot_left : forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy B C D E F A.
Proof.
intros; unfold is_hexamy in *.
unfold Col in *; firstorder.
exists x; firstorder.
rewrite inter_comm; auto.
Qed.

Lemma hexamy_rot_right : forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy F A B C D E.
Proof.
intros; unfold is_hexamy in *.
unfold Col in *; firstorder.
exists x; firstorder.
rewrite inter_comm; auto.
Qed.

Hint Resolve hexamy_rot_left hexamy_rot_right : permut.

Lemma hexamy_swap_2_3 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A C B D E F.
Proof.
intros; apply hexamy_rot_right; apply H;
       apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_2_4 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A D C B E F.
Proof.
intros;
apply hexamy_rot_right; apply H;
apply hexamy_rot_right; apply H;
apply hexamy_rot_left; apply H;
apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_2_5 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A E C D B F.
Proof.
intros;
apply H; apply hexamy_rot_left; apply H;
apply hexamy_rot_left; apply H;
apply hexamy_rot_right; apply H;
apply hexamy_rot_right; apply H; exact H0.
Qed.

Lemma hexamy_swap_2_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A F C D E B.
Proof.
intros;
apply H; apply hexamy_rot_left; apply H;
apply hexamy_rot_right; apply H; exact H0.
Qed.

Lemma hexamy_swap_3_4 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B D C E F.
Proof.
intros;
do 2 apply hexamy_rot_right;
apply H; apply hexamy_rot_left;
apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_3_5 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B E D C F.
Proof.
intro H; intro A; intro B; intro C; intro D; intro E; intro F; intro H0;
       apply hexamy_rot_right; apply hexamy_rot_right;
       apply H; apply hexamy_rot_right; apply H;
       apply hexamy_rot_left; apply H;
       apply hexamy_rot_left; apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_3_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B F D E C.
Proof.
intros.
do 2 apply hexamy_rot_right;
apply H.
apply hexamy_rot_right.
apply H.
do 2 apply hexamy_rot_right.
apply H;
apply hexamy_rot_right; apply H;
apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_4_5 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C E D F.
Proof.
intros.
do 3 apply hexamy_rot_left;
apply H;
do 3 apply hexamy_rot_left;
exact H0.
Qed.

Lemma hexamy_swap_4_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C F E D.
Proof.
intros.
do 3 apply hexamy_rot_right.
apply H.
apply hexamy_rot_right.
apply H.
apply hexamy_rot_left.
apply H.
do 3 apply hexamy_rot_left;
exact H0.
Qed.

Lemma hexamy_swap_5_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C D F E.
Proof.
intros;
do 2 apply hexamy_rot_left;
apply H;
do 2 apply hexamy_rot_right;
exact H0.
Qed.

Ltac put_in_front P := repeat (match goal with
 H:_ |- is_hexamy P ?B ?C ?D ?E ?F => idtac
|H:_ |- is_hexamy ?A ?B ?C ?D ?E ?F => apply hexamy_rot_left
|H:_ |- _ => fail "goal must be hexamy"
end).

Ltac hexamy_permut_1:= match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy _ _ _ _ _ _  => put_in_front A
end.

Ltac hexamy_permut_2 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B _ _ _ _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?B ?Y ?Z ?T  => cut (is_hexamy A B X Y Z T) ; [apply (hexamy_swap_2_3 HH) | idtac ]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?Y ?B ?Z ?T  => cut (is_hexamy A B Y X Z T) ; [apply (hexamy_swap_2_4 HH) | idtac]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?Y ?Z ?B ?T  => cut (is_hexamy A B Y Z X T) ; [apply (hexamy_swap_2_5 HH)|idtac]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?Y ?Z ?T ?B  => cut (is_hexamy A B Y Z T X) ; [apply (hexamy_swap_2_6 HH)| idtac]
end.

Ltac hexamy_permut_3 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C _ _ _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?X ?C ?Y ?Z  => cut (is_hexamy A B C X Y Z) ; [apply (hexamy_swap_3_4 HH) | idtac ]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?X ?Y ?C ?Z  => cut (is_hexamy A B C Y X Z) ; [apply (hexamy_swap_3_5 HH) | idtac]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?X ?Y ?Z ?C  => cut (is_hexamy A B C Y Z X) ; [apply (hexamy_swap_3_6 HH)|idtac]
end.

Ltac hexamy_permut_4 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?D _ _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?X ?D ?Y  => cut (is_hexamy A B C D X Y) ; [apply (hexamy_swap_4_5 HH) | idtac ]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?X ?Y ?D  => cut (is_hexamy A B C D Y X) ; [apply (hexamy_swap_4_6 HH) | idtac]
end.

Ltac hexamy_permut_5 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?D ?E _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?D ?X ?E  => cut (is_hexamy A B C D E X) ; [apply (hexamy_swap_5_6 HH) | idtac ]
end.

Ltac hexamy_permut := hexamy_permut_1 ; hexamy_permut_2 ; hexamy_permut_3 ; hexamy_permut_4 ; hexamy_permut_5 ; assumption.

Lemma test4  : forall A C J A' C' K, hexamy -> is_hexamy A C J A' C' K -> is_hexamy A A' J C C' K.
Proof.
intros; hexamy_permut.
Qed.

Lemma test5 : forall P M L Q N H, hexamy ->
is_hexamy P M L Q N H -> is_hexamy P Q L M N H.
Proof.
intros; hexamy_permut.
Qed.

Lemma test3 : forall A B C D E F, hexamy -> is_hexamy B F D A E C ->
is_hexamy A B C D E F.
Proof.
intros.
hexamy_permut.
Qed.

Lemma test : forall A B C D E F, hexamy ->
is_hexamy A B C D E F -> is_hexamy B A C E D F.
Proof.
intros.
hexamy_permut.
Qed.

Lemma test3' : forall A B C D E F, hexamy -> is_hexamy B F D A E C ->
is_hexamy A B C D E F.
Proof.
intros.
hexamy_permut.
Qed.

Lemma hexamy_swap_right : hexamy ->
forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C D F E.
Proof.
intros.
hexamy_permut.
Qed.

Lemma col_line_eq : forall A B C,
 Col A B C -> A<>B -> A<>C ->
 line A B = line A C.
Proof.
intros.
unfold line.
repeat elim a1_exist;intros.
simpl.
unfold Col in H.
use H.
use p.
use p0.
assert (x=x1).
eapply a1_unique;eauto.
subst.
assert (x1=x0).
eapply a1_unique; try apply H0;auto.
subst.
auto.
Qed.

Lemma col_trivial_1: forall A B, Col A A B.
Proof.
intros.
create_line A B lAB.
exists lAB.
auto.
Qed.

Lemma col_trivial_2: forall A B, Col A B B.
Proof.
intros.
create_line A B lAB.
exists lAB.
auto.
Qed.

Lemma col_trivial_3: forall A B, Col A B A.
Proof.
intros.
create_line A B lAB.
exists lAB.
auto.
Qed.

Hint Resolve col_trivial_1 col_trivial_2 col_trivial_3.

Ltac solve_col := match goal with
 HA: Incid ?A ?l, HB: Incid ?B ?l, HC : Incid ?C ?l |- Col ?A ?B ?C => exists l; auto
| H:_ |- Col ?A ?A ?B => auto
| H:_ |- Col ?A ?B ?B => auto
| H:_ |- Col ?A ?B ?A => auto
end.

 Ltac revert_all_inter T := (match goal with
H: context[inter (line _ _) (line _ _)] |- _ => revert H
end;revert_all_inter T;intro) || T.

Ltac remove_inter_points_occ_all := revert_all_inter remove_inter_points_occ.

Ltac remove_inter_points_occ_assum := do 3  (match goal with

|HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP1 : Incid ?P ?l,
HP2 : Incid ?P ?m ,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd A B C D P l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?A ?m,
H: context[inter (line ?A ?B) (line ?C ?D)]|- _ =>
rewrite <- (on_inter_points_wd_spec_1 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?B ?m,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_2 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?C ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_3 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?D ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_4 A B C D l m) in H; try assumption_or_sym

end).

Ltac hexamy_proof_1  A B C D E F :=
  let T := fresh "hexa" in
 assert (T:is_hexamy A B C D E F);
  [unfold is_hexamy;split;[assumptions_or_sym|
                                        remove_inter_points_occ; remove_line_occ; try solve [solve_col]]|
   idtac].

Ltac print_goal := match goal with
H:_ |- ?X => idtac X
end.

Ltac hexamy_proof A B C D E F A' B' C' D' E' F' :=
  let T := fresh "hexa" in
  let U := fresh "hexa" in
  assert (T:is_hexamy A B C D E F);
  [unfold is_hexamy;split;[assumptions_or_sym|
                                        remove_inter_points_occ; remove_line_occ; try solve [solve_col];print_goal]|
   assert (U:is_hexamy A' B' C' D' E' F') by hexamy_permut;
   unfold is_hexamy in U;use U;
     remove_inter_points_occ_assum;auto].

(* This first definition of Pappus is the most general one. *)

Definition pappus_strong :=
 forall A B C A' B' C' P Q R,
 (dist6 A B C A' B' C' \/
 (line A B' <> line A' B /\ A<>B' /\ A'<>B /\
  line B C' <> line B' C /\ B<>C' /\ B'<>C /\
  line A C' <> line A' C /\ A<>C' /\ A'<>C) ) ->
 Col A B C -> Col A' B' C' ->
 is_on_inter P A B' A' B ->
 is_on_inter Q B C' B' C ->
 is_on_inter R A C' A' C ->
 Col P Q R.

(* This second definition of Pappus' configuration assumes that all the 6 points are distincts
and that the intersection are all well defined. This implies also that the line AB and A'B'
are distinct. This is the figure without any particular case. *)

Definition pappus_weak :=
 forall A B C A' B' C' P Q R,
 Col A B C -> Col A' B' C' ->
 dist6 A B C A' B' C' ->
 is_on_proper_inter P A B' A' B ->
 is_on_proper_inter Q B C' B' C ->
 is_on_proper_inter R A C' A' C ->
 Col P Q R.

Lemma is_on_proper_inter_is_on_inter : forall P A B C D,
 is_on_proper_inter P A B C D -> is_on_inter P A B C D.
Proof.
intros.
unfold is_on_proper_inter, is_on_inter in *.
intuition.
Qed.

Lemma pappus_pappus_strong : pappus_weak <-> pappus_strong.
Proof.
unfold pappus_weak, pappus_strong.
split;intros.

2:apply (H  A B C A' B' C');auto using  is_on_proper_inter_is_on_inter.

decompose [or] H0;clear H0.

  elim (uniqdec.eq_line_dec (line A' B) (line A B')).
  intros.
  geo_norm.
  subst.
  remove_line_occ.
  subst.
  rename  x5 into l.
  rename x6 into m.
  rename x3 into lAB'.
  rename x2 into lB'C.
  rename x1 into lBC'.
  rename x0 into lA'C.
  rename x into lAC'.
  collapse.
  solve_col.

  intro.

  elim (uniqdec.eq_line_dec (line B' C) (line B C')).
  intros.
  geo_norm.
  subst.
  remove_line_occ.
  subst.
  collapse.
  solve_col.

  intro.

  elim (uniqdec.eq_line_dec (line A' C) (line A C')).
  intros.
  geo_norm.
  subst.
  remove_line_occ.
  subst.
  collapse.
  solve_col.

  intro.

  apply (H  A B C A' B' C'); auto;

  unfold is_on_inter, is_on_proper_inter, dist6 in *;use_all;auto.

use H6.

cases_point A B.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point A C.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point B C.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point A' B'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point A' C'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point B' C'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point A A'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point A B'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point A C'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point B A'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point B B'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point B C'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point C A'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point C B'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

cases_point C C'.
geo_norm.
remove_line_occ.
collapse.
solve_col.

apply (H  A B C A' B' C'); try assumption.
unfold dist6;intuition.

unfold is_on_proper_inter, is_on_inter in *; use_all;auto.
unfold is_on_proper_inter, is_on_inter in *; use_all;auto.
unfold is_on_proper_inter, is_on_inter in *; use_all;auto.
Qed.

Ltac not_eq_pt_all := match goal with
| A:Point,B:Point |- _ => assert_if_not_exist (A<>B);[ solve_eq | idtac]
end.

Ltac not_eq_li_all := match goal with
 | L:Line,M:Line |- _ => assert_if_not_exist (L<>M);[ solve_eq | idtac]
end.

Lemma essai : forall A B C:Point, A<>B -> True.
intros.
not_eq_pt_all.
auto.
Qed.

Ltac collapse_all n := do n (not_eq_pt_all; not_eq_li_all); collapse.

Lemma hexamy_special_case :  forall A B C D E F,
 dist6 A B C D E F ->
 Col A B C -> Col D E F -> is_hexamy A B C D E F.
Proof.
intros.
unfold is_hexamy.
split.
solve [auto].
geo_norm;remove_line_occ;solve_col.
Qed.

(* This theorem shows that Pappus property implies the Hexamys property *)

Unset Regular Subst Tactic.

Lemma hexamy_prop: pappus_strong -> forall A B C D E F,
 (line C D) <> (line A F) ->
 (line B C) <> (line E F) ->
 (line A B) <> (line D E) ->

 (line A C) <> (line E F) ->
 (line B F) <> (line C D) ->
 is_hexamy A B C D E F -> is_hexamy B A C D E F.
Proof.
intro HPappus.
intros.
unfold is_hexamy in *.
use H4.
split;[repeat split;auto|idtac].
create_line A B lAB.
create_line A C lAC.
create_line A D lAD.
create_line A E lAE.
create_line A F lAF.

create_line B C lBC.
create_line B D lBD.
create_line B E lBE.
create_line B F lBF.

create_line C D lCD.
create_line C E lCE.
create_line C F lCF.

create_line D E lDE.
create_line D F lDF.

create_line E F lEF.

create_inter B C E F a.
create_inter C D F A b.
create_inter A B D E c.
collapse.

replace (line A B) with l3 in * by (rewrite (line_wd A B l3) by assumption;trivial).
replace (line B C) with l  in * by (rewrite (line_wd B C l)  by assumption;trivial).
replace (line E F) with l0 in * by (rewrite (line_wd E F l0) by assumption;trivial).
replace (line C D) with l1 in * by (rewrite (line_wd C D l1) by assumption;trivial).
replace (line A F) with l2 in * by (rewrite (line_wd A F l2) by assumption;trivial).
replace (line D E) with l4 in * by (rewrite (line_wd D E l4) by assumption;trivial).
replace (line A C) with lAC in * by (rewrite (line_wd A C lAC) by assumption;trivial).
replace (line B F) with lBF in * by (rewrite (line_wd B F lBF) by assumption;trivial).
replace (line A D) with lAD in * by (rewrite (line_wd A D lAD) by assumption;trivial).
replace (line C E) with lCE in * by (rewrite (line_wd C E lCE) by assumption;trivial).
replace (line F B) with lBF in * by (rewrite (line_wd_sym F B lBF) by assumption;trivial).
replace (line A E) with lAE in * by (rewrite (line_wd A E lAE) by assumption;trivial).
replace (line E C) with lCE in * by (rewrite (line_wd_sym E C lCE) by assumption;trivial).
replace (line F A) with l2 in * by (rewrite (line_wd_sym F A l2) by assumption;trivial).
replace (line B A) with l3 in * by (rewrite (line_wd_sym B A l3) by assumption;trivial).
create_point lAC l0 b'.

revert H6;repeat remove_inter_occ;intro.

geo_norm.

cases_line lAD l2.
cases_point c D.
remove_inter_occ.
auto.
collapse.
cases_point a E.

create_inter B F C D w.
collapse.
remove_inter_occ.

cut (Col w b' c).
auto.
apply (HPappus D F A B C E w b' c).
left.
unfold dist6;repeat split;auto.
solve_col.
solve_col.
unfold is_on_inter;split;solve_col.
unfold is_on_inter;split;solve_col.
unfold is_on_inter;split;solve_col.

collapse.
auto.

cases_line l3 lAE.
cases_point a c.
auto.
collapse.
cases_point b F.
remove_inter_occ.
solve_col.
collapse.
remove_inter_occ.
solve_col.

cases_line l0 l2.
replace (inter l1 lBF) with B.
solve_col.
unfold inter;elim a2_exist; intros; simpl;geo_norm;solve [collapse].

cases_line lCE l0.
cases_point c C.
solve [auto].
exists x.
repeat split;auto.
unfold inter;elim a2_exist;simpl;intros;use_all;solve [auto].

cases_line lAD l4.
cases_point b' A.
solve[auto].
cases_point b A.
cases_point a A.
intuition.
exists l4.
repeat split; auto.
unfold inter;elim a2_exist;simpl;intros;use_all;solve [auto].

collapse.
replace (inter l1 l) with C.
solve_col.
unfold inter;elim a2_exist;simpl;intros;use_all;collapse.

cases_line l1 l4.
not_eq a b.
not_eq a c.

cases_point b c.

replace (inter l4 l2) with c.
solve [auto].
unfold inter; elim a2_exist; simpl;intros; geo_norm; collapse.
collapse;remove_inter_occ;solve [auto].

cases_line l1 l0.
remove_inter_occ.
solve [solve_col].

cases_line l4 l0.
cases_point b c.
intuition.
cases_point b' c.
auto.
collapse.
remove_inter_occ.
solve_col.

cases_line lAC l2.
cases_point c B.
exists lBF.
repeat split;auto.
unfold inter; elim a2_exist;simpl;intros;use p;solve [auto].
collapse.
exists x.
repeat split;auto.
unfold inter; elim a2_exist;simpl;intros;use p;solve [auto].

cases_line lAC l.
replace (inter x lBF) with B.
solve [solve_col].
unfold inter; elim a2_exist;simpl;intros;use p;solve [collapse].

cases_line lAC l1.
remove_inter_occ.
solve [solve_col].

not_eq a b.

not_eq a c.
not_eq a b'.
not_eq A a.
not_eq b' a.
not_eq C a.

not_eq b c.
not_eq b b'.
not_eq C b.
not_eq A b.

not_eq A c.
not_eq c b'.
not_eq C c.

not_eq A b'.
not_eq A C.

not_eq b' C.

assert (dist6 a b c A b' C)
  by (unfold dist6;assumptions_or_sym).

assert (Col A b' C) by solve_col.

assert (is_on_inter F a b' A b) by (unfold is_on_inter;split;solve_col).
assert (is_on_inter B a C A c) by (unfold is_on_inter;split;solve_col).

create_line c b' lcb'.
create_point l1 lcb' P.

assert (is_on_inter (inter l1 lcb') b C b' c).
  unfold is_on_inter;split.

  exists l1;
  repeat split;auto;
  unfold inter;
  elim (a2_exist);intro;
  simpl;intuition.

  exists lcb';
  repeat split;auto;
  unfold inter;
  elim (a2_exist);intro;
  simpl;intuition.

assert (Col F (inter l1 lcb') B)
  by (apply (HPappus a b c A b' C F (inter l1 lcb') B);auto || solve_col).

replace (inter l1 lcb') with (inter l1 lBF) in *.

geo_norm.
collapse.

solve_col.

geo_norm.
collapse.

unfold inter at 1.
elim a2_exist;intro;simpl.
intros;use p;collapse.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rbasic_fun.
Require BuiltIn.
Require int.Int.
Require real.Real.
Require real.Abs.
Require real.FromInt.
Require floating_point.Rounding.
Require floating_point.SingleFormat.

Require Import floating_point.GenFloat.

(* Why3 goal *)
Definition round: floating_point.Rounding.mode -> R -> R.
exact (round 24 128).
Defined.

(* Why3 goal *)
Definition value: floating_point.SingleFormat.single -> R.
exact (value 24 128).
Defined.

(* Why3 goal *)
Definition exact: floating_point.SingleFormat.single -> R.
exact (exact 24 128).
Defined.

(* Why3 goal *)
Definition model: floating_point.SingleFormat.single -> R.
exact (model 24 128).
Defined.

(* Why3 assumption *)
Definition round_error (x:floating_point.SingleFormat.single): R :=
  (Reals.Rbasic_fun.Rabs ((value x) - (exact x))%R).

(* Why3 assumption *)
Definition total_error (x:floating_point.SingleFormat.single): R :=
  (Reals.Rbasic_fun.Rabs ((value x) - (model x))%R).

(* Why3 assumption *)
Definition no_overflow (m:floating_point.Rounding.mode) (x:R): Prop :=
  ((Reals.Rbasic_fun.Rabs (round m
  x)) <= (33554430 * 10141204801825835211973625643008)%R)%R.

Lemma max_single_eq: (33554430 * 10141204801825835211973625643008 = max 24 128)%R.
unfold max, Fcore_defs.F2R; simpl.
ring.
Qed.

(* Why3 goal *)
Lemma Bounded_real_no_overflow : forall (m:floating_point.Rounding.mode)
  (x:R),
  ((Reals.Rbasic_fun.Rabs x) <= (33554430 * 10141204801825835211973625643008)%R)%R ->
  (no_overflow m x).
intros m x Hx.
unfold no_overflow.
rewrite max_single_eq in *.
exact (Bounded_real_no_overflow 24 128 (refl_equal true) (refl_equal true) m x Hx).
Qed.

(* Why3 goal *)
Lemma Round_monotonic : forall (m:floating_point.Rounding.mode) (x:R) (y:R),
  (x <= y)%R -> ((round m x) <= (round m y))%R.
apply Round_monotonic.
easy.
Qed.

(* Why3 goal *)
Lemma Round_idempotent : forall (m1:floating_point.Rounding.mode)
  (m2:floating_point.Rounding.mode) (x:R), ((round m1 (round m2
  x)) = (round m2 x)).
now apply Round_idempotent.
Qed.

(* Why3 goal *)
Lemma Round_value : forall (m:floating_point.Rounding.mode)
  (x:floating_point.SingleFormat.single), ((round m (value x)) = (value x)).
now apply Round_value.
Qed.

(* Why3 goal *)
Lemma Bounded_value : forall (x:floating_point.SingleFormat.single),
  ((Reals.Rbasic_fun.Rabs (value x)) <= (33554430 * 10141204801825835211973625643008)%R)%R.
rewrite max_single_eq.
now apply Bounded_value.
Qed.

(* Why3 goal *)
Lemma Exact_rounding_for_integers : forall (m:floating_point.Rounding.mode)
  (i:Z), (((-16777216%Z)%Z <= i)%Z /\ (i <= 16777216%Z)%Z) -> ((round m
  (Reals.Raxioms.IZR i)) = (Reals.Raxioms.IZR i)).
intros m i Hi.
now apply Exact_rounding_for_integers.
Qed.

(* Why3 goal *)
Lemma Round_down_le : forall (x:R), ((round floating_point.Rounding.Down
  x) <= x)%R.
now apply Round_down_le.
Qed.

(* Why3 goal *)
Lemma Round_up_ge : forall (x:R), (x <= (round floating_point.Rounding.Up
  x))%R.
now apply Round_up_ge.
Qed.

(* Why3 goal *)
Lemma Round_down_neg : forall (x:R), ((round floating_point.Rounding.Down
  (-x)%R) = (-(round floating_point.Rounding.Up x))%R).
now apply Round_down_neg.
Qed.

(* Why3 goal *)
Lemma Round_up_neg : forall (x:R), ((round floating_point.Rounding.Up
  (-x)%R) = (-(round floating_point.Rounding.Down x))%R).
now apply Round_up_neg.
Qed.

(* Why3 goal *)
Definition round_logic: floating_point.Rounding.mode -> R ->
  floating_point.SingleFormat.single.
exact (round_logic 24 128 (refl_equal true) (refl_equal true)).
Defined.

(* Why3 goal *)
Lemma Round_logic_def : forall (m:floating_point.Rounding.mode) (x:R),
  (no_overflow m x) -> ((value (round_logic m x)) = (round m x)).
Proof.
intros m x.
unfold no_overflow.
rewrite max_single_eq.
exact (Round_logic_def 24 128 (refl_equal true) (refl_equal true) m x).
Qed.

(* Why3 assumption *)
Definition of_real_post (m:floating_point.Rounding.mode) (x:R)
  (res:floating_point.SingleFormat.single): Prop := ((value res) = (round m
  x)) /\ (((exact res) = x) /\ ((model res) = x)).

(* Why3 assumption *)
Definition add_post (m:floating_point.Rounding.mode)
  (x:floating_point.SingleFormat.single)
  (y:floating_point.SingleFormat.single)
  (res:floating_point.SingleFormat.single): Prop := ((value res) = (round m
  ((value x) + (value y))%R)) /\
  (((exact res) = ((exact x) + (exact y))%R) /\
  ((model res) = ((model x) + (model y))%R)).

(* Why3 assumption *)
Definition sub_post (m:floating_point.Rounding.mode)
  (x:floating_point.SingleFormat.single)
  (y:floating_point.SingleFormat.single)
  (res:floating_point.SingleFormat.single): Prop := ((value res) = (round m
  ((value x) - (value y))%R)) /\
  (((exact res) = ((exact x) - (exact y))%R) /\
  ((model res) = ((model x) - (model y))%R)).

(* Why3 assumption *)
Definition mul_post (m:floating_point.Rounding.mode)
  (x:floating_point.SingleFormat.single)
  (y:floating_point.SingleFormat.single)
  (res:floating_point.SingleFormat.single): Prop := ((value res) = (round m
  ((value x) * (value y))%R)) /\
  (((exact res) = ((exact x) * (exact y))%R) /\
  ((model res) = ((model x) * (model y))%R)).

(* Why3 assumption *)
Definition div_post (m:floating_point.Rounding.mode)
  (x:floating_point.SingleFormat.single)
  (y:floating_point.SingleFormat.single)
  (res:floating_point.SingleFormat.single): Prop := ((value res) = (round m
  ((value x) / (value y))%R)) /\
  (((exact res) = ((exact x) / (exact y))%R) /\
  ((model res) = ((model x) / (model y))%R)).

(* Why3 assumption *)
Definition neg_post (x:floating_point.SingleFormat.single)
  (res:floating_point.SingleFormat.single): Prop :=
  ((value res) = (-(value x))%R) /\ (((exact res) = (-(exact x))%R) /\
  ((model res) = (-(model x))%R)).

(* Why3 assumption *)
Definition lt (x:floating_point.SingleFormat.single)
  (y:floating_point.SingleFormat.single): Prop := ((value x) < (value y))%R.

(* Why3 assumption *)
Definition gt (x:floating_point.SingleFormat.single)
  (y:floating_point.SingleFormat.single): Prop := ((value y) < (value x))%R.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import gset gmap excl agree frac.
From iris.heap_lang.lib Require Export lock.
From iris.heap_lang.lib Require Import par.
From iris.bi.lib Require Import fractional.
Require Import clh_lock.

Definition read  : expr :=
    λ: "l" "k" ,
    let: "p" := init_proc #() in
    request "l" "p";;
    let: "v" := !"k" in
    grant "p";;
    "v".

Definition simple_client : expr :=
    let: "r" := ref #42 in
    let: "lock" := init_lock #()in
    (read "lock" "r") ||| (read "lock" "r").

Section proof.
Local Set Default Proof Using All.
 Context `{!heapG Σ, !lockedG Σ, !stateG Σ, !spawnG Σ} (N : namespace).

Lemma read_spec l γ3 k:
  {{{isLock N  l (k ↦ #42) γ3}}}
    read #l #k
  {{{ v, RET v;  ⌜v = #42⌝ }}}.
Proof.
  iIntros (ϕ) "#HLock Hcont".
  wp_pures.
  wp_bind (init_proc _)%E.
  wp_apply (init_proc_spec N (k ↦ #42)%I γ3).
  { done. }
  iIntros (p) "HProc".
  iDestruct "HProc" as ( γ1 γ2 γ1' γ2') "HProc".
  wp_pures.
  wp_apply (request_spec N l _ (k ↦ #42)%I γ1 γ2 γ3 γ1' γ2' with "[HProc]").
  { iFrame "#".  iFrame. }
  iIntros "HPost".
  iDestruct "HPost" as (γ1'' γ2'') "[HProc [HL HR]]".
  wp_pures.
  wp_load.
  wp_pures.
  wp_apply( grant_spec N _ (k ↦ #42)%I γ1 γ2 γ3 γ1'' γ2'' with "[-Hcont]").
  {iFrame. }
  iIntros "HProc".
  wp_pures.
  iApply "Hcont".
  eauto.
Qed.

Lemma simple_spec :
  {{{True}}}simple_client {{{p, RET p; ⌜p=(#42, #42)%V ⌝}}}.
Proof.
      iIntros (ϕ) "_ Hcont".
      rewrite /simple_client.
      wp_alloc r as "H".
      wp_let.
      wp_bind (init_lock _ )%E.
      wp_apply (init_lock_spec N (r ↦ #42)%I with "[-Hcont]").
      eauto with iFrame.
      iIntros (l) "HLock".
      iDestruct "HLock" as (γ3) "#HLock".
      wp_pures.
      iApply (wp_par (λ v , ⌜v=#42⌝)%I (λ v , ⌜v=#42⌝)%I).
      - iApply (read_spec).
        {iFrame "#". }
        iNext.
        iIntros (v) "H".
        iFrame.
      - iApply (read_spec).
        {iFrame "#". }
        iNext.
        iIntros (v) "H".
        iFrame.
      - iIntros (v1 v2) "[-> ->]".
        iNext.
        iApply "Hcont".
        eauto.
Qed.