(**

This module implements the following

- The encryption iterator for ChaCha20 and XChaCha20.

- A host-endian variant of the chacha20 keystream meant for use in
  csprg.

 *)

Require Import Verse.
Import VerseNotations.
Require Import Verse.CryptoLib.chacha20.common.

Module Internal.

  Section ChaCha20.

    (** ** Program variables.

    Following the standard idiom, we start by abstracting over the
    program variables

     *)

    Variable progvar  : VariableT.

    Section Params.
      (**

       The chacha20 round function takes the key, iv, and the
       counter. The xchacha20 variant uses an extended iv which is
       captured by the [xiv] variable.

       *)

      Variable key      : progvar of type Key.
      Variable iv       : progvar of type IV.
      Variable ctrRef   : progvar of type (Array 1 hostE Counter).

      (** IV for hchacha20 *)
      Variable hiv0 hiv1 hiv2 hiv3 : progvar of type Word.

      Section Locals.

        (* We do not have local stack variables *)

        (**
       Besides we have the following in registers

       - The 4x4 state matrix in x0,...,x16

       - A register copy of the counter

       - A temporary register

         *)

        Variable Temp            : progvar of type Word.
        Variable ctr             : progvar of type Counter.
        (* NOTE : The following variables haven't been declared as a
        variable array because of the way `ROUNDS` is written
        below. We remark there about a possible fix *)
        Variable x0  x1  x2  x3
                 x4  x5  x6  x7
                 x8  x9  x10 x11
                 x12 x13 x14 x15 : progvar of type Word.

        (**
        Let us make some auxiliary definitions that simplify some of
        the variable manipulations.

         *)
        Definition stateVars := [ x0; x1; x2; x3;
                                  x4; x5; x6; x7;
                                  x8; x9; x10; x11;
                                  x12; x13; x14; x15
                                ].

        (** It is useful to have a uniform way to index the state variables. *)

        Definition X : VarIndex progvar 16 Word := varIndex stateVars.

        (** ** The chacha20 keystream.

        The chacha20 cipher consists of computing a key stream which
        is then xor-ed to the input stream to get the encrypted
        stream. Computation of the key stream is done by transforming
        the state matrix as follows (the bits in the state matrix
        becomes the key stream)

        - Initialisation of the state.

        - Apply 20 rounds of the chacha20 round function.

        - Update the state by adding the initial value of the state.

         *)

        (** *** The initialisation.

       The initial state is computed as follows.

         *)

        Definition Init : Repeat (statement progvar).
          verse [code|
              x0  := C0         ; x1  := C1         ; x2  := C2         ; x3  := C3;
              x4  := key[ 0 ] ; x5  := key[ 1 ] ; x6  := key[ 2 ] ; x7 := key[ 3 ];
              x8  := key[ 4 ] ; x9  := key[ 5 ] ; x10 := key[ 6 ] ; x11 := key[ 7 ];
              x12 := ctr      ; x13 := iv [ 0 ] ; x14 := iv[ 1 ]  ; x15 := iv[ 2 ]
            |].
        Defined.

        (** *** The chacha20 round.

     The rounds are defined in terms of the chacha20 quarter round

         *)

        Definition QRound (a b c d : progvar of type Word) : Repeat (statement progvar)
          := [code|
               a += b; d ⊕= a; d := d ⋘ `16`;
               c += d; b ⊕= c; b := b ⋘ `12`;
               a += b; d ⊕= a; d := d ⋘ `8`;
               c += d; b ⊕= c; b := b ⋘ `7`
             |].

        (**

       The 20 rounds that the algorithm performs, alternate between
       the _column round_ where we apply the quarter round on all the
       four columns and the _diagonal round_ where the quarter round
       is applied on each of the four diagonals. We code this up as 10
       double round where a double round consists of a column round
       and a diagonal round.

         *)

        (* NOTE : Since the following usage of x_i's is naked (not in
        custom syntax code), we have deferred use of a variable array
        for the x's. Duplicating the custom syntax indexing notation
        outside it too, and wrapping the following in the `verse`
        tactic might be a solution *)
        Definition Rounds : Repeat (statement progvar) :=
          let colRound := List.concat [ QRound x0 x4 x8   x12;
                                        QRound x1 x5 x9   x13;
                                        QRound x2 x6 x10  x14;
                                        QRound x3 x7 x11  x15
                                      ] in
          let diagRound := List.concat [ QRound x0 x5 x10 x15;
                                         QRound x1 x6 x11 x12;
                                         QRound x2 x7 x8  x13;
                                         QRound x3 x4 x9  x14
                                       ] in
          let doubleRound := (colRound ++ diagRound)%list
          in List.concat (List.repeat doubleRound 10).

        (** ** The state update.

        In the final step, we updated the transformed state by adding
        it to the initial state.

         *)
        Definition Update : Repeat (statement progvar).
          verse [code|
              x0  += C0         ; x1  += C1         ; x2  += C2         ; x3  += C3;
              x4  += key[ 0 ] ; x5  += key[ 1 ] ; x6  += key[ 2 ] ; x7  += key[ 3 ];
              x8  += key[ 4 ] ; x9  += key[ 5 ] ; x10 += key[ 6 ] ; x11 += key[ 7 ];
              x12 += ctr      ; x13 += iv [ 0 ] ; x14 += iv[ 1 ]  ; x15 += iv[ 2 ]
            |].

        Defined.

        (** ** The chacha20 stream

        Putting all the code fragments together, we have the algorithm
        that compute the chacha20 stream inside the state matrix.

         *)

        Definition TransformState := List.concat [ Init; Rounds; Update].

        (** ** The XChaCha20 variant.

    The XChaCha20 cipher is a variant of the standard chacha20 cipher
    but supports a 192-bit (6x32-bit). With the iv being large, one
    can safely choose them at random and be confident of not repeating
    them ever --- the 96-bit iv that the standard supports is too
    small for such random choice and would often need to keep track of
    additional information to ensure that ivs are not repeated.

    This variant uses the following steps

    - It uses the HChaCha20 hashing to first initialise a key (which
      makes use of the first four words of the iv.

    - It then uses certain portion of the state and the rest of the
      two words as the key and iv for a chacha20 state.

         *)

        (** ** The Encryption and the keystream.

        Recall that this module serves as the base for two different
        implementations, the first being the chacha20 encryption and
        the other being the keystream for csprg. We define the block
        transformation for each of the case above.

         *)

        Definition XorBlock (B : progvar of type (Block littleE))(i : nat) (_ : i < 16)
          : Repeat (statement progvar).
          verse [code| Temp := B[ i ]; Temp ⊕= X [ i ]; B[ i ] <- Temp |].
        Defined.

        Definition EmitStream (B : progvar of type (Block hostE))(i : nat) (_ : i < 16)
          : Repeat (statement progvar).
          verse [code| B[ i ] <-  X [ i ] |].
        Defined.

        Definition Encrypt blk : Repeat (statement progvar)
          := (TransformState ++ foreach (indices blk) (XorBlock blk)
                             ++ [code| ctr += `1` |])%list.

        Definition CSPRGStream blk : Repeat (statement progvar)
          := (TransformState ++ foreach (indices blk) (EmitStream blk)
                             ++ [code| ctr += `1` |])%list.

        (* ** The HChacha20 hash and XChacha20.

       The XChacha20 is a variant of chacha20 that uses a larger iv
       which allows us to use random ivs with out fear of
       collision. Remember that if key,iv pairs are repeated, it would
       compromise the encryption of chacha20. The XChacha20 uses the
       key and part of the iv to first set up a subkey using the
       HChacha20 hash. It then proceeds to compute the encryption
       using this subkey and the rest of the iv. This module also
       exposes the hchacha20 function that updates the key array with
       the subkey.

         *)
        Definition HInit : Repeat (statement progvar).
          verse [code|
              x0  := C0       ; x1  := C1       ; x2  := C2       ; x3  := C3;
              x4  := key[ 0 ] ; x5  := key[ 1 ] ; x6  := key[ 2 ] ; x7 := key[ 3 ];
              x8  := key[ 4 ] ; x9  := key[ 5 ] ; x10 := key[ 6 ] ; x11 := key[ 7 ];
              x12 := hiv0     ; x13 := hiv1     ; x14 := hiv2     ; x15 := hiv3
            |].
        Defined.

        Definition HUpdateKey : Repeat (statement progvar).
          verse [code|
                  key [ 0 ] <- x0;
                  key [ 1 ] <- x1;
                  key [ 2 ] <- x2;
                  key [ 3 ] <- x3;
                  key [ 4 ] <- x12;
                  key [ 5 ] <- x13;
                  key [ 6 ] <- x14;
                  key [ 7 ] <- x15
                |].
        Defined.

        Definition hChaCha20 : Repeat (statement progvar) :=  List.concat [ HInit; Rounds; HUpdateKey ].

        (** ** The iterators.

        Finally we define the iterator code for both the chacha20
        encryption and the chacha20 host-endian key stream.

         *)
        Definition LoadCounter : Repeat (statement progvar).
          verse [code| ctr := ctrRef[ 0 ] |].
        Defined.
        Definition StoreCounter : Repeat (statement progvar).
          verse [code| ctrRef[ 0 ] <- ctr |].
        Defined.

        Definition encryptIterator : iterator progvar (Block littleE) :=
          {| setup    := LoadCounter;
             process  := Encrypt;
             finalise := StoreCounter
          |}.

        Definition cSPRGIterator : iterator progvar (Block hostE) :=
          {| setup    := LoadCounter;
             process  := CSPRGStream;
             finalise := StoreCounter
          |}.

      End Locals.

      Definition EncryptIterator := do encryptIterator end.
      Definition HChaCha20 := do hChaCha20 end.
      Definition CSPRGIterator := do cSPRGIterator end.

    End Params.

  End ChaCha20.

End Internal.

Require Import Verse.Target.C.

Inductive name := verse_chacha20_c_portable
                | verse_chacha20csprg_c_portable
                | verse_hchacha20_c_portable.

Definition chacha20_iter : CodeGen.Config.programLine + {Error.TranslationError}.
  Iterator verse_chacha20_c_portable
           (common.Block littleE)
           Internal.EncryptIterator.
Defined.

Definition hchacha20_fun : CodeGen.Config.programLine + {Error.TranslationError}.
  Function verse_hchacha20_c_portable
           Internal.HChaCha20.
Defined.

Definition csprg_iter : CodeGen.Config.programLine + {Error.TranslationError}.
  Iterator verse_chacha20csprg_c_portable
           (common.Block hostE)
           Internal.CSPRGIterator.
Defined.

Require Import Verse.Error.

Definition chacha20  : Compile.programLine := recover chacha20_iter.
Definition hchacha20 : Compile.programLine := recover hchacha20_fun.
Definition csprg     : Compile.programLine := recover csprg_iter.

Definition program   := verseC [chacha20; hchacha20 ; csprg].

Require Import Verse.FFI.Raaz.
Require Import Verse.FFI.Raaz.Target.C.

Definition raazFFI {Name} (name : Name)
  := mkProgram name [ iterator verse_chacha20_c_portable
                               (common.Block littleE)
                               Internal.EncryptIterator;
                      function verse_hchacha20_c_portable
                               Internal.HChaCha20;
                      iterator verse_chacha20csprg_c_portable
                               (common.Block hostE)
                               Internal.CSPRGIterator
                    ].

(*
Require Import Verse.Print.
Require Import Verse.Target.C.Pretty.
Goal to_print raazFFI.
  print.
Abort.

 *)


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import par.
From iris.heap_lang Require Import adequacy proofmode.
From iris_examples.barrier Require Import proof.
From iris.prelude Require Import options.

Definition worker (n : Z) : val :=
  λ: "b" "y", wait "b" ;; !"y" #n.
Definition client : expr :=
  let: "y" := ref #0 in
  let: "b" := newbarrier #() in
  ("y" <- (λ: "z", "z" + #42) ;; signal "b") |||
    (worker 12 "b" "y" ||| worker 17 "b" "y").

Section client.
  Local Set Default Proof Using "Type*".
  Context `{!heapGS Σ, !barrierG Σ, !spawnG Σ}.

  Definition N := nroot .@ "barrier".

  Definition y_inv (q : Qp) (l : loc) : iProp Σ :=
    (∃ f : val, l ↦{# q} f ∗ □ ∀ n : Z, WP f #n {{ v, ⌜v = #(n + 42)⌝ }})%I.

  Lemma y_inv_split q l : y_inv q l -∗ (y_inv (q/2) l ∗ y_inv (q/2) l).
  Proof.
    iDestruct 1 as (f) "[[Hl1 Hl2] #Hf]".
    iSplitL "Hl1"; iExists f; by iSplitL; try iModIntro.
  Qed.

  Lemma worker_safe q (n : Z) (b y : loc) :
    recv N b (y_inv q y) -∗ WP worker n #b #y {{ _, True }}.
  Proof.
    iIntros "Hrecv". wp_lam. wp_let.
    wp_apply (wait_spec with "Hrecv"). iDestruct 1 as (f) "[Hy #Hf]".
    wp_seq. wp_load.
    iApply (wp_wand with "Hf"). by iIntros (v) "_".
  Qed.

  Lemma client_safe : ⊢ WP client {{ _, True }}.
  Proof.
    iIntros ""; rewrite /client. wp_alloc y as "Hy". wp_let.
    wp_apply (newbarrier_spec N (y_inv 1 y) with "[//]").
    iIntros (l) "[Hr Hs]". wp_pures.
    wp_apply (wp_par (λ _, True%I) (λ _, True%I) with "[Hy Hs] [Hr]"); last auto.
    - (* The original thread, the sender. *)
      wp_store. iApply (signal_spec with "[-]"); last by iNext; auto.
      iSplitR "Hy"; first by eauto.
      iExists _; iSplitL; [done|]. iIntros "!#" (n). by wp_pures.
    - (* The two spawned threads, the waiters. *)
      iDestruct (recv_weaken with "[] Hr") as "Hr".
      { iIntros "Hy". by iApply (y_inv_split with "Hy"). }
      iMod (recv_split with "Hr") as "[H1 H2]"; first done.
      wp_smart_apply (wp_par (λ _, True%I) (λ _, True%I) with "[H1] [H2]"); last auto.
      + by iApply worker_safe.
      + by iApply worker_safe.
Qed.
End client.

Section ClosedProofs.

Let Σ : gFunctors := #[ heapΣ ; barrierΣ ; spawnΣ ].

Lemma client_adequate σ : adequate NotStuck client σ (λ _ _, True).
Proof. apply (heap_adequacy Σ)=> ?. iIntros "_". iApply client_safe. Qed.

End ClosedProofs.

Print Assumptions client_adequate.


Require Export Fiat.FiniteSetADTs.WordInterface.
Require Export Bedrock.Memory Bedrock.IL.

Set Implicit Arguments.

Module Export BedrockWordW <: BedrockWordT.
  Definition W := Memory.W.

  Definition wzero := (@Word.natToWord 32 0).
  Definition wplus := (@Word.wplus 32).
  Definition wminus := (@Word.wminus 32).
  Definition weq := @Word.weqb 32.

  Definition wlt := IL.wltb.

  Definition from_nat := @Word.natToWord 32.

  Lemma weq_iff x : forall y, x = y <-> weq x y = true.
  Proof.
    symmetry; apply Word.weqb_true_iff.
  Qed.

  Lemma wlt_irrefl x : wlt x x = false.
  Proof.
    unfold wlt, wltb.
    destruct (Word.wlt_dec x x).
    pose proof (Word.lt_le w); congruence.
    reflexivity.
  Qed.

  Lemma wlt_true_iff :
    forall x y,
      wlt x y = true <-> Word.wlt x y.
  Proof.
    intros.
    unfold wlt, IL.wltb.
    destruct (Word.wlt_dec x y); intuition.
  Qed.

  Lemma wlt_false_iff :
    forall x y,
      wlt x y = false <-> ~ Word.wlt x y.
  Proof.
    intros.
    unfold wlt, IL.wltb.
    destruct (Word.wlt_dec x y); intuition.
  Qed.

  Lemma wlt_trans x : forall y z, wlt x y = true -> wlt y z = true -> wlt x z = true.
  Proof.
    intros.
    rewrite wlt_true_iff in *.
    unfold Word.wlt in *.
    eapply BinNat.N.lt_trans; eauto.
  Qed.

  Lemma wle_antisym x : forall y, wlt x y = false -> wlt y x = false -> x = y.
  Proof.
    intros.
    rewrite wlt_false_iff in *.
    unfold Word.wlt in *.
    rewrite BinNat.N.nlt_ge in *.
    apply Word.wordToN_inj.
    apply BinNat.N.le_antisymm; intuition.
  Qed.

  Lemma wle_asym x : forall y, wlt x y = true -> wlt y x = false.
  Proof.
    intro y; rewrite wlt_true_iff, wlt_false_iff.
    unfold Word.wlt.
    apply BinNat.N.lt_asymm.
  Qed.
End BedrockWordW.


Require Import erasure.

(*Helper theorems for reasoning about the erasure of heaps being rolled back*)
Theorem raw_eraseHeapRBNew : forall H x,
                           raw_heap_lookup x H = Some(sempty SPEC) ->
                           raw_eraseHeap H = raw_eraseHeap (raw_remove H x).
Proof.
  induction H; intros.
  {inv H. }
  {simpl in *. destruct a. destruct (beq_nat x i) eqn:eq.
   {inv H0; auto. }
   {simpl in *. erewrite IHlist; eauto. }
  }
Qed.

Theorem eraseHeapRBNew : forall H x,
                           heap_lookup x H = Some(sempty SPEC) ->
                           eraseHeap H = eraseHeap (Heap.remove H x).
Proof.
  intros. destruct H; simpl in *. apply rawHeapsEq. eapply raw_eraseHeapRBNew; eauto.
Qed.

Theorem raw_eraseHeapRBWrite : forall H x sc TID N,
                      raw_heap_lookup x H = Some(sfull sc nil SPEC TID N) ->
                      raw_eraseHeap H = raw_eraseHeap (raw_replace x (sempty sc) H).
Proof.
  induction H; intros.
  {inv H. }
  {simpl in *. destruct a. destruct (beq_nat x i) eqn:eq.
   {apply beq_nat_true in eq. subst. inv H0. destruct sc; auto. }
   {simpl. erewrite IHlist; eauto. }
  }
Qed.

Theorem eraseHeapRBWrite : forall H x sc TID N,
                      heap_lookup x H = Some(sfull sc nil SPEC TID N) ->
                      eraseHeap H = eraseHeap (replace x (sempty sc) H).
Proof.
  intros. destruct H; simpl in *. apply rawHeapsEq. eapply raw_eraseHeapRBWrite; eauto.
Qed.

Theorem erasePoolApp : forall T1 T2,
                          erasePool(T1++T2) = erasePool T1++erasePool T2.
Proof.
  induction T1; intros.
  {simpl. auto. }
  {simpl. rewrite IHT1. unfold tUnion. unfold Union. rewrite <- app_assoc. auto. }
Qed.

Theorem eraseAdd : forall T t1 t2,
                      eraseThread t1 = eraseThread t2 ->
                      erasePool (tAdd T t1) = erasePool (tAdd T t2).
Proof.
  induction T; intros.
  {simpl. rewrite H. auto. }
  {simpl. repeat rewrite erasePoolApp. simpl. rewrite H. auto. }
Qed.

Theorem eraseAddCouple : forall T t1 t2,
                            erasePool t1 = eraseThread t2 ->
                            erasePool (tUnion T t1) = erasePool (tAdd T t2).
Proof.
  induction T; intros.
  {simpl. rewrite H. unfold tUnion. rewrite union_empty_r. auto. }
  {simpl. unfold tUnion. unfold Union. repeat rewrite erasePoolApp.
   rewrite H. simpl. unfoldTac. rewrite union_empty_r. auto. }
Qed.

Theorem eraseThreadActTerm : forall tid a s1 s2 M M',
              actionTerm a M' ->
              eraseThread(tid,aCons a s1,s2,M) =
              eraseThread(tid, s1,s2,M').
Proof.
  intros. destruct s1; auto.
  {destruct l. simpl. inv H; auto. uCons a0 l. erewrite eraseTwoActs.
   eauto. }
Qed.

Theorem rollbackIdempotent : forall tid stack H T H' T',
                               rollback tid stack H T H' T' ->
                               erasePool T = erasePool T' /\
                               eraseHeap H = eraseHeap H'.
Proof.
  intros. induction H0; subst.
  {split; auto. }
  {invertHyp. split. rewrite <- H. apply eraseAdd. erewrite eraseThreadActTerm.
   eauto. constructor. rewrite <- H0. erewrite eraseHeapDependentRead; eauto. }
  {invertHyp. split. rewrite <- H. apply eraseAddCouple. unfoldTac. rewrite couple_swap.
   erewrite <- eraseThreadActTerm; simpl; eauto. rewrite app_nil_r. auto. constructor.
   auto. }
  {invertHyp. split. rewrite <- H. apply eraseAdd. erewrite eraseThreadActTerm.
   eauto. constructor. rewrite <- H1. erewrite eraseHeapRBWrite; eauto. }
  {invertHyp. rewrite <- H. split. apply eraseAdd. erewrite eraseThreadActTerm.
   eauto. constructor. rewrite <- H2. erewrite eraseHeapRBNew; eauto. }
  {invertHyp. split. rewrite <- H. apply eraseAddCouple.
   erewrite <- eraseThreadActTerm. simpl. rewrite app_nil_r; eauto. constructor.
   auto. }
Qed.


From st.STLCmuVS Require Import lang typing tactics.
From st.STLCmu Require Import types.
From st.backtranslations.un_syn Require Import universe.base.
From st.STLCmuVS.lib Require Import omega.

Opaque Ω.

Local Ltac simplify_custom := (repeat rewrite /= to_of_val; simplify_option_eq; repeat rewrite Ω_Closed).

Lemma eval_same_tc tc v : rtc STLCmuVS_step (CaseTC tc (Unfold (FoldV (InjVTC tc v)))) v.
Proof. destruct tc; by repeat (eapply rtc_l; first auto_STLCmuVS_step; first simplify_custom). Qed.

Lemma eval_diff_tc tc1 tc2 v : tc1 ≠ tc2 → rtc STLCmuVS_step (CaseTC tc1 (Unfold (FoldV (InjVTC tc2 v)))) Ω.
Proof. destruct tc1; destruct tc2; intro neq; (try by contradiction); by repeat ((by eapply rtc_refl) || eapply rtc_l; first auto_STLCmuVS_step; first simplify_custom). Qed.


(* (c) Copyright Christian Doczkal and Joachim Bard                       *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Classical_Pred_Type.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base.
Require Import PDL_def.

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

Arguments subsep {T X P}.

Implicit Types (S cls X Y : {fset clause}) (C D : clause).

(** * Demos *)

Definition rtrans a C D := (R a C `<=` D) && (Rc a D `<=` C).

Fixpoint reach_demo cls p : rel clause :=
  match p with
  | pV a => rtrans a
  | pSeq p0 p1 => (fun C D => [some C' in cls, reach_demo cls p0 C C' && reach_demo cls p1 C' D])
  | pCh p0 p1 => (fun C D => reach_demo cls p0 C D || reach_demo cls p1 C D)
  | pStar p => (fun C D => connect_in cls (reach_demo cls p) C D)
  | pTest s => (fun C D => (C == D) && (s^+ \in C))
  | pConv p => (fun C D => reach_demo cls p D C)
  end.

Definition D0 cls := forall C, C \in cls -> hintikka C.
Definition D1 cls := forall C, C \in cls -> forall p s, [p]s^- \in C -> [some D in cls, reach_demo cls p C D &&  (s^- \in D)].

(** A demo consists of a finite set of Hintikka clauses that satisfy the demo condition. *)

Record demo := Demo {
  cls :> {fset clause} ;
  demoD0 : D0 cls ;
  demoD1 : D1 cls }.

Arguments demoD1 [d C] _ [p s] _.

Canonical demo_predType := PredType (fun (S : demo) (C : clause) => nosimpl C \in cls S).

Lemma LCF (S : demo) C : C \in S -> ((fF^+ \in C) = false) * (forall p, (fV p^+ \in C) && (fV p^- \in C) = false).
Proof.
  move/demoD0. case/andP => /andP [/negbTE -> /allP H] _. split => // x.
  case inC: (fV x^+ \in C) => //=. apply: negbTE. apply: H _ inC.
Qed.

(** ** Demo Theorem *)

Section ModelExistience.
  Variables (S : demo).
  Hypothesis cnf_S : (forall s C, s \in C -> C \in S -> is_cnf (drop_sign s)).

  Definition Mtype := seq_sub S.
  Definition Mtrans a : rel Mtype := @restrict _ S (rtrans a).
  Definition Mlabel (x: var) (C : Mtype) := fV x^+ \in val C.

  Definition model_of := FModel Mtrans Mlabel.

  Implicit Types (c d e : model_of).

  Unset Printing Records.

  Lemma model_of_cnf c s : s \in val c -> is_cnf (drop_sign s).
  Proof. move => A. exact: cnf_S (valP c). Qed.

  Lemma model_of_dc c s : s \in val c -> hintikka' s (val c).
  Proof. case/demoD0/andP : (valP c) => _ /allP. apply. Qed.

  (* Lemma 4.3 *)
  Lemma model_reach_pos p s c d :
    (forall t e, sizef t < sizep p -> t^- \in val e -> ~ eval t e) ->
    [p]s^+ \in val c -> reach p c d -> s^+ \in val d.
  Proof.
    elim: p s c d => [a|p0 IH0 p1 IH1|p0 IH0 p1 IH1|p IHp|t|p IHp] s c d /= Ht.
    - rewrite /= /Mtrans /restrict /= /rtrans => A /andP[] /subP B _. apply: B. by rewrite RE.
    - move/model_of_dc => /= /andP[A B] [].
      + apply: IH0 => // t e H. apply: Ht. by somega.
      + apply: IH1 => // t e H. apply: Ht. by somega.
    - move/model_of_dc => /= A [e E1 E2].
      (apply: IH1 E2; last apply: IH0 E1 => //) => t e' ?; apply Ht; by somega.
    - move => /= A B. elim: B A => {c d} [c|c e d A _ IH B]; first by case/model_of_dc/andP.
      apply: IH. case/model_of_dc/andP : B => _ ?. apply: IHp A => //.
      move => t {e} - e A. apply: Ht. by somega.
    - case/model_of_dc/orP; last by move => ? [->].
      move => A [->] B. exfalso. apply: Ht A B. by somega.
    - move => A. case: p {IHp Ht} A (model_of_cnf A) => //= a.
      rewrite /= /Mtrans /restrict /= /rtrans => A _ /andP[_] /subP B.
      apply: B. by rewrite RcE.
  Qed.

  (* Lemma 7.4 *)
  Lemma demo2reach p c d :
    (forall t e, sizef t < sizep p -> t^+ \in val e -> eval t e) ->
    reach_demo S p (val c) (val d) -> reach p c d.
  Proof.
    elim : p c d => [a|p0 IH0 p1 IH1|p0 IH0 p1 IH1|p IHp|s|p IHp] c d //= Ht.
    - move/orP => [H|H];[left; apply: IH0|right;apply: IH1] => // t e ?; apply Ht; by somega.
    - move/hasP => [C' inS /andP [L R]]. exists (SeqSub C' inS).
      + apply IH0 => // t e ?. by apply: Ht; somega.
      + apply IH1 => // t e ?. by apply: Ht; somega.
    - case/connect_inP => cs. elim: cs c d => /= [|e cd IH] c d.
      + case => _ _ /eqP. rewrite -[_ d == _ c]/(d == c) => /eqP->. by constructor.
      + case => /and3P[A B C] /andP[D E] F. apply: (StarL (z := SeqSub e B)).
        * apply: IHp => // t e' E'. apply: Ht; somega.
        * apply IH. by rewrite /= B C E F.
    - rewrite -[_ c == _ d]/(c == d) => /andP[/eqP-> A]. split => //. by apply: Ht A; somega.
    - apply: IHp => t e ?. by apply: Ht; somega.
  Qed.

  Ltac discharge_with tac := case/(_ _)/Wrap; first by tac.

  (* Theorem 4.6 (Demo Theorem) *)
  Theorem demo_eval s b c :  (s, b) \in val c -> eval (interp (s, b)) c.
  Proof with discharge_with somega.
    move: s b c. apply: (nat_size_ind (f := sizef)) => s IH b.
    case: s b IH => [|x|s t|p s] [|] IH c;
      try by rewrite /= ?(LCF (ssvalP c)); auto.
    - move => /= nx. rewrite /Mlabel. case: (LCF (ssvalP c)) => /= _ H px. move: (H x).
        by rewrite px nx.
    - case/hint_imp_pos ; first by case: c => C; exact: demoD0.
      move/IH => //=... tauto. move/IH => /=... by auto.
    - case/hint_imp_neg; first by case: c => C; exact: demoD0.
      move/IH => /=... move => Hs /IH => /=... by auto.
    - move => H d cRd. apply: (IH s _ true) => /=; first by somega.
      apply: model_reach_pos cRd => // t e A. apply: IH => //=. by somega.
    - move => inC /=. apply: ex_not_not_all.
      have /hasP CD: [some D in S , reach_demo S p (val c) D && (s^- \in D)]
        by apply: (demoD1 (ssvalP c)).
      case: CD => D DinS /andP [cRD inD]. exists (SeqSub D DinS).
      case/(_ _)/Wrap.
      + apply: demo2reach => // t e A. apply IH => //; by somega.
      + rewrite -/(not _). apply: (IH s _ false) => //=. by somega.
  Qed.

End ModelExistience.

(** ** Pruning *)

Section Pruning.

  Variable (F: {fset form}).
  Hypothesis sfc_F : sf_closed F.
  Definition PU := powerset (flipcl F).
  Definition S0 := [fset C in PU | hintikka C && maximal F C].

  Definition pcond C S := ~~ [all u in C, if u is [p]s^- then
    [some D in S, reach_demo S p C D && (s^- \in D)] else true].

  (* Lemma 5.2 *)
  Lemma prune_D0 : D0 (prune pcond S0).
  Proof.
    move => C. move/(subP (prune_sub _ _)). rewrite inE. by case/and3P.
  Qed.

  Lemma prune_D1 : D1 (prune pcond S0).
  Proof.
    move => C /pruneE. rewrite negbK. move/allP => H p s Hs. exact: (H ([p]s^-) Hs).
  Qed.

  Definition DD := Demo prune_D0 prune_D1.

  (** ** Pruning Refutations *)

  Definition supp S (C: clause) := [some D in S, C `<=` D].

  Local Notation "S |> C" := (supp S C) (at level 30, format "S  |>  C").

  Definition coref (ref : clause -> Prop) S :=
    forall C, C \in S0 `\` S -> ref C.

  Inductive pref : clause -> Prop :=
  | P1 S C : coref pref S -> C \in PU -> ~~ S |> C -> pref C
  | P2 S C p s : S `<=` S0 -> coref pref S -> C \in S
                 -> [p]s^- \in C -> ~~[some D in S, reach_demo S p C D && (s^- \in D)] -> pref C.

  Lemma corefD1 S C : pref C -> coref pref S -> coref pref (S `\` [fset C]).
  Proof.
    move => rC coS D. rewrite !in_fsetD negb_and andb_orr -in_fsetD negbK in_fset1.
    case/orP; first exact: coS. by case/andP => [_ /eqP ->].
  Qed.

  (* Lemma 5.3 - corefutability of the pruning demo *)
  Lemma coref_DD : coref pref DD.
  Proof.
    apply: prune_myind => [C|C S]; first by rewrite inE andbN.
    case/allPn. case. case => // p s. case => // inC H inS corS sub.
    apply: corefD1 => //. exact: (P2 sub).
  Qed.

  Lemma DD_refute C : C \in PU -> ~~ DD |> C -> pref C.
  Proof. move => inU. apply: P1 _ inU => //. exact: coref_DD. Qed.

End Pruning.

(** ** Pruning Completeness *)

Definition satT (M: cmodel) C := { w: M | forall s, s \in C -> eval (interp s) w}.

Notation "S |> C" := (supp S C) (at level 30, format "S  |>  C").

(* Theorem 5.4 (Pruning Completeness) *)
Theorem pruning_completeness F (sfc_F : sf_closed F) (C: clause) :
  (forall s E, s \in E -> E \in PU F -> is_cnf (drop_sign s)) ->
  C \in PU F -> pref F C + { M: fmodel & satT M C & #|{: M}| <= 2 ^ (2 * size F)}.
Proof.
  move => cnf_S inPU. case: (boolP ((DD F) |> C)) => H; [right|left; exact: DD_refute].
  exists (model_of (DD F)).
  - case/hasS : H => D D1 /subP D2. exists (SeqSub _ D1) => s inC.
    move: inPU. move/powersetP => sub. case: s inC => s b inC.
    apply: demo_eval => //=; last exact: D2.
    move => t E inE H. apply: cnf_S inE _. move: H. apply/subP.
    apply: sub_trans (prune_sub _ _) _. exact: subsep.
  - rewrite card_seq_sub ?funiq //.
    apply: leq_trans; last by apply: (leq_pexp2l _ (size_flipcl F)).
    rewrite -powerset_size subset_size /DD /S0 //=.
    apply: sub_trans; [exact: prune_sub | exact: subsep].
Qed.


Require Export Common Computation ADTSig ADT.
Require Import Ensembles.

Generalizable All Variables.
Set Implicit Arguments.

(** Definition of a fully computational ADT *)

(** Type of a computational constructor. *)
Definition computationalConstructorType (rep dom : Type)
  :=  dom (* Initialization arguments *)
     -> rep (* Freshly constructed model *).

(** Type of a method. *)
Definition computationalMethodType (rep dom cod : Type)
  := rep    (* Initial model *)
     -> dom (* Method arguments *)
     -> (rep * cod) (* Final model and return value. *).

(** Interface of a computational ADT *)
Record cADT (Sig : ADTSig) :=
  {
    (** The representation type of the ADT **)
    cRep : Type;

    (** Constructor implementations *)
    cConstructors :
      forall idx : ConstructorIndex Sig,
        computationalConstructorType cRep (ConstructorDom Sig idx);

    (** Method implementations *)
    cMethods :
      forall idx : MethodIndex Sig,
        computationalMethodType cRep (fst (MethodDomCod Sig idx))
                                (snd (MethodDomCod Sig idx))
  }.

Definition is_computationalADT (Sig : ADTSig) (A : ADT Sig) :=
  (forall (idx : ConstructorIndex Sig) i,
     is_computational (Constructors A idx i))
  /\ (forall (idx : MethodIndex Sig) i r,
        is_computational (Methods A idx i r)).

  Definition CallComputationalMethod
             (Sig : ADTSig)
             (A : ADT Sig)
             (CompA : is_computationalADT A)
             (idx : MethodIndex Sig)
             (r : Rep A)
             (i : fst (MethodDomCod Sig idx))
             : Rep A * snd (MethodDomCod Sig idx) :=
    is_computational_val (proj2 CompA idx r i).

  Definition CallComputationalConstructor
             (Sig : ADTSig)
             (A : ADT Sig)
             (CompA : is_computationalADT A)
             (idx : ConstructorIndex Sig)
             (i : ConstructorDom Sig idx)
             : Rep A :=
    is_computational_val (proj1 CompA idx i).


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Preservation.

Lemma canonical_form_abs : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_arrow U1 U2) ->
  exists V, exists e1, e = exp_abs V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;try solve [inversion H|inversion H1|inversion H2]...
  -
    exists V.
    exists e1...
  -
    inversion H0;subst. inversion H2;subst. inversion H3. inversion H2.
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_tabs : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_all U1 U2) ->
  exists V, exists e1, e = exp_tabs V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;try solve [inversion H|inversion H1|inversion H2]...
  -
    exists V.
    exists e1...
  -
    inversion H0;subst. inversion H2;subst. inversion H3. inversion H2.
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_tabs_lb : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_all_lb U1 U2) ->
  exists V, exists e1, e = exp_tabs_lb V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;try solve [inversion H|inversion H1|inversion H2]...
  -
    exists V.
    exists e1...
  -
    inversion H0;subst. inversion H2;subst. inversion H3. inversion H2.
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_fold : forall e U S,
  value e ->
  typing empty e S ->
  sub empty S (typ_mu U) ->
  exists V, exists e1, exists T,
   (sub empty (typ_mu V) (typ_mu U) /\ value e1 /\ e = exp_fold T e1 /\
   WF empty T).
Proof with auto.
  intros.
  generalize dependent U.
  dependent induction H0;intros;
  try solve [inversion H|inversion H1|inversion H2
  |inversion H3]...
  -
    dependent destruction H.
    exists A...
    exists e...
    exists T... repeat split...
    apply sub_transitivity with (Q:=T)... get_well_form...
  -
    apply IHtyping with (U:=U)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma value_expr: forall e,
    value e -> expr e.
Proof with auto.
  intros.
  induction H...
Qed.

Lemma progress : forall e T,
  typing empty e T ->
  value e \/ exists e', step e e'.
Proof with eauto.
  intros.
  dependent induction H...
  -
    inversion H0...
  - (* abs *)
    left.
    constructor.
    apply expr_abs with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* app *)
    right.
    destruct IHtyping1;destruct IHtyping2...
    +
      apply canonical_form_abs with (S:=typ_arrow T1 T2) (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_ee x0 e2).
      subst.
      apply step_beta...
      apply value_expr...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_app e1 x).
      apply step_app2...
    +
      destruct_hypos.
      exists (exp_app x e2).
      apply step_app1...
      apply value_expr...
    +
      destruct_hypos.
      exists (exp_app x0 e2).
      apply step_app1...
      apply typing_regular in H0.
      destruct_hypos...
  - (* tabs *)
    left.
    constructor.
    apply expr_tabs with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* tabs_lb *)
    left.
    constructor.
    apply expr_tabs_lb with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* tapp *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_tabs with (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_te x0 T).
      subst.
      apply step_tabs...
      apply value_expr...
      get_type...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_tapp x T).
      apply step_tapp...
      get_type...
  - (* tapp_lb *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_tabs_lb with (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_te x0 T).
      subst.
      apply step_tabs_lb...
      apply value_expr...
      get_type...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_tapp x T).
      apply step_tapp...
      get_type...
  - (* fold *)
    assert (empty ~= empty) by auto.
    apply IHtyping in H1.
    destruct H1.
    left.
    constructor...
    { get_well_form. apply WF_type in H3... }
    right.
    destruct H1.
    exists (exp_fold T x).
    constructor...
    { get_well_form. apply WF_type in H3... }

  - (* unfold *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_fold with (e:=e) (S:=A) (U:=T) in H0...
      destruct_hypos.
      exists x0...
      rewrite H3.
      get_well_form...
      apply step_fld...
      apply WF_type in H4...
      apply typing_regular in H...
      destruct_hypos...
      apply WF_type in H8...
    +
      destruct_hypos.
      exists (exp_unfold A x).
      (* apply canonical_form_fold with (e:=e) (S:=A) (U:=T) in H0... *)
      apply step_unfold...
      apply typing_regular in H...
      destruct_hypos.
      apply WF_type in H3...
Qed.


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import ZArith.
Require Import Bool.
Require Import List.
Require Import Permutation.
Require Import Psatz.

Require Import Misc.
Require Import Linalg.
Require Import Canonizer.
Require Import Projection.
Require Import TopoSort.
Require Import PolyTest.
Require Import ImpureAlarmConfig.

(** * Polyhedral intersection *)

Definition poly_inter_pure (p1 p2 : polyhedron) : polyhedron := p1 ++ p2.
Lemma poly_inter_pure_def :
  forall p pol1 pol2, in_poly p (poly_inter_pure pol1 pol2) = in_poly p pol1 && in_poly p pol2.
Proof.
  intros p pol1 pol2; unfold poly_inter_pure, in_poly.
  rewrite forallb_app; reflexivity.
Qed.

Definition poly_inter p1 p2 :=
  Canon.canonize (poly_inter_pure p1 p2).
Lemma poly_inter_def :
  forall p pol1 pol2, WHEN pol <- poly_inter pol1 pol2 THEN in_poly p pol = in_poly p (poly_inter_pure pol1 pol2).
Proof.
  intros p pol1 pol2 pol Hinter.
  apply Canon.canonize_correct in Hinter.
  specialize (Hinter 1 p). rewrite !expand_poly_1 in Hinter.
  apply Hinter; lia.
Qed.

Lemma poly_inter_pure_no_new_var :
  forall pol1 pol2 k, absent_var pol1 k -> absent_var pol2 k -> absent_var (poly_inter_pure pol1 pol2) k.
Proof.
  intros pol1 pol2 k H1 H2 c Hc.
  rewrite in_app_iff in Hc; destruct Hc; auto.
Qed.

Lemma poly_inter_no_new_var :
  forall pol1 pol2 k, absent_var pol1 k -> absent_var pol2 k ->
                 WHEN pol <- poly_inter pol1 pol2 THEN absent_var pol k.
Proof.
  intros pol1 pol2 k H1 H2 pol Hpol.
  apply Canon.canonize_no_new_var with (k := k) in Hpol; [auto|].
  apply poly_inter_pure_no_new_var; auto.
Qed.

Lemma poly_inter_nrl :
  forall pol1 pol2 n, (poly_nrl pol1 <= n)%nat -> (poly_nrl pol2 <= n)%nat ->
                 WHEN pol <- poly_inter pol1 pol2 THEN (poly_nrl pol <= n)%nat.
Proof.
  intros pol1 pol2 n H1 H2 pol Hpol.
  rewrite has_var_poly_nrl in *.
  intros k Hnk; eapply poly_inter_no_new_var; [| |exact Hpol]; eauto.
Qed.

(** * Polyhedral difference *)
Fixpoint poly_difference p1 p2 :=
  match p2 with
  | nil => pure nil
  | c :: p2 =>
    BIND pl1 <- VplCanonizerZ.canonize (neg_constraint c :: p1) -;
    BIND diff <- poly_difference (c :: p1) p2 -;
    BIND b <- isBottom pl1 -;
    pure (if b then diff else (pl1 :: diff))
  end.

Lemma poly_difference_def :
  forall p2 p1 v, WHEN pl <- poly_difference p1 p2 THEN
                  existsb (in_poly v) pl = in_poly v p1 && negb (in_poly v p2).
Proof.
  induction p2.
  - intros p1 v pl Hpl. apply mayReturn_pure in Hpl; rewrite <- Hpl. simpl. destruct in_poly; auto.
  - intros p1 v pl Hpl. simpl in *.
    bind_imp_destruct Hpl pl1 Hpl1; bind_imp_destruct Hpl diff Hdiff; bind_imp_destruct Hpl empty Hempty; apply mayReturn_pure in Hpl; rewrite <- Hpl.
    transitivity (existsb (in_poly v) (pl1 :: diff)).
    { destruct empty; simpl; [|reflexivity]. eapply isBottom_correct_1 in Hempty; simpl in *; rewrite Hempty; reflexivity. }
    simpl. rewrite IHp2; [|eauto].
    rewrite VplCanonizerZ.canonize_correct; [|eauto]. simpl.
    rewrite neg_constraint_correct; unfold in_poly; simpl.
    destruct (satisfies_constraint v a); simpl.
    + reflexivity.
    + destruct forallb; reflexivity.
Qed.

Lemma poly_difference_no_new_var :
  forall p2 p1 k, absent_var p1 k -> absent_var p2 k ->
             WHEN pl <- poly_difference p1 p2 THEN forall p, In p pl -> absent_var p k.
Proof.
  induction p2.
  - intros p1 k Hp1 Hp2 pl Hpl p Hp. apply mayReturn_pure in Hpl; rewrite <- Hpl in *. simpl in *. tauto.
  - intros p1 k Hp1 Hp2 pl Hpl p Hp. simpl in *.
    bind_imp_destruct Hpl pl1 Hpl1; bind_imp_destruct Hpl diff Hdiff; bind_imp_destruct Hpl empty Hempty;
      apply mayReturn_pure in Hpl; rewrite <- Hpl in *.
    assert (Hin : In p (pl1 :: diff)) by (destruct empty; simpl in *; tauto).
    simpl in *. destruct Hin; [|eapply (IHp2 (a :: p1) k); eauto using absent_var_cons, absent_var_head, absent_var_tail].
    rewrite H in *.
    unfold absent_var. eapply VplCanonizerZ.canonize_no_new_var; [|eauto].
    apply absent_var_cons; [|auto].
    apply absent_var_head in Hp2; unfold neg_constraint; simpl; rewrite mult_nth.
    lia.
Qed.

Lemma poly_difference_nrl :
  forall p1 p2 n, (poly_nrl p1 <= n)%nat -> (poly_nrl p2 <= n)%nat ->
             WHEN pl <- poly_difference p1 p2 THEN (forall p, In p pl -> (poly_nrl p <= n)%nat).
Proof.
  intros p1 p2 n Hp1 Hp2 pl Hpl p Hp.
  rewrite has_var_poly_nrl in *.
  intros k Hk; eapply poly_difference_no_new_var; [| |exact Hpl|]; eauto.
Qed.

Lemma poly_difference_disjoint :
  forall p2 p1, WHEN pols <- poly_difference p1 p2 THEN all_disjoint pols.
Proof.
  induction p2.
  - intros p1 pols Hpols; simpl in *. apply mayReturn_pure in Hpols; rewrite <- Hpols.
    apply all_disjoint_nil.
  - intros p1 pols Hpols. simpl in *.
    bind_imp_destruct Hpols pl1 Hpl1; bind_imp_destruct Hpols diff Hdiff; bind_imp_destruct Hpols empty Hempty; apply mayReturn_pure in Hpols; rewrite <- Hpols.
    enough (all_disjoint (pl1 :: diff)) by (destruct empty; [eapply all_disjoint_cons_rev; eauto|auto]).
    apply all_disjoint_cons; [eapply IHp2; eauto|].
    intros p pol1 Hpolin Hinpl Hinpol1.
    rewrite VplCanonizerZ.canonize_correct in Hinpl; [|eauto].
    eapply poly_difference_def with (v := p) in Hdiff.
    unfold in_poly in *; simpl in *.
    rewrite neg_constraint_correct in Hinpl.
    destruct (satisfies_constraint p a) eqn:Hsat; simpl in *.
    + congruence.
    + rewrite existsb_forall in Hdiff; rewrite Hdiff in Hinpol1; [congruence|auto].
Qed.

(** * Separating a list of polyhedra *)
Definition separate_polys pol1 pol2 :=
  BIND inter <- poly_inter pol1 pol2 -;
  BIND empty <- isBottom inter -;
  if empty then pure (nil, pol2 :: nil) else
  BIND diff <- poly_difference pol2 pol1 -;
  pure (inter :: nil, diff).

Lemma separate_polys_nrl :
  forall pol1 pol2 n, (poly_nrl pol1 <= n)%nat -> (poly_nrl pol2 <= n)%nat ->
                 WHEN sep <- separate_polys pol1 pol2 THEN
                      forall pol, In pol (fst sep ++ snd sep) -> (poly_nrl pol <= n)%nat.
Proof.
  intros pol1 pol2 n H1 H2 sep Hsep pol Hpol.
  unfold separate_polys in Hsep.
  bind_imp_destruct Hsep inter Hinter; bind_imp_destruct Hsep empty Hempty. destruct empty.
  - apply mayReturn_pure in Hsep; rewrite <- Hsep in *; simpl in *.
    destruct Hpol as [<- | ?]; tauto.
  - bind_imp_destruct Hsep diff Hdiff; apply mayReturn_pure in Hsep; rewrite <- Hsep in *.
    simpl in *.
    destruct Hpol as [<- | Hpol]; [|eapply poly_difference_nrl; [| |exact Hdiff|]; eauto].
    eapply poly_inter_nrl in Hinter; eauto.
Qed.

Lemma separate_polys_cover :
  forall pol1 pol2, WHEN sep <- separate_polys pol1 pol2 THEN
                    forall p, in_poly p pol2 = true <-> exists pol, In pol (fst sep ++ snd sep) /\ in_poly p pol = true.
Proof.
  intros pol1 pol2 sep Hsep p.
  unfold separate_polys in Hsep.
  bind_imp_destruct Hsep inter Hinter; bind_imp_destruct Hsep empty Hempty. destruct empty.
  - apply mayReturn_pure in Hsep; rewrite <- Hsep in *; simpl in *.
    split; [intros H; exists pol2; auto|intros [pol [H1 H2]]; intuition congruence].
  - bind_imp_destruct Hsep diff Hdiff; apply mayReturn_pure in Hsep; rewrite <- Hsep in *.
    simpl in *.
    apply poly_difference_def with (v := p) in Hdiff.
    apply poly_inter_def with (p := p) in Hinter; rewrite poly_inter_pure_def in Hinter.
    destruct (in_poly p pol1); simpl in *; split.
    + intros H; exists inter; intuition congruence.
    + intros [pol [[H1 | H1] H2]]; [congruence|]. rewrite andb_false_r, existsb_forall in Hdiff.
      specialize (Hdiff pol H1); congruence.
    + intros H; rewrite H, existsb_exists in Hdiff. destruct Hdiff as [pol [H1 H2]]; eauto.
    + intros [pol [[H1 | H1] H2]]; [congruence|]. rewrite andb_true_r in Hdiff; rewrite <- Hdiff, existsb_exists.
      eauto.
Qed.

Lemma separate_polys_separate :
  forall pol1 pol2, WHEN sep <- separate_polys pol1 pol2 THEN
                    forall p pol, In pol (snd sep) -> in_poly p pol = true -> in_poly p pol1 = false.
Proof.
  intros pol1 pol2 sep Hsep p pol Hpolin Hinpol.
  unfold separate_polys in Hsep.
  bind_imp_destruct Hsep inter Hinter; bind_imp_destruct Hsep empty Hempty. destruct empty.
  - apply mayReturn_pure in Hsep; rewrite <- Hsep in *; simpl in *.
    destruct Hpolin as [<- | ?]; [|tauto].
    apply isBottom_correct_1 in Hempty; simpl in *. specialize (Hempty p).
    rewrite poly_inter_def in Hempty; [|eauto]. rewrite poly_inter_pure_def in Hempty.
    destruct (in_poly p pol1); simpl in *; congruence.
  - bind_imp_destruct Hsep diff Hdiff; apply mayReturn_pure in Hsep; rewrite <- Hsep in *.
    simpl in *.
    apply poly_difference_def with (v := p) in Hdiff.
    apply not_true_is_false; intros H. rewrite H, andb_false_r, existsb_forall in Hdiff.
    specialize (Hdiff pol Hpolin); congruence.
Qed.

Lemma separate_polys_disjoint :
  forall pol1 pol2, WHEN sep <- separate_polys pol1 pol2 THEN all_disjoint (fst sep ++ snd sep).
Proof.
  intros pol1 pol2 sep Hsep.
  unfold separate_polys in Hsep.
  bind_imp_destruct Hsep inter Hinter; bind_imp_destruct Hsep empty Hempty. destruct empty.
  - apply mayReturn_pure in Hsep; rewrite <- Hsep in *; simpl in *.
    apply all_disjoint_cons; [apply all_disjoint_nil|]. intros; simpl in *; auto.
  - bind_imp_destruct Hsep diff Hdiff; apply mayReturn_pure in Hsep; rewrite <- Hsep in *.
    apply all_disjoint_app.
    + simpl. apply all_disjoint_cons; [apply all_disjoint_nil|].
      intros; simpl in *; auto.
    + simpl. eapply poly_difference_disjoint; eauto.
    + intros p p1 p2 H1 H2 Hp1 Hp2; simpl in *. destruct H1 as [H1 | H1]; [|auto].
      apply poly_difference_def with (v := p) in Hdiff.
      apply poly_inter_def with (p := p) in Hinter; rewrite poly_inter_pure_def, H1 in Hinter.
      rewrite Hinter in Hp1; reflect. destruct Hp1 as [Hpol1 Hpol2]; rewrite Hpol1, andb_false_r in Hdiff.
      rewrite existsb_forall in Hdiff; specialize (Hdiff p2 H2). congruence.
Qed.

Fixpoint split_polys_rec (l : list polyhedron) (n : nat) : imp (list (polyhedron * list nat)) :=
  match l with
  | nil => pure ((nil, nil) :: nil)
  | p :: l =>
    BIND spl <- split_polys_rec l (S n) -;
    BIND spl1 <- mapM (fun '(pol, pl) =>
         BIND sep <- separate_polys p pol -;
         pure (map (fun pp => (pp, n :: pl)) (fst sep) ++ map (fun pp => (pp, pl)) (snd sep))
    ) spl -;
    pure (flatten spl1)
  end.

Lemma split_polys_rec_index_correct :
  forall pols n, WHEN out <- split_polys_rec pols n THEN forall polpl i, In polpl out -> In i (snd polpl) -> (n <= i < n + length pols)%nat.
Proof.
  induction pols.
  - intros n out Hout ppl i Hin Hiin.
    simpl in *. apply mayReturn_pure in Hout. rewrite <- Hout in Hin.
    simpl in Hin; destruct Hin as [Hin | Hin]; [|tauto]. rewrite <- Hin in Hiin; simpl in Hiin; tauto.
  - intros n out Hout ppl i Hin Hiin.
    simpl in *.
    bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout spl1 Hspl1; apply mayReturn_pure in Hout; rewrite <- Hout in *.
    rewrite flatten_In in Hin. destruct Hin as [u [Hppl Hu]].
    eapply mapM_in_iff in Hu; [|eauto].
    destruct Hu as [[pol pl] [Hu Hpolpl]].
    bind_imp_destruct Hu sep Hsep. apply mayReturn_pure in Hu; rewrite <- Hu in *.
    simpl in Hppl. rewrite in_app_iff, !in_map_iff in Hppl.
    specialize (IHpols _ _ Hspl (pol, pl)); simpl in IHpols.
    destruct Hppl as [[? [Heq _]] | [? [Heq _]]]; rewrite <- Heq in Hiin; simpl in Hiin; [destruct Hiin as [Hiin | Hiin]; [lia|]|];
      specialize (IHpols i Hpolpl Hiin); lia.
Qed.

Lemma split_polys_rec_index_NoDup :
  forall pols n, WHEN out <- split_polys_rec pols n THEN forall polpl, In polpl out -> NoDup (snd polpl).
Proof.
  induction pols.
  - intros n out Hout ppl Hin.
    simpl in *. apply mayReturn_pure in Hout. rewrite <- Hout in Hin.
    simpl in Hin; destruct Hin as [Hin | Hin]; [|tauto]. rewrite <- Hin; constructor.
  - intros n out Hout ppl Hin.
    simpl in *.
    bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout spl1 Hspl1; apply mayReturn_pure in Hout; rewrite <- Hout in *.
    rewrite flatten_In in Hin. destruct Hin as [u [Hppl Hu]].
    eapply mapM_in_iff in Hu; [|eauto].
    destruct Hu as [[pol pl] [Hu Hpolpl]].
    bind_imp_destruct Hu sep Hsep. apply mayReturn_pure in Hu; rewrite <- Hu in *.
    simpl in Hppl. rewrite in_app_iff, !in_map_iff in Hppl.
    specialize (IHpols _ _ Hspl (pol, pl)); simpl in IHpols.
    destruct Hppl as [[? [Heq _]] | [? [Heq _]]]; rewrite <- Heq; simpl; [|intuition].
    constructor; [|intuition].
    intros H; eapply (split_polys_rec_index_correct _ _ _ Hspl _ _ Hpolpl) in H.
    lia.
Qed.

Lemma split_polys_rec_nrl :
  forall pols n, WHEN out <- split_polys_rec pols n THEN
                 forall k, (forall pol, In pol pols -> (poly_nrl pol <= k)%nat) -> (forall ppl, In ppl out -> (poly_nrl (fst ppl) <= k)%nat).
Proof.
  induction pols.
  - intros n out Hout k Hpols ppl Hin.
    simpl in *. apply mayReturn_pure in Hout. rewrite <- Hout in Hin.
    simpl in Hin; destruct Hin as [Hin | Hin]; [|tauto]. rewrite <- Hin; unfold poly_nrl; simpl; lia.
  - intros n out Hout k Hpols ppl Hin.
    simpl in *.
    bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout spl1 Hspl1; apply mayReturn_pure in Hout; rewrite <- Hout in *.
    rewrite flatten_In in Hin. destruct Hin as [u [Hppl Hu]].
    eapply mapM_in_iff in Hu; [|eauto].
    destruct Hu as [[pol pl] [Hu Hpolpl]].
    bind_imp_destruct Hu sep Hsep. apply mayReturn_pure in Hu; rewrite <- Hu in *.
    eapply separate_polys_nrl in Hsep; [apply Hsep|apply Hpols; auto|eapply (IHpols _ _ Hspl _ _ (pol, pl)); eauto]. Unshelve. 2:eauto.
    apply in_map with (f := fst) in Hppl; simpl in Hppl; rewrite map_app, !map_map, !map_id in Hppl.
    exact Hppl.
Qed.

Lemma split_polys_rec_disjoint :
  forall pols n, WHEN out <- split_polys_rec pols n THEN all_disjoint (map fst out).
Proof.
    induction pols.
  - intros n out Hout p k1 k2 ppl1 ppl2 Hk1 Hk2 Hppl1 Hppl2.
    simpl in *. apply mayReturn_pure in Hout. rewrite <- Hout in *.
    destruct k1 as [|[|k1]]; destruct k2 as [|[|k2]]; simpl in *; congruence.
  - intros n out Hout.
    simpl in *.
    bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout spl1 Hspl1; apply mayReturn_pure in Hout; rewrite <- Hout in *.
    rewrite flatten_map. apply all_disjoint_flatten.
    + intros l1 Hl1.
      rewrite in_map_iff in Hl1. destruct Hl1 as [pll [Hpll Hin1]]; rewrite <- Hpll.
      eapply mapM_in_iff in Hin1; [|eauto]. destruct Hin1 as [[pol pl] [H1 H2]].
      bind_imp_destruct H1 sep Hsep; apply mayReturn_pure in H1; rewrite <- H1.
      simpl; rewrite map_app, !map_map, !map_id.
      eapply separate_polys_disjoint; eauto.
    + intros p k1 k2 l1 l2 pol1 pol2 Hk1 Hk2 Hl1 Hl2 Hin1 Hin2.
      rewrite nth_error_map_iff in Hk1, Hk2.
      destruct Hk1 as [pll1 [Hk1 Hll1]]; destruct Hk2 as [pll2 [Hk2 Hll2]]; rewrite Hll1, Hll2 in *.
      eapply mapM_nth_error1 in Hk1; [|exact Hspl1]. destruct Hk1 as [[pp1 pl1] [H1 Hk1]].
      eapply mapM_nth_error1 in Hk2; [|exact Hspl1]. destruct Hk2 as [[pp2 pl2] [H2 Hk2]].
      bind_imp_destruct H1 sep1 Hsep1; bind_imp_destruct H2 sep2 Hsep2.
      apply mayReturn_pure in H1; apply mayReturn_pure in H2. rewrite <- H1 in Hl1; rewrite <- H2 in Hl2.
      simpl in Hl1, Hl2; rewrite map_app, !map_map, !map_id in Hl1, Hl2.
      assert (Ht1 : in_poly p pp1 = true) by (erewrite (separate_polys_cover _ _ _ Hsep1 _); exists pol1; auto).
      assert (Ht2 : in_poly p pp2 = true) by (erewrite (separate_polys_cover _ _ _ Hsep2 _); exists pol2; auto).
      apply map_nth_error with (f := fst) in Hk1; apply map_nth_error with (f := fst) in Hk2.
      specialize (IHpols _ _ Hspl _ _ _ _ _ Hk1 Hk2 Ht1 Ht2). auto.
Qed.

Lemma split_polys_rec_cover_all :
  forall pols n, WHEN out <- split_polys_rec pols n THEN forall p, exists ppl, In ppl out /\ in_poly p (fst ppl) = true /\
                                                               (forall k pol, nth_error pols k = Some pol -> in_poly p pol = true -> In (n + k)%nat (snd ppl)).
Proof.
  induction pols.
  - intros n out Hout p.
    simpl in *. apply mayReturn_pure in Hout. exists (nil, nil). rewrite <- Hout.
    simpl; split; [|split]; auto. intros [|k]; simpl; congruence.
  - intros n out Hout p.
    simpl in *.
    bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout spl1 Hspl1; apply mayReturn_pure in Hout; rewrite <- Hout in *.
    destruct (IHpols _ _ Hspl p) as [[pol pl] [Hppl1 [Hin1 Hins1]]]; simpl in *.
    apply In_nth_error in Hppl1. destruct Hppl1 as [k1 Hk1].
    destruct (mapM_nth_error2 _ _ _ _ _ _ Hk1 _ Hspl1) as [lppl [Hlppl Hk2]].
    apply nth_error_In in Hk2.
    bind_imp_destruct Hlppl sep Hsep; apply mayReturn_pure in Hlppl.
    eapply separate_polys_cover in Hin1; [|eauto]. destruct Hin1 as [pol1 [Hpol1in Hinpol1]].
    rewrite in_app_iff in Hpol1in.
    destruct Hpol1in as [Hpol1in | Hpol1in]; [exists (pol1, n :: pl)|exists (pol1, pl)]; simpl; rewrite flatten_In.
    all: split; [exists lppl; split; [rewrite <- Hlppl; simpl|auto]|split; [auto|]].
    + rewrite in_app_iff; left. rewrite in_map_iff; exists pol1. auto.
    + intros [|k] pol2 Hk Hin2; simpl in *; [left; lia|right; rewrite Nat.add_succ_r; eapply Hins1; eauto].
    + rewrite in_app_iff; right. rewrite in_map_iff; exists pol1. auto.
    + intros [|k] pol2 Hk Hin2; simpl in *; [|rewrite Nat.add_succ_r; eapply Hins1; eauto].
      exfalso. eapply separate_polys_separate in Hinpol1; eauto. congruence.
Qed.

Definition split_polys pols :=
  BIND spl <- split_polys_rec pols 0%nat -;
  pure (filter (fun ppl => match snd ppl with nil => false | _ => true end) spl).

Lemma split_polys_index_correct :
  forall pols, WHEN out <- split_polys pols THEN forall polpl i, In polpl out -> In i (snd polpl) -> (i < length pols)%nat.
Proof.
  intros pols out Hout ppl i H1 H2.
  bind_imp_destruct Hout out1 Hout1. apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite filter_In in H1.
  generalize (split_polys_rec_index_correct pols 0%nat out1 Hout1 ppl i). intuition lia.
Qed.

Lemma split_polys_index_NoDup :
  forall pols, WHEN out <- split_polys pols THEN forall polpl, In polpl out -> NoDup (snd polpl).
Proof.
  intros pols out Hout ppl Hin.
  bind_imp_destruct Hout out1 Hout1. apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite filter_In in Hin; destruct Hin.
  eapply (split_polys_rec_index_NoDup pols 0%nat); eauto.
Qed.

Lemma split_polys_nrl :
  forall pols, WHEN out <- split_polys pols THEN forall k, (forall pol, In pol pols -> (poly_nrl pol <= k)%nat) -> (forall ppl, In ppl out -> (poly_nrl (fst ppl) <= k)%nat).
Proof.
  intros pols out Hout k H ppl Hin.
  bind_imp_destruct Hout out1 Hout1. apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite filter_In in Hin; destruct Hin.
  eapply (split_polys_rec_nrl pols 0%nat); eauto.
Qed.

Lemma split_polys_disjoint :
  forall pols, WHEN out <- split_polys pols THEN all_disjoint (map fst out).
Proof.
  intros pols out Hout.
  bind_imp_destruct Hout out1 Hout1. apply mayReturn_pure in Hout; rewrite <- Hout in *.
  apply split_polys_rec_disjoint in Hout1.
  apply all_disjoint_map_filter. auto.
Qed.

Lemma split_polys_cover :
  forall pols, WHEN out <- split_polys pols THEN
          forall p pol i, nth_error pols i = Some pol -> in_poly p pol = true -> exists ppl, In ppl out /\ In i (snd ppl) /\ in_poly p (fst ppl) = true.
Proof.
  intros pols out Hout p pol i Hi Hin.
  bind_imp_destruct Hout out1 Hout1. apply mayReturn_pure in Hout; rewrite <- Hout in *.
  destruct (split_polys_rec_cover_all _ _ _ Hout1 p) as [ppl Hppl].
  exists ppl. destruct Hppl as [H1 [H2 H3]]; specialize (H3 i pol).
  rewrite filter_In. split; [|auto]. split; [auto|]. destruct (snd ppl); [|auto].
  exfalso; apply H3; auto.
Qed.

(** * Building a dependency matrix for a list of polyhedra *)

Definition build_dependency_matrix n pols :=
  mapM (fun pol1 =>
          BIND proj1 <- Proj.project (n, pol1) -;
          mapM (fun pol2 => fmap negb (check_canPrecede n pol1 pol2 proj1)) pols) pols.

Lemma build_dependency_matrix_length :
  forall n pols, WHEN out <- build_dependency_matrix n pols THEN length out = length pols.
Proof.
  intros n pols out Hout.
  unfold build_dependency_matrix in Hout.
  symmetry; eapply mapM_length; eauto.
Qed.

Lemma build_dependency_matrix_canPrecede :
  forall n pols, WHEN out <- build_dependency_matrix n pols THEN
                 forall k1 k2 ppl1 ppl2, nth_error pols k1 = Some ppl1 -> nth_error pols k2 = Some ppl2 ->
                                    nth k2 (nth k1 out nil) true = false ->
                                    canPrecede n ppl1 ppl2.
Proof.
  intros n pols out Hout k1 k2 ppl1 ppl2 Hk1 Hk2 H.
  unfold build_dependency_matrix in Hout.
  eapply mapM_nth_error2 with (k := k1) in Hout; [|eauto].
  destruct Hout as [row [Hrow Hout]].
  bind_imp_destruct Hrow proj Hproj.
  eapply mapM_nth_error2 with (k := k2) in Hrow; [|eauto].
  destruct Hrow as [b [Hb Hrow]].
  erewrite nth_error_nth with (n := k1) in H; [|eauto].
  erewrite nth_error_nth in H; [|eauto]. rewrite H in Hb.
  unfold fmap in Hb. bind_imp_destruct Hb b1 Hb1; apply mayReturn_pure in Hb.
  destruct b1; simpl in *; [|congruence].
  eapply check_canPrecede_correct in Hb1; simpl in Hb1; [auto|].
  eapply Proj.project_in_iff; eauto.
Qed.

(** * Splitting and sorting a list of polyhedra *)

Definition split_and_sort n pols :=
  BIND spl <- split_polys pols -;
  BIND deps <- build_dependency_matrix n (map fst spl) -;
  BIND indices <- topo_sort deps -;
  pure (map (fun t => nth t spl (nil, nil)) indices).

Lemma split_and_sort_index_NoDup :
  forall n pols, WHEN out <- split_and_sort n pols THEN forall polpl, In polpl out -> NoDup (snd polpl).
Proof.
  intros n pols out Hout polpl Hin.
  unfold split_and_sort in Hout.
  bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout deps Hdeps; bind_imp_destruct Hout indices Hindices; apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite in_map_iff in Hin. destruct Hin as [t [Hpolpl _]].
  destruct (t <? length spl)%nat eqn:Ht; reflect.
  - eapply nth_In in Ht; rewrite Hpolpl in Ht.
    eapply split_polys_index_NoDup in Ht; eauto.
  - eapply nth_overflow in Ht; rewrite Hpolpl in Ht.
    rewrite Ht; simpl. constructor.
Qed.

Lemma split_and_sort_index_correct :
  forall n pols, WHEN out <- split_and_sort n pols THEN forall polpl i, In polpl out -> In i (snd polpl) -> (i < length pols)%nat.
Proof.
  intros n pols out Hout polpl i Hin Hiin.
  unfold split_and_sort in Hout.
  bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout deps Hdeps; bind_imp_destruct Hout indices Hindices; apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite in_map_iff in Hin. destruct Hin as [t [Hpolpl _]].
  destruct (t <? length spl)%nat eqn:Ht; reflect.
  - eapply nth_In in Ht; rewrite Hpolpl in Ht.
    eapply split_polys_index_correct in Ht; eauto.
  - eapply nth_overflow in Ht; rewrite Hpolpl in Ht.
    rewrite Ht in Hiin; simpl in Hiin; tauto.
Qed.

Lemma split_and_sort_nrl :
  forall n pols, WHEN out <- split_and_sort n pols THEN forall k, (forall pol, In pol pols -> (poly_nrl pol <= k)%nat) -> (forall ppl, In ppl out -> (poly_nrl (fst ppl) <= k)%nat).
Proof.
  intros n pols out Hout k Hk ppl Hin.
  unfold split_and_sort in Hout.
  bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout deps Hdeps; bind_imp_destruct Hout indices Hindices; apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite in_map_iff in Hin. destruct Hin as [t [Hppl _]].
  destruct (t <? length spl)%nat eqn:Ht; reflect.
  - eapply nth_In in Ht; rewrite Hppl in Ht.
    eapply split_polys_nrl in Ht; eauto.
  - eapply nth_overflow in Ht; rewrite Hppl in Ht.
    rewrite Ht. unfold poly_nrl; simpl. lia.
Qed.

Lemma split_and_sort_disjoint :
  forall n pols, WHEN out <- split_and_sort n pols THEN
          forall p k1 k2 ppl1 ppl2, nth_error out k1 = Some ppl1 -> nth_error out k2 = Some ppl2 ->
                               in_poly p (fst ppl1) = true -> in_poly p (fst ppl2) = true -> k1 = k2.
Proof.
  intros n pols out Hout p k1 k2 ppl1 ppl2 Hk1 Hk2 Hp1 Hp2.
  unfold split_and_sort in Hout.
  bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout deps Hdeps; bind_imp_destruct Hout indices Hindices; apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite nth_error_map_iff in Hk1, Hk2.
  destruct Hk1 as [t1 [Hind1 Ht1]]; destruct Hk2 as [t2 [Hind2 Ht2]].
  symmetry in Ht1; rewrite <- nth_error_nth_iff in Ht1 by (
    erewrite <- map_length, <- build_dependency_matrix_length; [|eauto];
    eapply topo_sort_indices_correct; [eauto|]; apply nth_error_In in Hind1; eauto
  ).
  symmetry in Ht2; rewrite <- nth_error_nth_iff in Ht2 by (
    erewrite <- map_length, <- build_dependency_matrix_length; [|eauto];
    eapply topo_sort_indices_correct; [eauto|]; apply nth_error_In in Hind2; eauto
  ).
  assert (t1 = t2) by (eapply split_polys_disjoint; try (apply map_nth_error); eauto).
  eapply NoDup_nth_error; [|apply nth_error_Some; rewrite Hind1; congruence|congruence].
  eapply Permutation_NoDup; [apply topo_sort_permutation; eauto|apply n_range_NoDup].
Qed.

Lemma split_and_sort_cover :
  forall n pols, WHEN out <- split_and_sort n pols THEN
            forall p pol i, nth_error pols i = Some pol -> in_poly p pol = true -> exists ppl, In ppl out /\ In i (snd ppl) /\ in_poly p (fst ppl) = true.
Proof.
  intros n pols out Hout p pol i Hi Hp.
  unfold split_and_sort in Hout.
  bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout deps Hdeps; bind_imp_destruct Hout indices Hindices; apply mayReturn_pure in Hout; rewrite <- Hout in *.
  eapply split_polys_cover in Hi; [|eauto]. specialize (Hi Hp).
  destruct Hi as [ppl [Hin [Hiin Hp1]]]. exists ppl.
  split; [|auto].
  apply In_nth_error in Hin; destruct Hin as [k Hk].
  rewrite in_map_iff. exists k. split; [erewrite nth_error_nth; eauto|].
  eapply Permutation_in; [eapply topo_sort_permutation; eauto|].
  erewrite build_dependency_matrix_length, map_length; [|eauto].
  rewrite n_range_in. apply nth_error_Some. congruence.
Qed.

Lemma split_and_sort_sorted :
  forall n pols, WHEN out <- split_and_sort n pols THEN
            forall k1 k2 ppl1 ppl2, nth_error out k1 = Some ppl1 -> nth_error out k2 = Some ppl2 ->
                               (k1 < k2)%nat -> canPrecede n (fst ppl1) (fst ppl2).
Proof.
  intros n pols out Hout k1 k2 ppl1 ppl2 Hk1 Hk2 Hcmp.
  bind_imp_destruct Hout spl Hspl; bind_imp_destruct Hout deps Hdeps; bind_imp_destruct Hout indices Hindices; apply mayReturn_pure in Hout; rewrite <- Hout in *.
  rewrite nth_error_map_iff in Hk1, Hk2.
  destruct Hk1 as [t1 [Hind1 Ht1]]; destruct Hk2 as [t2 [Hind2 Ht2]].
  symmetry in Ht1; rewrite <- nth_error_nth_iff in Ht1 by (
    erewrite <- map_length, <- build_dependency_matrix_length; [|eauto];
    eapply topo_sort_indices_correct; [eauto|]; apply nth_error_In in Hind1; eauto
  ).
  symmetry in Ht2; rewrite <- nth_error_nth_iff in Ht2 by (
    erewrite <- map_length, <- build_dependency_matrix_length; [|eauto];
    eapply topo_sort_indices_correct; [eauto|]; apply nth_error_In in Hind2; eauto
  ).
  assert (Hcmp2 : (k1 < k2 < length deps)%nat) by (split; [auto|]; rewrite <- topo_sort_length, <- nth_error_Some; [|eauto]; congruence).
  eapply topo_sort_sorted in Hcmp2; [|eauto].
  erewrite nth_error_nth with (n := k1) in Hcmp2; [|eauto].
  erewrite nth_error_nth with (n := k2) in Hcmp2; [|eauto].
  eapply build_dependency_matrix_canPrecede; [eauto| | |eauto]; erewrite map_nth_error; eauto.
Qed.

(** * Simplifying a polyhedron in a context *)

Fixpoint ctx_simplify pol ctx :=
  match pol with
  | nil => pure nil
  | c :: pol =>
    BIND simp1 <- ctx_simplify pol ctx -;
    BIND b <- isBottom (neg_constraint c :: simp1 ++ ctx) -;
    pure (if b then simp1 else c :: simp1)
  end.

Lemma ctx_simplify_correct :
  forall pol ctx, WHEN simp <- ctx_simplify pol ctx THEN (forall p, in_poly p ctx = true -> in_poly p pol = in_poly p simp).
Proof.
  induction pol; intros ctx simp Hsimp p Hpctx; simpl in *.
  - apply mayReturn_pure in Hsimp; rewrite <- Hsimp; reflexivity.
  - bind_imp_destruct Hsimp simp1 Hsimp1; bind_imp_destruct Hsimp b Hb; apply mayReturn_pure in Hsimp; rewrite <- Hsimp in *.
    transitivity (satisfies_constraint p a && in_poly p simp1); [f_equal; eapply IHpol; eauto|].
    destruct b; simpl; [|auto].
    apply isBottom_correct_1 in Hb; specialize (Hb p); simpl in *.
    rewrite neg_constraint_correct in Hb.
    destruct (satisfies_constraint p a); [auto|]. simpl in *.
    rewrite in_poly_app, Hpctx, andb_true_r in Hb. auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e190m11_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e413m21_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e322m2e161m1_14limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Syntax Eq Gen QuickCheck.

Definition prop_foo :=
  forAll gen_nat (fun n => true).

Definition bool_of_sumbool {A B:Prop} (sb: {A}+{B}) :=
  if sb then true else false.

Definition prop_natLeftUnit :=
  forAll gen_nat (fun n => bool_of_sumbool (n+0 =? n)).

Definition prop_hoge :=
  forAll gen_nat (fun n => bool_of_sumbool (n+0 =? 0)).

Definition test :=
  check prop_hoge.

Require Import List Streams.
Fixpoint take {A:Type} n (xs : Stream A) :=
  match n with
  | O => nil
  | S p =>
    match xs with
    | Cons x xs' => x :: take p xs'
    end
  end.

Definition test10 :=
  take 10 test.

Definition results :=
  List.map check [prop_foo;
    prop_natLeftUnit;
    prop_hoge
  ].


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e166m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e322m2e161m1_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(*i $Id: JMeq.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** John Major's Equality as proposed by Conor McBride

  Reference:

  [McBride] Elimination with a Motive, Proceedings of TYPES 2000,
  LNCS 2277, pp 197-216, 2002.

*)

Set Implicit Arguments.

Unset Elimination Schemes.

Inductive JMeq (A:Type) (x:A) : forall B:Type, B -> Prop :=
    JMeq_refl : JMeq x x.

Set Elimination Schemes.

Hint Resolve JMeq_refl.

Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x.
Proof.
destruct 1; trivial.
Qed.

Hint Immediate JMeq_sym.

Lemma JMeq_trans :
 forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z.
Proof.
destruct 2; trivial.
Qed.

Axiom JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y.

Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type),
  P x -> forall y, JMeq x y -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := H'); trivial.
Qed.

Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type),
   P x -> forall y, JMeq y x -> P y.
Proof.
intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial.
Qed.

Lemma JMeq_congr :
 forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y.
Proof.
intros A x B f y H; case JMeq_eq with (1 := H); trivial.
Qed.

(** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *)

Require Import Eqdep.

Lemma JMeq_eq_dep_id :
 forall (A B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X => X) A x B y.
Proof.
destruct 1.
apply eq_dep_intro.
Qed.

Lemma eq_dep_id_JMeq :
 forall (A B:Type) (x:A) (y:B), eq_dep Type (fun X => X) A x B y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

(** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *)

Lemma eq_dep_JMeq :
 forall U P p x q y, eq_dep U P p x q y -> JMeq x y.
Proof.
destruct 1.
apply JMeq_refl.
Qed.

Lemma eq_dep_strictly_stronger_JMeq :
 exists U, exists P, exists p, exists q, exists x, exists y,
  JMeq x y /\ ~ eq_dep U P p x q y.
Proof.
exists bool. exists (fun _ => True). exists true. exists false.
exists I. exists I.
split.
trivial.
intro H.
assert (true=false) by (destruct H; reflexivity).
discriminate.
Qed.

(** However, when the dependencies are equal, [JMeq (P p) x (P q) y]
    is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *)

Lemma JMeq_eq_dep :
  forall U (P:U->Prop) p q (x:P p) (y:P q),
  p = q -> JMeq x y -> eq_dep U P p x q y.
Proof.
intros.
destruct H.
apply JMeq_eq in H0 as ->.
reflexivity.
Qed.

(* Compatibility *)
Notation sym_JMeq := JMeq_sym (only parsing).
Notation trans_JMeq := JMeq_trans (only parsing).


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq paths fintype.
Require Import tuple bigops finset groups perm action prim_act.
Require Import morphisms normal cyclic.

(* Require Import paths finfun connect div zp. *)

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

Import GroupScope.

Definition bool_groupMixin := FinGroup.Mixin addbA addFb addbb.
Canonical Structure bool_baseGroup :=
  Eval hnf in BaseFinGroupType bool_groupMixin.
Canonical Structure boolGroup := Eval hnf in FinGroupType addbb.

Section PermutationParity.

Variable T : finType.

Implicit Type s : {perm T}.
Implicit Types x y z : T.

Definition pcycle s := orbit 'P%act <[s]>.
Definition pcycles s := pcycle s @: T.
Definition odd_perm (s : perm_type T) := odd #|T| (+) odd #|pcycles s|.
Definition even_perm s := ~~ odd_perm s.

Lemma pcycleE : forall s, pcycle s = orbit 'P%act <[s]>. Proof. by []. Qed.

Lemma pcycle_traject : forall s x, pcycle s x =i traject s x #[s].
Proof.
move=> s x y; apply/orbitP/trajectP=> [[sn] | [k _ <-]].
  by case/cyclePmin=> k lt_k_s <- <-; exists k; rewrite //= -permX.
by exists (s ^+ k); rewrite ?mem_cycle //= -permX.
Qed.

Definition dpair := [pred t | t.1 != t.2 :> T].

Lemma prod_tpermP : forall s : {perm T},
  {ts : seq (T * T) | s = \prod_(t <- ts) tperm t.1 t.2 & all dpair ts}.
Proof.
move=> s; elim: {s}_.+1 {-2}s (ltnSn #|[pred x | s x != x]|) => // n IHn s.
rewrite ltnS => le_s_n; case: (pickP (fun x => s x != x)) => [x s_x | s_id].
  have [|ts def_s ne_ts] := IHn (tperm x (s^-1 x) * s).
    rewrite (cardD1 x) !inE s_x in le_s_n; apply: leq_ltn_trans le_s_n.
    apply: subset_leq_card; apply/subsetP=> y.
    rewrite !inE permM permE /= -(canF_eq (permK _)).
    case: (y =P x) => [->|]; first by rewrite permKV eqxx.
    by move/eqP=> ne_yx; case: (_ =P x) => // -> _; rewrite eq_sym.
  exists ((x, s^-1 x) :: ts); last by rewrite /= -(canF_eq (permK _)) s_x.
  by rewrite big_cons -def_s mulgA tperm2 mul1g.
exists (Nil (T * T)); rewrite // big_nil; apply/permP=> x.
by apply/eqP; apply/idPn; rewrite perm1 s_id.
Qed.

Lemma ncycles_mul_tperm : forall s x y (t := tperm x y),
  #|pcycles (t * s)| + (x \notin pcycle s y).*2 = #|pcycles s| + (x != y).
Proof.
pose xf s x y := find (pred2 x y) (traject s (s x) #[s]).
have xf_size : forall s x y, xf s x y <= #[s].
  by move=> s x y; rewrite (leq_trans (find_size _ _)) ?size_traject.
have lt_xf: forall s x y n, n < xf s x y -> ~~ pred2 x y ((s ^+ n.+1) x).
  move=> s x y n lt_n; move/negbT: (before_find (s x) lt_n).
  by rewrite permX iterSr nth_traject // (leq_trans lt_n).
pose t x y s := tperm x y * s.
have tC: forall x y s, t x y s = t y x s by move=> x y s; rewrite /t tpermC.
have tK : forall x y, involutive (t x y) by move=> x y s; exact: tpermKg.
have tXC: forall s x y n, n <= xf s x y -> (t x y s ^+ n.+1) y = (s ^+ n.+1) x.
  move=> s x y; elim=> [|n IHn] lt_n_f; first by rewrite permM tpermR.
  rewrite !(expgSr _ n.+1) !permM {}IHn 1?ltnW //; congr (s _).
  by move/lt_xf: lt_n_f; case/norP=> *; rewrite tpermD // eq_sym.
have eq_xf: forall s x y, pred2 x y ((s ^+ (xf s x y).+1) x).
  move=> s x y; simpl in s, x, y.
  have has_f: has (pred2 x y) (traject s (s x) #[s]).
    apply/hasP; exists x; rewrite /= ?eqxx // -pcycle_traject.
    by apply/orbitP; exists s^-1; rewrite ?[_ s^-1]permK // groupV cycle_id.
  have:= nth_find (s x) has_f; rewrite has_find size_traject in has_f.
  by rewrite nth_traject // -iterSr -permX.
have xfC: forall s x y, xf (t x y s) y x = xf s x y.
  move=> s x y; wlog ltx: s x y / xf (t x y s) y x < xf s x y.
    move=> IWxy; set m := xf _ y x; set n := xf s x y.
    by case: (ltngtP m n) => // ltx; [exact: IWxy | rewrite /m -IWxy tC tK].
  by move/lt_xf: (ltx); rewrite -(tXC s x y) 1?ltnW //= orbC [_ || _]eq_xf.
move=> /= s x y; pose ts := t x y s; rewrite -[_ * s]/ts.
pose dp s' := #|pcycles s' :\ pcycle s' y :\ pcycle s' x|.
rewrite !(addnC #|_|) (cardsD1 (pcycle ts y)) mem_imset ?inE //.
rewrite (cardsD1 (pcycle ts x)) inE mem_imset ?inE //= -/(dp ts).
rewrite (cardsD1 (pcycle s y)) (cardsD1 (pcycle s x)) !(mem_imset, inE) //.
rewrite -/(dp s) !addnA !orbit_eq_mem -!pcycleE andbT; congr (_ + _).
  rewrite {dp}/ts; case: eqP => [<- | ne_xy].
    by rewrite /t tperm1 mul1g orbit_refl.
  suff ->: (x \in pcycle (t x y s) y) = (x \notin pcycle s y).
    by case: (x \in _).
  wlog xf_x: s x y ne_xy / (s ^+ (xf s x y).+1) x = x.
    move=> IWs; have:= eq_xf s x y; set n := xf s x y.
    case/pred2P=> [|snx]; first exact: IWs.
    rewrite -[x \in _]negbK ![x \in _]orbit_sym -!pcycleE.
    by rewrite -{}IWs; [rewrite tC tK | move/esym | rewrite xfC tXC].
  rewrite -{1}xf_x -(tXC _ _ _ _ (leqnn _)) (orbit_to 'P) ?mem_cycle //.
  rewrite orbit_sym; symmetry; apply/orbitP=> [[sn]]; case/cycleP=> n <-{sn}.
  rewrite [_ x _]permX => snx.
  have: looping s x (xf s x y).+1.
    by rewrite permX in xf_x; apply/trajectP; exists 0.
  move/loopingP; move/(_ n); rewrite {n}snx.
  case/trajectP=> [[//|i]]; rewrite ltnS -permX => lt_i def_y.
  by move/lt_xf: lt_i; rewrite def_y /= eqxx orbT.
rewrite {}/ts; wlog: s / dp (t x y s) < dp s.
  move=> IWs; case: (ltngtP (dp (t x y s)) (dp s)); [exact: IWs | | by []].
  by move=> lt_s_ts; rewrite -IWs tK.
rewrite ltnNge; case/negP; apply: subset_leq_card; apply/subsetP=> {dp} C.
rewrite !inE andbA andbC !(eq_sym C); case/and3P; case/imsetP=> z _ ->{C}.
rewrite 2!orbit_eq_mem -pcycleE => sxz syz.
suff ts_z: pcycle (t x y s) z = pcycle s z.
  by rewrite -ts_z !orbit_eq_mem -pcycleE {1 2}ts_z sxz syz mem_imset ?inE.
suff exp_id: forall n, ((t x y s) ^+ n) z = (s ^+ n) z.
  apply/setP=> u; apply/idP/idP; case/orbitP=> v; case/cycleP=> n <- <-{u v}.
    by rewrite [_ z _]exp_id (orbit_to 'P) ?mem_cycle.
  by rewrite -[_ z _]exp_id (orbit_to 'P) ?mem_cycle.
elim=> // n IHn; rewrite !expgSr !permM {}IHn.
by rewrite /t tpermD //; apply/eqP=> xy_z; [case/negP: sxz | case/negP: syz];
   rewrite xy_z (orbit_to 'P) ?mem_cycle.
Qed.

Lemma odd_perm1 : odd_perm 1 = false.
Proof.
rewrite /odd_perm card_imset ?addbb // => x y; move/eqP.
by rewrite orbit_eq_mem /= cycle1; case/orbitP=> ?; move/set1P->; rewrite act1.
Qed.

Lemma odd_mul_tperm : forall x y s,
  odd_perm (tperm x y * s) = (x != y) (+) odd_perm s.
Proof.
move=> x y s; rewrite addbC -addbA -[~~ _]oddb -odd_add -ncycles_mul_tperm.
by rewrite odd_add odd_double addbF.
Qed.

Lemma odd_tperm : forall x y, odd_perm (tperm x y) = (x != y).
Proof. by move=> x y; rewrite -[_ y]mulg1 odd_mul_tperm odd_perm1 addbF. Qed.

Lemma odd_perm_prod : forall ts,
  all dpair ts -> odd_perm (\prod_(t <- ts) tperm t.1 t.2) = odd (size ts).
Proof.
elim=> [_|t ts IHts] /=; first by rewrite big_nil odd_perm1.
by case/andP=> dt12 dts; rewrite big_cons odd_mul_tperm dt12 IHts.
Qed.

Lemma odd_permM : {morph odd_perm : s1 s2 / s1 * s2 >-> s1 (+) s2}.
Proof.
move=> s1 s2; case: (prod_tpermP s1) => ts1 ->{s1} dts1.
case: (prod_tpermP s2) => ts2 ->{s2} dts2.
by rewrite -big_cat !odd_perm_prod ?all_cat ?dts1 // size_cat odd_add.
Qed.

Lemma odd_permV : forall s, odd_perm s^-1 = odd_perm s.
Proof. by move=> s; rewrite -{2}(mulgK s s) !odd_permM -addbA addKb. Qed.

Lemma odd_permJ : forall s1 s2, odd_perm (s1 ^ s2) = odd_perm s1.
Proof. by move=> s1 s2; rewrite !odd_permM odd_permV addbC addbK. Qed.

(** Definitions of the alternate groups and some Properties **)
Definition Sym of phant T : {set {perm T}} := setT.

Canonical Structure Sym_group phT := Eval hnf in [group of Sym phT].

Notation Local "'Sym_T" := (Sym (Phant T)) (at level 0).

Canonical Structure sign_morph := @Morphism _ _ 'Sym_T _ (in2W odd_permM).

Definition Alt of phant T := 'ker odd_perm.

Canonical Structure Alt_group phT := Eval hnf in [group of Alt phT].

Notation Local "'Alt_T" := (Alt (Phant T)) (at level 0).

Lemma Alt_even : forall p, (p \in 'Alt_T) = even_perm p.
Proof. by move=> p; rewrite !inE /even_perm /=; case: odd_perm. Qed.

Lemma Alt_subset : 'Alt_T \subset 'Sym_T.
Proof. exact: subsetT. Qed.

Lemma Alt_normal : 'Alt_T <| 'Sym_T.
Proof. exact: ker_normal. Qed.

Lemma Alt_norm : 'Sym_T \subset 'N('Alt_T).
Proof. by case/andP: Alt_normal. Qed.

Let n := #|T|.

Lemma Alt_index : 1 < n -> #|'Sym_T : 'Alt_T| = 2.
Proof.
move=> lt1n; rewrite -card_quotient ?Alt_norm //=.
have : ('Sym_T / 'Alt_T) \isog (odd_perm @* 'Sym_T) by apply: first_isog.
case/isogP=> g; move/injmP; move/card_in_imset <-.
rewrite /morphim setIid=> ->; rewrite -card_bool; apply: eq_card => b.
apply/imsetP; case: b => /=; last first.
 by exists (1 : {perm T}); [rewrite setIid inE | rewrite odd_perm1].
case: (pickP T) lt1n => [x1 _ | d0]; last by rewrite /n eq_card0.
rewrite /n (cardD1 x1) ltnS lt0n; case/existsP=> x2 /=.
by rewrite eq_sym andbT -odd_tperm; exists (tperm x1 x2); rewrite ?inE.
Qed.

Lemma card_Sym : #|'Sym_T| = fact n.
Proof.
rewrite -[n]cardsE -card_perm; apply: eq_card => p.
by apply/idP/subsetP=> [? ?|]; rewrite !inE.
Qed.

Lemma card_Alt : 1 < n -> (2 * #|'Alt_T|)%N = fact n.
Proof.
by move/Alt_index <-; rewrite mulnC (LaGrange Alt_subset) card_Sym.
Qed.

Lemma Sym_trans : [transitive * n ('Sym_T | 'P) on setT].
Proof.
apply/imsetP; pose t1 := [tuple of enum T].
have dt1: t1 \in n.-dtuple(setT) by rewrite inE enum_uniq; apply/subsetP.
exists t1 => //; apply/setP=> t; apply/idP/imsetP=> [|[a _ ->{t}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> x; rewrite !inE.
case/dtuple_onP=> injt _; have injf := inj_comp injt (@enum_rank_inj _).
exists (perm injf); first by rewrite inE.
apply: eq_from_tnth => i; rewrite tnth_map /= [aperm _ _]permE; congr tnth.
by rewrite (tnth_nth (enum_default i)) enum_valK.
Qed.

Lemma Alt_trans : [transitive * n.-2 ('Alt_T | 'P) on setT].
Proof.
case n_m2: n Sym_trans => [|[|m]] /= tr_m2; try exact: ntransitive0.
have tr_m := ntransitive_weak (leqW (leqnSn m)) tr_m2.
case/imsetP: tr_m2; case/tupleP=> x; case/tupleP=> y t.
rewrite !dtuple_on_add 2!inE [x \in _]inE negb_or /= -!andbA.
case/and4P=> nxy ntx nty dt _; apply/imsetP; exists t => //; apply/setP=> u.
apply/idP/imsetP=> [|[a _ ->{u}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> z; rewrite !inE.
case/(atransP2 tr_m dt)=> /= a _ ->{u}.
case odd_a: (odd_perm a); last by exists a => //; rewrite !inE /= odd_a.
exists (tperm x y * a); first by rewrite !inE /= odd_permM odd_tperm nxy odd_a.
apply: val_inj; apply: eq_in_map => z tz; rewrite actM /= /aperm; congr (a _).
by case: tpermP ntx nty => // <-; rewrite tz.
Qed.

Lemma aperm_faithful : forall A : {group {perm T}},
  [faithful (A | 'P) on setT].
Proof.
move=> A; apply/faithfulP=> /= p _ np1; apply/eqP; apply/perm_act1P=> y.
by rewrite np1 ?inE.
Qed.

End PermutationParity.

Notation "''Sym_' T" := (Sym (Phant T))
  (at level 8, T at level 2, format "''Sym_' T") : group_scope.
Notation "''Sym_' T" := (Sym_group (Phant T)) : subgroup_scope.

Notation "''Alt_' T" := (Alt (Phant T))
  (at level 8, T at level 2, format "''Alt_' T") : group_scope.
Notation "''Alt_' T" := (Alt_group (Phant T)) : subgroup_scope.

Coercion odd_perm : perm_type >-> bool.


Require Import FunctionalExtensionality.

Definition undefined {a : Set} : a. Admitted.

Definition id {A : Set} : A -> A := fun x => x.

Definition comp {A B C : Set} (f : B -> C) (g : A -> B) (x : A) : C := f (g x).
Arguments comp {_ _ _} f g x /.

Infix "∘" := comp (at level 50).

Lemma comp_assoc : forall {A B C D : Set} (f : C -> D) (g : B -> C) (h : A -> B),
      f ∘ (g ∘ h) = (f ∘ g) ∘ h.
Proof. reflexivity. Qed.

Notation "f $ x" := (f x) (at level 60, right associativity, only parsing).

Definition flip {A B C : Set} (f : A -> B -> C) : B -> A -> C := fun y x => f x y.

Definition const {A B : Set} (x : B) : A -> B := fun _ => x.

Definition uncurry {A B C : Set} (f : A -> B -> C) : (A * B -> C) :=
  fun z => f (fst z) (snd z).

(* Notation "f .: g" := (fun x y => f (g x y)) (at level 100). *)

(* Function application *)
Definition f_ap {A B : Set}
  (f : A -> B) (x : A) := f x.

(* Reverse function application *)
Definition rev_f_ap {A B : Set}
  (x : A) (f : A -> B) := f x.

Lemma flip_id_rev_f_ap : forall (A : Set), flip (@id (A -> A)) = (@rev_f_ap A A).
Proof. intros A. now extensionality a. Qed.

Lemma id_expand : forall (A : Set), flip rev_f_ap (@id A) = id.
Proof. intros A. now extensionality a. Qed.

(** Tactic helpers *)

Require Import FunctionalExtensionality.

Ltac extensionalize :=
  intuition;
  unfold comp, id; simpl;
  let A := fresh "A" in
  try extensionality A;
  let B := fresh "B" in
  try extensionality B;
  let C := fresh "C" in
  try extensionality C;
  try destruct A;
  try destruct B;
  try destruct C;
  simpl in *;
  repeat (match goal with
          | [ H : False    |- _ ] => contradiction H
          | [ H : unit     |- _ ] => destruct H
          | [ H : bool     |- _ ] => destruct H
          | [ H : sum _ _  |- _ ] => destruct H
          | [ H : prod _ _ |- _ ] => destruct H
          end);
  auto.


Set Warnings "-notation-overridden".

From Coq Require Extraction Setoid ZArith.

Module Classes.

Export Setoid Morphisms.

(* Definition relation (A : Type) : Type :=
  A -> A -> Prop.

Definition respectful {A B : Type}
  (R : relation A) (S : relation B) (f g : A -> B) : Prop :=
  forall x y : A, R x y -> S (f x) (g y).

Definition Proper {A : Type} (R : relation A) (x : A) : Prop :=
  R x x.

Reserved Notation "R '==>' S" (at level 55, right associativity).
Notation "R '==>' S" := (respectful R S). *)
Reserved Notation "x '::>' R" (at level 60, right associativity).
Notation "x '::>' R" := (Proper R x).

Class Eqv (A : Type) : Type := eqv : A -> A -> Prop.
Class Opr (A : Type) : Type := opr : A -> A -> A.
Class Idn (A : Type) : Type := idn : A.
Class Inv (A : Type) : Type := inv : A -> A.
Class Add (A : Type) : Type := add : A -> A -> A.
Class Zero (A : Type) : Type := zero : A.
Class Neg (A : Type) : Type := neg : A -> A.
Class Mul (A : Type) : Type := mul : A -> A -> A.
Class One (A : Type) : Type := one : A.
Class Recip (A : Type) : Type := recip : A -> A.

Reserved Notation "x '==' y" (at level 70, no associativity).
Notation "x '==' y" := (eqv x y).
Notation "x '+' y" := (add x y).
Notation "'0'" := zero.
Notation "'-' x" := (neg x).
Notation "x '-' y" := (x + (- y)).
Notation "x '*' y" := (mul x y).
Notation "'1'" := one.
Notation "'/' x" := (recip x).
Notation "x '/' y" := (x * (/ y)).

Module AdditiveNotations.

Notation "x '+' y" := (opr x y).
Notation "'0'" := idn.
Notation "'-' x" := (inv x).
Notation "x '-' y" := (x + (- y)).

End AdditiveNotations.

Module MultiplicativeNotations.

Notation "x '*' y" := (opr x y).
Notation "'1'" := idn.
Notation "'/' x" := (inv x).
Notation "x '/' y" := (x * (/ y)).

End MultiplicativeNotations.

Class Setoid (A : Type) {eqv : Eqv A} : Prop := {
  ref : forall x : A, x == x;
  sym : forall x y : A, x == y -> y == x;
  tra : forall x y z : A, x == y -> y == z -> x == z;
}.

Section Additive.

Import AdditiveNotations.

Class Semigroup (A : Type) {eqv : Eqv A} {opr : Opr A} : Prop := {
  setoid :> Setoid A;
  opr_pro : opr ::> eqv ==> eqv ==> eqv;
  ass : forall x y z : A, (x + y) + z == x + (y + z);
}.

Class Monoid (A : Type) {eqv : Eqv A} {opr : Opr A} {idn : Idn A} : Prop := {
  semigroup :> Semigroup A;
  idn_l : forall x : A, 0 + x == x;
  idn_r : forall x : A, x + 0 == x;
}.

Class Group (A : Type) {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} : Prop := {
  monoid :> Monoid A;
  inv_pro : inv ::> eqv ==> eqv;
  inv_l : forall x : A, (- x) + x == 0;
  inv_r : forall x : A, x + (- x) == 0;
}.

End Additive.

Class Ring (A : Type) {eqv : Eqv A} {add : Add A} {zero : Zero A} {neg : Neg A}
  {mul : Mul A} {one : One A} : Prop := {
  add_group :> Group A (opr := add) (idn := zero) (inv := neg);
  add_com : forall x y : A, x + y == y + x;
  mul_monoid :> Monoid A (opr := mul) (idn := one);
  dis_l : forall x y z : A, x * (y + z) == x * y + x * z;
  dis_r : forall x y z : A, (x + y) * z == x * z + y * z;
}.

Add Parametric Relation {A : Type} {eqv' : Eqv A}
  {std' : Setoid A} : A eqv
  reflexivity proved by ref
  symmetry proved by sym
  transitivity proved by tra
  as eqv_relation.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {opr' : Opr A} {sgr' : Semigroup A} : opr
  with signature eqv ==> eqv ==> eqv
  as eqv_opr_morphism.
Proof.
  intros x y p z w q.
  destruct sgr' as [_ opr_pro _].
  cbv in opr_pro. apply opr_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {opr' : Opr A} {idn' : Idn A} {inv' : Inv A} {grp' : Group A} : inv
  with signature eqv ==> eqv
  as eqv_inv_morphism.
Proof.
  intros x y p.
  destruct grp' as [_ inv_pro _ _].
  cbv in inv_pro. apply inv_pro. apply p. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {add' : Add A} {zero' : Zero A} {neg' : Neg A}
  {mul' : Mul A} {one' : One A} {rng' : Ring A} : add
  with signature eqv ==> eqv ==> eqv
  as eqv_add_morphism.
Proof.
  intros x y p z w q.
  destruct rng' as [[[[_ add_pro _] _ _] _ _ _] _ _ _ _].
  cbv in add_pro. apply add_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {add' : Add A} {zero' : Zero A} {neg' : Neg A}
  {mul' : Mul A} {one' : One A} {rng' : Ring A} : neg
  with signature eqv ==> eqv
  as eqv_neg_morphism.
Proof.
  intros x y p.
  destruct rng' as [[[_ _ _] neg_pro _ _] _ _ _ _].
  cbv in neg_pro. apply neg_pro. apply p. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {add' : Add A} {zero' : Zero A} {neg' : Neg A}
  {mul' : Mul A} {one' : One A} {rng' : Ring A} : mul
  with signature eqv ==> eqv ==> eqv
  as eqv_mul_morphism.
Proof.
  intros x y p z w q.
  destruct rng' as [_ _ [[_ mul_pro _] _ _] _ _].
  cbv in mul_pro. apply mul_pro.
  - apply p.
  - apply q. Qed.

End Classes.

Module Properties.

Import Classes AdditiveNotations.

Theorem ivl : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x : A, - (- x) == x.
Proof.
  intros A eqv opr idn inv grp x.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnr (- (- x))). rewrite <- (pvl x).
  rewrite <- (pa (- (- x)) (- x) x). rewrite (pvl (- x)). rewrite (pnl x).
  reflexivity. Qed.

Lemma inj_l : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, z + x == z + y -> x == y.
Proof.
  intros A eqv opr idn inv grp x y z p.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnl x). rewrite <- (pvl z). rewrite (pa (- z) z x).
  rewrite p. rewrite <- (pa (- z) z y). rewrite (pvl z). rewrite (pnl y).
  reflexivity. Qed.

Lemma inj_r : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, x + z == y + z -> x == y.
Proof.
  intros A eqv opr idn inv grp x y z p.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnr x). rewrite <- (pvr z). rewrite <- (pa x z (- z)).
  rewrite p. rewrite (pa y z (- z)). rewrite (pvr z). rewrite (pnr y).
  reflexivity. Qed.

Theorem dis : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y : A, - (y + x) == (- x) + (- y).
Proof.
  intros A eqv opr idn inv grp x y.
  apply (inj_l (- (y + x)) ((- x) + (- y)) (y + x)).
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite (pvr (y + x)). rewrite <- (pa (y + x) (- x) (- y)).
  rewrite (pa y x (- x)). rewrite (pvr x). rewrite (pnr y). rewrite (pvr y).
  reflexivity. Qed.

End Properties.

Module Instances.

Import ZArith Z Classes.

Open Scope Z_scope.

Instance Z_Eqv : Eqv Z := fun x y : Z => x = y.

Instance Z_Setoid : Setoid Z := {
  ref := _;
  sym := _;
  tra := _;
}.
Proof.
  all: cbv [eqv].
  all: cbv [Z_Eqv].
  - apply eq_refl.
  - apply eq_sym.
  - apply eq_trans. Qed.

Instance Z_AddOpr : Opr Z := fun x y : Z => x + y.

Instance Z_AddSemigroup : Semigroup Z := {
  opr_pro := _;
  ass := _;
}.
Proof.
  all: cbv [eqv opr].
  all: cbv [Z_Eqv Z_AddOpr].
  - apply add_wd.
  - intros x y z. rewrite add_assoc. reflexivity. Qed.

Instance Z_AddIdn : Idn Z := 0.

Instance Z_AddMonoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [eqv opr idn].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn].
  - intros x. rewrite add_0_l. reflexivity.
  - intros x. rewrite add_0_r. reflexivity. Qed.

Instance Z_AddInv : Inv Z := fun x => - x.

Instance Z_AddGroup : Group Z := {
  inv_pro := _;
  inv_l := _; inv_r := _;
}.
Proof.
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv].
  - apply opp_wd.
  - intros x. rewrite add_opp_diag_l. reflexivity.
  - intros x. rewrite add_opp_diag_r. reflexivity. Qed.

Instance Z_MulOpr : Opr Z := fun x y : Z => x * y.

Instance Z_MulSemigroup : Semigroup Z := {
  opr_pro := _;
  ass := _;
}.
Proof.
  all: cbv [eqv opr].
  all: cbv [Z_Eqv Z_MulOpr].
  - apply mul_wd.
  - intros x y z. rewrite mul_assoc. reflexivity. Qed.

Instance Z_MulIdn : Idn Z := 1.

Instance Z_MulMonoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [eqv opr idn].
  all: cbv [Z_Eqv Z_MulOpr Z_MulIdn].
  - intros x. rewrite mul_1_l. reflexivity.
  - intros x. rewrite mul_1_r. reflexivity. Qed.

Instance Z_Add : Add Z := Z_AddOpr.
Instance Z_Zero : Zero Z := Z_AddIdn.
Instance Z_Neg : Neg Z := Z_AddInv.
Instance Z_Mul : Mul Z := Z_MulOpr.
Instance Z_One : One Z := Z_MulIdn.

Instance Z_Ring : Ring Z := {
  add_com := _;
  dis_l := _; dis_r := _;
}.
Proof.
  all: cbv [eqv add zero neg mul one].
  all: cbv [Z_Eqv Z_Add Z_Zero Z_Neg Z_Mul Z_One].
  all: cbv [Z_AddOpr Z_AddIdn Z_AddInv Z_MulOpr Z_MulIdn].
  - intros x y. rewrite add_comm. reflexivity.
  - intros x y z. rewrite mul_add_distr_l. reflexivity.
  - intros x y z. rewrite mul_add_distr_r. reflexivity. Qed.

End Instances.

Module Computations.

Section Input.

Import ZArith Z.

Open Scope Z_scope.

Definition meaning := 42.
Definition luck := 13.
Definition fortune := 7.

End Input.

Section Output.

Import Classes.

Example fate := meaning * fortune - luck.

End Output.

Section Test.

Import ZArith Z.

Open Scope Z_scope.

Compute if eq_dec fate 281 then true else false.

End Test.

End Computations.

Extraction "example.ml" Classes Properties Instances Computations.