(* Rewritten versions of poly1305 and chacha20 that you could compile with Rupicola *)

Require Coq.Init.Byte Coq.Strings.String. Import Init.Byte(byte(..)) String.
Require Import coqutil.Datatypes.List. Import Lists.List List.ListNotations.
Require Import Coq.ZArith.BinInt. Import Zdiv. Local Open Scope Z_scope.
Require Import coqutil.Byte coqutil.Word.LittleEndianList.

(* reference: https://datatracker.ietf.org/doc/html/rfc8439 *)

let r := List.map (as_word_list (firstn 16 k)) (fun x => x `and` 0x0ffffffc) in

l: list byte

H: locals[x] = xp
lw := (as_word_list l)
Hmem: (array Word lw xp * R) mem
==================
{| locals, mem, tr |} b { POST (k lw) }

apply compile_as_word_list

H: local[x] = xp
Hmem: (array Byte l xp * R) mem
Hlen: len xp mod 4 = 0
==================
{| locals, mem, tr |} b { POST (let x := as_word_list l in k x) }

felem_size

Definition poly1305 (p:=2^130-5) (k : list byte) (m : list byte) : list byte :=
  let f16, l16 := split 16 k in
  let scratch := make_buffer felem_size in
  let scratch := buf_append scratch f16 in
  let f16, lone_byte_and_felem_spare_space := split_buffer scratch in
  let f16 := as_word_list f16 in
  let f16 := List.map (fun w =>
                        let w := word.and w 0x0ffffffc in
                        w)
                     f16 in
  let f16 := as_byte_list f16 in
  let scratch := reassemble_buffer f16 lone_byte_and_felem_spare_space in
  let scratch := buffer_push scratch 0 in
  let scratch := buffer_as_array scratch in
  let scratch := as_felem_inplace scratch in (* B2 primitive reads first 17 bytes of longer array *)
  let mchunks := as_small_arrays 16 m in (* FIXME this shouldn't need to be a multiple of the length *)
  let a := stack (felem_init_zero ()) in
  let a := fold_left (fun idx a ck =>
                       let nscratch := make_buffer felem_size in
                       let nscratch := buf_append nscratch ck in (* len = 16 *)
                       let nscratch := buf_push nscratch x01 in (* len = 17 *)
                       let nscratch := as_felem_inplace nscratch in
                       let a := felem.add a nscratch in
                       let a := felem.mul a scratch in
                       a)
                    mchunks a in
  let output := felem_as_bytes a in
  let output := andres_uint128_add output l16 in (* FIXME reassemble inputs *)
  output.

Definition poly1305_uneven_length (p:=2^130-5) (k : list byte) (m : list byte) : list byte :=
  let f16, l16 := split 16 k in
  let scratch := make_buffer felem_size in
  let scratch := buf_append scratch f16 in
  let f16, lone_byte_and_felem_spare_space := split_buffer scratch in
  let f16 := as_word_list f16 in
  let f16 := List.map (fun w =>
                        let w := word.and w 0x0ffffffc in
                        w)
                     f16 in
  let f16 := as_byte_list f16 in
  let scratch := reassemble_buffer f16 lone_byte_and_felem_spare_space in
  let scratch := buffer_push scratch 0 in
  let scratch := buffer_as_array scratch in
  let scratch := as_felem_inplace scratch in (* B2 primitive reads first 17 bytes of longer array *)
  let a := stack (felem_init_zero ()) in
  let nchunks := Nat.div_up m_length 16 in
  let a := List.iter  (fun idx a ck =>
                       let nscratch := make_buffer felem_size in
                       let ck_start := idx * 16 in
                       let ck_end := min (ck_start + 16) m_length in
                       let before, ck, after := slice m ck_start ck_end in
                       let nscratch := buf_append nscratch ck in (* len = 16 *)
                       let m := reassemble before ck after in
                       let nscratch := buf_push nscratch x01 in (* len = 17 *)
                       let nscratch := as_felem_inplace nscratch in
                       let a := felem.add a nscratch in
                       let a := felem.mul a scratch in
                       a)
                    a in
  let output := felem_as_bytes a in
  let output := andres_uint128_add output l16 in (* FIXME reassemble inputs *)
  output.

Definition poly1305 (p:=2^130-5) (k : list byte) (m : list byte) : list byte :=
  let r := Z.land (le_combine (firstn 16 k)) 0x0ffffffc0ffffffc0ffffffc0fffffff in
  let t := fold_left (fun a n => (a+le_combine(n++[x01]))*r mod p) (chunk 16 m) 0 in
  le_split 16 (t + le_combine (skipn 16 k)).

Local Notation "a + b" := (Z.land (a+b) (Z.ones 32)).
Local Notation "a ^ b" := (Z.lxor a b).
Local Notation "a <<< b" := (Z.shiftl a b + Z.shiftr a (32-b))
  (at level 30).

Definition quarter '(a, b, c, d) :=
  let a := a + b in  let d := d ^ a in  let d := d <<< 16 in
  let c := c + d in  let b := b ^ c in  let b := b <<< 12 in
  let a := a + b in  let d := d ^ a in  let d := d <<< 8 in
  let c := c + d in  let b := b ^ c in  let b := b <<< 7 in
  (a, b, c, d).

Definition quarterround x y z t (st : list Z) :=
  let/n stx := ArrayList.get x st 0 in
  let/n sty := ArrayList.get y st 0 in
  let/n stz := ArrayList.get z st 0 in
  let/n stt := ArrayList.get t st 0 in
  let/n stx, sty, stz, stt := quarter (stx, sty, stz, stt) in
  let/n st := ArrayList.put x st stx in
  let/n st := ArrayList.put y st sty in
  let/n st := ArrayList.put z st stz in
  let/n st := ArrayList.put t st stt in
  st.

Definition quarterround x y z t (st : list Z) :=
  let '(a,b,c,d) := quarter (nth x st 0, nth y st 0, nth z st 0, nth t st 0) in
  upd (upd (upd (upd st x a) y b) z c) t d.

init := list_byte_of_string "expand 32-byte k"

Definition chacha20_block (*256bit*)key (*32bit+96bit*)nonce (*512 bits*)st :=
  let st := buffer_push init1 in
  let st := buffer_push init2 in
  let st := buffer_push init3 in
  let st := buffer_push init4 in (* the inits are the chunks of "expand …" *)
  let key := as_word_list key in
  let st := buffer_append st key in
  let key := as_byte_list st key in
  let nonce := as_word_list nonce in
  let st := buffer_append st nonce in
  let key := as_byte_list st nonce in
  let st := buffer_as_array st in
  let ss := make_buffer_word 16 in
  let ss := buf_append st ss in
  let ss := buffer_as_array ss in
  let ss := downto 10 0 (fun ss =>
    let ss := quarterround  0  4  8 12  ss in
    let ss := quarterround  1  5  9 13  ss in
    let ss := quarterround  2  6 10 14  ss in
    let ss := quarterround  3  7 11 15  ss in
    let ss := quarterround  0  5 10 15  ss in
    let ss := quarterround  1  6 11 12  ss in
    let ss := quarterround  2  7  8 13  ss in
    let ss := quarterround  3  4  9 14  ss in
    ss) ss in
  let st := List.iter 16 (fun i st =>
                           let st_i := Array.get st i in
                           let ss_i := Array.get ss i in
                           let st_i := word.add st_i ss_i in
                           let st := Array.put st i st_i in
                           st) st in
  let st := as_list_byte st in
  st.

Definition chacha20_block (*256bit*)key (*32bit+96bit*)nonce :=
  let st := (*512bit*)
    map le_combine (chunk 4 (list_byte_of_string"expand 32-byte k"))
    ++ map le_combine (chunk 4 key)
    ++ map le_combine (chunk 4 nonce) in
  let ss := Nat.iter 10 (fun ss =>
    let ss := quarterround  0  4  8 12  ss in
    let ss := quarterround  1  5  9 13  ss in
    let ss := quarterround  2  6 10 14  ss in
    let ss := quarterround  3  7 11 15  ss in
    let ss := quarterround  0  5 10 15  ss in
    let ss := quarterround  1  6 11 12  ss in
    let ss := quarterround  2  7  8 13  ss in
    let ss := quarterround  3  4  9 14  ss in
    ss) st in
  let st := map (fun '(s, t) => s + t) (combine ss st) in
  flat_map (le_split 4) st.

Definition chacha20_encrypt key start nonce plaintext :=
  let chunks := as_small_arrays 16 plaintex in (* FIXME this shouldn't need to be a multiple of the length *)
  let chunks := List.iter nchunks (fun idx chunks => (* FIXME nchunks *)
    let before, ck, after := partition_array chunks i in
    let counter := word.add start idx in
    let scratch := make_buffer_word 4 in
    let nonce := as_list_byte nonce in
    let scratch := buffer_push scratch counter in
    let scratch := buffer_append scratch nonce in (* FIXME? You can save a scratch buffer by doing the nonce concatenation of chacha20 here instead *)
    let st := make_buffer_word 16 in
    let st := chacha20_block key scratch st in
    let ck := List.iter 16 (fun idx => (* FIXME should this be rewritten as mapi *)
                           let st_i := Array.get st i in
                           let ss_i := Array.get ck i in
                           let ck_i := word.xor st_i ck_i in
                           let ck := Array.put ck i ck_i in
                           ck)
                       ck in
    let chunks := unpartition_array before chunk after in
    chunks) in
  let ciphertext := of_small_arrays chunks in
  ciphertext.

Definition chacha20_encrypt_uneven_length key start nonce plaintext :=
  let plaintext := List.iter (Nat.div_up plaintext_len 16) (fun idx plaintext => (* FIXME nplaintext *)
    let counter := word.add start idx in
    let scratch := make_buffer_word 4 in
    let nonce := as_list_byte nonce in
    let scratch := buffer_push scratch counter in
    let scratch := buffer_append scratch nonce in (* FIXME? You can save a scratch buffer by doing the nonce concatenation of chacha20 here instead *)
    let st := make_buffer_word 16 in
    let st := chacha20_block key scratch st in
    let st := as_list_bytes st in
    let chunk_start := idx * chunk_sz in
    let chunk_end := min (chunk_start + chunk_sz) plaintext_length in
    (* let before, ck, after := slice_out_array plaintext chunk_start chunk_end in *)
    let plaintext := List.iter chunk_start chunk_end
                       (fun idx => (* FIXME should this be rewritten as mapi *)
                           let st_i := Array.get st (i - chunk_start) in
                           let ss_i := Array.get plaintext i in
                           let plaintext_i := byte.xor st_i plaintext_i in
                           let plaintext := Array.put plaintext i plaintext_i in
                           plaintext)
                       plaintext in
    plaintext) in
  plaintext.

Definition chacha20_encrypt key start nonce plaintext :=
  flat_map (fun '(counter, ck) =>
    zip byte.xor (chacha20_block key (le_split 4 (Z.of_nat counter) ++ nonce)) ck)
  (enumerate start (chunk 64 plaintext)).

Definition chacha20poly1305_aead_encrypt aad key iv constant plaintext :=
  let pad16 xs := repeat x00 (Nat.div_up (length xs) 16 * 16 - length xs) in
  let nonce := constant ++ iv in
  let otk := firstn 32 (chacha20_block key (le_split 4 0 ++ nonce)) in
  let ciphertext := chacha20_encrypt key 1 nonce plaintext in
  let mac_data := aad ++ pad16 aad in
  let mac_data := mac_data ++ ciphertext ++ pad16 ciphertext in
  let mac_data := mac_data ++ le_split 8 (Z.of_nat (length aad)) in
  let mac_data := mac_data ++ le_split 8 (Z.of_nat (length ciphertext)) in
  let tag := poly1305 otk mac_data in
  (ciphertext, tag).


Require Export FiatFormal.Language.Ty.
Require Export FiatFormal.Language.Ki.

(* Kind judgement assigns a kind to a type.

   With plain SystemF (not SystemF2) we only have value types.
   We could have made this a 2-place relation and omitted the
   KStar return kind, but doing it this way makes the form of the
   judgement more similar to the SystemF2 case.
 *)
Inductive KIND : kienv -> ty -> ki -> Prop :=
 | KICon
   :  forall ke c
   ,  KIND ke (TCon c) KStar

 | KIVar
   :  forall ke i k
   ,  get  i ke = Some k
   -> KIND ke (TVar i) k

 | KIFun
   :  forall ke t1 t2
   ,  KIND ke t1 KStar
   -> KIND ke t2 KStar
   -> KIND ke (TFun t1 t2) KStar

 | KIExists
   : forall ke t,
     KIND (ke :> KStar) t KStar
     -> KIND ke (TExists t) KStar

 | KINProd
   : forall ke ts,
     Forall (fun t => KIND ke t KStar) ts
     -> KIND ke (TNProd ts) KStar

 | KINFun : forall ke ts tRes,
     KIND ke tRes KStar
     -> Forall (fun t => KIND ke t KStar) ts
     -> KIND ke (TNFun ts tRes) KStar.
Hint Constructors KIND.

Ltac inverts_kind :=
  match goal with
  | [ H1 : KIND _ _ _ |- _ ] => inverts keep H1
  end.

(* ----------------------------- *)
 Ltac notHyp P :=
   match goal with
   | [ _ : P |- _ ] => fail 1
   | _ =>
     match P with
     | ?P1 /\ ?P2 => first [ notHyp P1 | notHyp P2 | fail 2 ]
     | _ => idtac P
     end
   end.
 Ltac extend pf :=
   let t := type of pf in
   let t' := eval simpl in t in
       notHyp t'; generalize pf; intro.
  Ltac forall_cons :=
   match goal with
   | [ H: Forall _ (?tl :> ?h) |- _ ] =>
     inverts H; eauto
   end.
 Ltac ff_goal :=
   match goal with
   | [ |- Forall _ _ ] => apply Forall_forall; intros; eauto
   end.
 Ltac forall_in_extract' :=
   match goal with
   | [ H1: Forall _ ?l,
           H2: In ?x ?l |- _ ] =>
     let H := fresh "H" in
     pose proof (Forall_in _ _ _ H1 H2) as H; simpl in H; eauto
   end.
 Ltac forall_in_extract :=
   match goal with
   | [ H1: Forall _ ?l,
       H2: In ?x ?l |- _ ] =>
     extend (Forall_in _ _ _ H1 H2); simpl in *; eauto
   end.
(* ----------------------------- *)

(********************************************************************)
(* A well kinded type is well formed. *)
Lemma kind_wfT
 :  forall ke t k
 ,  KIND ke t k
 -> wfT ke t.
Proof.
 intros. gen ke k.
 induction t; intros; inverts H; simpl; eauto;
   try inverts_kind; eauto; repeat constructor; eauto;
 repeat (first [forall_cons | ff_goal | forall_in_extract]).

(* OLD PROOF *)
 (* Case "TNProd". *)
 (* inverts keep H4. eauto. *)
 (* apply Forall_forall; intros. *)
 (* pose proof (Forall_in _ _ _ H2 H); simpl in. *)
 (* eapply H3. inverts keep H4. *)
 (* pose proof (Forall_in _ _ _ H8 H); simpl in *. *)
 (* eassumption. *)

 (* Case "TNFun". *)
 (* inverts keep H7; eauto. *)
 (* apply Forall_forall; intros. *)
 (* pose proof (Forall_in _ _ _ H2 H); simpl in *. *)
 (* eapply H3. *)
 (* inverts keep H7. *)
 (* pose proof (Forall_in _ _ _ H9 H); simpl in *. *)
 (* eassumption. *)

Qed.

(* If a type is well kinded in an empty environment,
   then that type is closed. *)
Lemma kind_empty_is_closed
 :  forall t k
 ,  KIND nil t k
 -> closedT t.
Proof.
 intros. unfold closedT. eapply kind_wfT. eauto.
Qed.

(* We can insert a new type into the environment at an arbitray point
   provided we lift existing references to types higher than this
   point across the new one. *)
Lemma liftTT_insert
 :  forall ke ix t k1 k2
 ,  KIND ke t k1
 -> KIND (insert ix k2 ke) (liftTT ix t) k1.
Proof.
 intros. gen ix ke k1.
 induction t; intros; simpl; inverts H; eauto;
   simpl; try destruct k1.

 Case "TVar".
 lift_cases; intros; auto.

 Case "TExists". (* why doesn't auto 10 hang here? *)
 apply KIExists. (* why doesn't auto try applying registered constructor? *)
 rewrite insert_rewind.
 apply IHt. auto.

 Case "TNProd".
 apply KINProd; eauto.
 apply KINProd; eauto.
 inverts_kind. inverts keep H4.
 apply Forall_cons.
 apply H1; assumption.
 rewrite Forall_forall in H2.
 rewrite Forall_forall; intros.
 apply map_in_exists in H. destruct H as [y  [YX0  INY]].
 specialize (H2 _ INY).
 rewrite <- YX0. apply H2.
 rewrite Forall_forall in H6; eauto.

 Case "TNFun".
 apply KINFun. inverts_kind. apply IHt; eauto.
 apply Forall_nil.
 inverts_kind. inverts keep H6.
 apply KINFun; eauto.
 apply Forall_cons.
 apply H1; assumption.
 rewrite Forall_forall in H2.
 rewrite Forall_forall; intros.
 apply map_in_exists in H. destruct H as [y  [YX0  INY]].
 specialize (H2 _ INY).
 rewrite <- YX0. apply H2.
 rewrite Forall_forall in H6; eauto.
Qed.

(* Weakening the kind environment by pushing a new type onto the
   stack *)
Lemma liftTT_weaken
 :  forall ke t k1 k2
 ,  KIND  ke         t           k1
 -> KIND (ke :> k2) (liftTT 0 t) k1.
Proof.
  intros.
  assert (ke :> k2 = insert 0 k2 ke). simpl.
  destruct ke; auto.
  rewrite H0. apply liftTT_insert. auto.
Qed.


(**

----------------------------------------------

  Num anonymat : 6

  NOM:

  PRENOM:

  No Ano: 3264851

-----------------------------------------------

  * Spécification et Validation de Programmes - Examen Février 2016

Cet examen est un examen sur machine.

_Durée_ : 3 heures

_Documents_ :  tous documents autorisés

L'objectif est de répondre directement dans ce fichier et de
soumettre ce dernier sur le site du master (cf. instructions données
lors de l'examen).   Repérez les mots  "QUESTION"  au fil du texte.

_Important_ : le temps de soumission est compris dans les 3 heures,
 toute soumission tardive est comptée comme copie vide.

Dans les réponses, les [admit]  ou [Admitted]  doivent etre effacés ou commentés sinon aucun point ne sera accordé à la question.   Le sujet est à priori à répondre dans l'ordre
 des questions mais il est possible de laisser un [admit] ou [Admitted] pour passer à la suite
 en supposant la réponse fournie.

La difficulté relative et ressentie par les enseignants pour chaque question est notée de
la façon suivante :

  [+]   question facile
  [++]  question non-triviale mais simple
  [+++] question demandant un peu plus de réflexion
  [++++] question difficile et/ou prenant du temps

Le sujet est composé de deux exercices:

  - exercice 1 : spécification et validation d'un programme de tri

  - exercice 2 : modélisation événementielle d'une file d'attente triée.

_Remarque_ : l'exercice 2 utilise les définitions de l'exercice 1
 et n'est donc pas indépendant. Cependant, on pourra passer à l'exercice
 2 avant de compléter l'exercice 1 en acceptant certains résultats.

*)

Require Import Bool.
Require Import Arith.
Require Import List.

(**

* Exercice 1 : du tri certifié ...

Dans cet exercice nous spécifions le principe des listes
 triées et développons un programme de tri certifié.

Voici une spécification inductive de la notion
de liste triée.

 *)

Inductive Sorted : list nat -> Prop :=
| sorted_nil: Sorted nil
| sorted_one: forall a : nat, Sorted (a::nil)
| sorted_cons:
    forall a b : nat, forall l : list nat,
      a <= b -> Sorted (b::l)
      -> Sorted (a::b::l).

(**

 ** QUESTION 1 [+]

Compléter les preuves des exemples suivant.

*)

Example Sorted_ex1:
  Sorted (1::2::3::4::5::nil).
Proof.
  repeat apply sorted_cons.
  SearchPattern ( _ <= _).
  apply le_S; reflexivity.
  auto.
  auto.
  auto.
  apply sorted_one.
Qed.

Example Sorted_ex2:
  not (Sorted (1::2::3::2::4::nil)).
Proof.
  unfold not.
  intros HF.
  assert (Sorted (1 :: 2 :: 3 :: 2 :: 4 :: nil) -> True).
  - intros HFF.
  inversion HF.
Admitted.

(**

  ** QUESTION 2 [+]

Compléter la définition de la fonction [fsorted]
 ci-dessous, de sorte que les deux tests
suivant passent.

 *)

Fixpoint fsorted (l:list nat) : bool :=
match l with
    | nil => true
    | x :: nil => true
    | x :: xs => match xs with
                   | nil => true
                   | y :: ys => if (leb x y) then fsorted xs else false
                 end
end.

Example fsorted_ex1:
  fsorted (1::2::3::4::5::nil) = true.
Proof.
  compute.
  reflexivity.
Qed.

Example fsorted_ex2:
  fsorted (1::2::3::2::4::nil)= false.
Proof.
 compute.
  reflexivity.
Qed.

(**

  * QUESTION 3 [++]

On se donne le lemme suivant (avec sa preuve
qui devrait passer en la décommentant...).

*)

Lemma fsorted_tail:
  forall a b : nat, forall l : list nat,
    leb a b && fsorted (b::l) = true
    -> fsorted (a::b::l) = true.
Proof.
  intros a b l H.
  induction l as [| c l'].
  - (* cas l=nil *)
    simpl.
    simpl in H.
    exact H.
  - (* cas l=c::l' *)
    simpl.
    case_eq (leb a b).
    + (* cas a <= b *)
      intro Htrue.
      rewrite Htrue in *.
      simpl in *.
      case_eq (leb b c).
      * (* cas b <= c *)
        intro Htrue'.
        rewrite Htrue' in *.
        simpl in *.
        { destruct l' as [|d l''].
          - (* cas l'=nil *)
            reflexivity.
          - (* cas l''=d l'' *)
            simpl.
            exact H.
        }
      * (* cas b > c *)
        intro Hfalse.
        rewrite Hfalse in *.
        simpl in *.
        inversion H.
    + (* cas a > b *)
      intro Hfalse.
      rewrite Hfalse in *.
      simpl in *.
      inversion H.
Qed.

(**

Montrer le Lemme suivant en suivant
 le principe d'induction des listes triées.

_Remarque_ : on pourra bien sûr utiliser le Lemme
précédent. On s'intéressera également à la conversion entre
les expressions (a <= b)   et  (leb a b = true).

*)

Lemma Sorted_fsorted:
  forall l : list nat,
    Sorted l -> fsorted l = true.
Proof.
  intros l H.
  induction H.
  +simpl.
   trivial.
  +simpl.
   trivial.
  + apply fsorted_tail.
    rewrite IHSorted.
    destruct (leb a b).
    *simpl.
     auto.
    *
     simpl.
     admit.
Qed.
(**

  ** QUESTION 4 [++]

On se donne le Lemme complémentaire suivant :

*)

Lemma fsorted_Sorted:
  forall l : list nat,
    fsorted l = true -> Sorted l.
Proof.
  intros l H.
  induction l as [|a l'].
  - apply sorted_nil.
  - destruct l' as [|b l''].
    + apply sorted_one.
    + apply sorted_cons.
      * inversion H.
        Check andb_prop.
        apply andb_prop in H1.
        destruct H1 as [ H2 H3 ].
        SearchPattern ( leb _ _ = true -> _ <= _ ).
        apply leb_complete.
        exact H2.
      * apply IHl'.
        inversion H.
        apply andb_prop in H1.
        destruct H1 as [H2 H3].
        rewrite H2 in *.
        simpl.
        reflexivity.
Qed.

(**

Démontrer les deux lemmes ci-dessous.

*)

Lemma Sorted_tail_conv:
  forall n : nat, forall l : list nat,
    Sorted (n::l) -> Sorted l.
Proof.
  intros n l S.
  inversion S.
  constructor.
  exact H2.
Qed.

Lemma fsorted_tail_conv:
  forall n : nat, forall l : list nat,
    fsorted (n::l) = true -> fsorted l = true.
Proof.
  intros n l S.
  induction l as [|x l'].
  -simpl.
   auto.
  -rewrite <- IHl'.
   +apply fsorted_tail in S.
Admitted.

(**

  ** QUESTION 5 [+++]

On définit maintenant la notion de permutation.

*)

Fixpoint frequence (n:nat) (l:list nat) : nat :=
  match l with
    | nil => 0
    | m::l' => if beq_nat n m then S (frequence n (l'))
               else frequence n l'
  end.

Example frequence_ex:
  let l := (1::2::2::3::4::1::2::5::nil)
  in (frequence 3 l = 1)
     /\ (frequence 2 l = 3)
     /\ (frequence 6 l = 0).
Proof.
  compute ; repeat split ; reflexivity.
Qed.

Definition Permutation (l1 l2 : list nat) : Prop :=
  (length l1 = length l2) /\
  forall n : nat, frequence n l1 = frequence n l2.

Example Perm_ex1:
  Permutation (1::2::3::3::4::nil) (3::2::3::1::4::nil).
Proof.
  unfold Permutation.
  split.
  - simpl. reflexivity.
  - intro n.
    simpl.
    destruct (beq_nat n 1).
    + destruct (beq_nat n 2).
      * destruct (beq_nat n 3) ; reflexivity.
      * destruct (beq_nat n 3) ; reflexivity.
    + destruct (beq_nat n 2).
      * destruct (beq_nat n 3) ; reflexivity.
      * destruct (beq_nat n 3) ; reflexivity.
Qed.

(**

  Ainsi que le fait d'un algorithm de tri correct.

*)

Definition Correct_Sort (l1 l2 : list nat) : Prop :=
  Sorted l2 /\ Permutation l1 l2.

(**

On se donne la fonction [insert] ci-dessous effectuant
l'insertion d'un élément "à la bonne place" dans une liste
 [l]  déjà triée. Et compléter la preuve du Lemme [Sorted_insert]
 qui suit.

*)

Fixpoint insert (n:nat) (l:list nat) : list nat :=
  match l with
    | nil => n::nil
    | m::l' => if leb n m then n::m::l'
               else m::(insert n l')
  end.

Lemma Sorted_insert:
  forall l : list nat,
    Sorted l -> forall n : nat, Sorted (insert n l).
Proof.
  intros l H n.
  induction H.
  - simpl.
    apply sorted_one.
  - simpl.
    destruct (leb n a).
    + apply sorted_cons.
      * admit.
      * apply sorted_one.
    + apply sorted_cons.
      *admit.
      *apply sorted_one.
  - simpl.
    admit.
Qed.

(**

On en déduit le Lemme suivant :

*)

Lemma fsorted_insert:
  forall l : list nat,
    fsorted l = true -> forall n : nat, fsorted (insert n l) = true.
Proof.
  intros l H n.
  apply Sorted_fsorted.
  apply fsorted_Sorted in H.
  apply Sorted_insert ; assumption.
Qed.

(**

  ** QUESTION 6 [+++]

Démontrer le Lemme suivant :

*)

Lemma frequence_insert:
  forall n : nat, forall l : list nat,
    frequence n (insert n l) = S (frequence n l).
Proof.
  intros n l.
  induction l as [|x l'].
  -simpl.
   rewrite <- beq_nat_refl.
   reflexivity.
  - simpl.
   admit.
Qed.

(**

On se donne également le Lemme suivant.

*)

Lemma frequence_insert_neq:
  forall n m : nat, forall l : list nat,
    n<>m -> frequence m (insert n l) = frequence m l.
Proof.
  intros n m l.
  generalize m as p. clear m.
  induction l as [| m l'].
  - intros p Hneq.
    simpl.
    case_eq (beq_nat p n).
    + intro Htrue.
      SearchPattern (beq_nat _ _ = true -> _ = _ ).
      apply beq_nat_true in Htrue.
      apply eq_sym in Htrue.
      contradiction.
    + reflexivity.
  - intros p H.
    simpl.
    case_eq (leb n m).
    + intro Heq.
      simpl.
      case_eq (beq_nat p n).
      * intro Htrue.
        apply beq_nat_true in Htrue.
        apply eq_sym in Htrue.
        contradiction.
      * intro Hfalse.
        reflexivity.
    + intro Hfalse.
      simpl.
      destruct (beq_nat p m).
      * apply eq_S.
        { rewrite IHl'.
          - reflexivity.
          - exact H.
        }
      * apply IHl'.
        exact H.
Qed.

(**

  ** QUESTION 7 [++]

Définir la fonction [tri_insert] de tri par insertion
 et démontrer le lemme [tri_insert_Sorted] ci-dessous.

*)

Fixpoint tri_insert (l:list nat) : list nat :=
  match l with
    | nil => nil
    | x :: xs => insert x (tri_insert xs)
  end.

Example tri_insert_ex:
  tri_insert (5::3::4::2::3::3::1::2::9::nil)
  = (1::2::2::3::3::3::4::5::9::nil).
Proof.
simpl. reflexivity.
Qed.

Lemma tri_insert_Sorted:
  forall l : list nat,
    Sorted (tri_insert l).
Proof.
  intro l.
  induction l as [|x l'].
  -simpl.
   apply sorted_nil.
  -simpl.
   apply Sorted_insert.
   exact IHl'.
Qed.
(**

** QUESTION 8 [+++]

Démontrer le lemme suivant :

*)

Lemma tri_insert_frequence:
  forall n : nat, forall l : list nat,
    frequence n (tri_insert l) = frequence n l.
Proof.
  intros n l.
  induction l as [|x l'].
  - simpl.
    reflexivity.
  -simpl.
   destruct (beq_nat n x).
   +rewrite <- IHl'.
    rewrite <- frequence_insert.
    admit.
   + inversion IHl'.
     admit.
Qed.

(**

** QUESTION 9 [+++]

Prouver que l'implémentation du tri par insertion
 est correcte (Théorème [tri_insert_correct]).

_Remarque_ : il faudra sans doute définir quelques
 lemmes utilitaires.

*)

Theorem tri_insert_correct:
  forall l : list nat,
    Correct_Sort l (tri_insert l).
Proof.
  (* A COMPLETER *)
Admitted.

(* ------------------------------------------------------------------------ *)

(**

  * Exercice 2 : modélisation événementielle d'une file d'attente triée.

On se donne la machine abstraite suivante :

 *)

Module AbstractQueue.

Record State : Set :=
  mkState {
      queue : list nat
    }.

Definition Inv_1 (st:State) : Prop :=
  Sorted st.(queue).

Module Init.

Definition action : State := mkState nil.

Theorem PO_Safety:
  Inv_1 (action).
Proof.
  unfold Inv_1.
  simpl.
  apply sorted_nil.
Qed.

End Init.

Module Push.

Definition action_Prop_1 (n:nat) (st st' : State) : Prop :=
  Permutation st'.(queue) (n::(st.(queue))).

Definition action_Prop_2 (n:nat) (st st' : State) : Prop :=
  Sorted st'.(queue).

(** QUESTION 1 [++]

Compléter la définition et la preuve de l'obligation de preuve suivante.

*)

Theorem PO_Safety:
  forall n : nat, forall st st' : State,  (* True. *)
    Inv_1 st -> action_Prop_1 n st st' -> action_Prop_2 n st st'
    -> Inv_1 st'.
Proof.
  intros n st st'.
  unfold Inv_1.
  unfold action_Prop_1.
  unfold action_Prop_2.
  intros I1 P S.
  induction (queue st') as [|x xs].
  +exact S.
  +exact S.
Qed.

End Push.

(** On complète la machine. *)

Module Pull.

Definition Guard (st:State) : Prop :=
  st.(queue) <> nil.

Definition action_Prop_1 (st st' : State) : Prop :=
  S (length st'.(queue)) = length st.(queue).

Definition action_Prop_2 (st st' : State) : Prop :=
  Sorted st'.(queue).

Theorem PO_Safety:
  forall st st' : State,
    Inv_1 st -> Guard st
    -> action_Prop_1 st st' -> action_Prop_2 st st'
    -> Inv_1 st'.
Proof.
  intros st st' HInv_1 HGuard HProp1 HProp2.
  unfold Inv_1 in *.
  unfold action_Prop_2 in *.
  exact HProp2.
Qed.

End Pull.

End AbstractQueue.

(** QUESTION 2 [++]

Compléter la machine concrète [ConcreteQueue] ci-dessous en utilisant [insert]   (insertion triée)
 pour l'événement [Push],  le plus petit élément pour l'événement
 [Pull].

Définir et prouver toutes les obligations de preuves nécessaires
 pour démontrer que le raffinement est correct.

Remarque : dans cette partie, il sera plus important d'énoncer les lemmes auxiliaires nécessaires que de les prouver en détail. On les admettra donc et on terminera les preuves si le temps le permet.

 *)

Module ConcreteQueue.

Record State : Set :=
  mkState {
      queue : list nat
    }.

Definition Glue_Inv_1 (st:State) (ast:AbstractQueue.State) : Prop :=
  Permutation st.(queue) (AbstractQueue.queue ast).

Definition Inv_1 (st:State) : Prop :=
  Sorted st.(queue).

Module Init.

Definition action : State := mkState nil.

Theorem PO_Safety:
  Inv_1 (action).
Proof.
  unfold Inv_1.
  simpl.
  apply sorted_nil.
Qed.

Theorem PO_Simulation:
    let st := action in
    let ast := AbstractQueue.Init.action in
    Glue_Inv_1 st ast.
Proof.
  unfold AbstractQueue.Init.action.
  unfold action.
  unfold Glue_Inv_1.
  unfold Permutation.
  induction queue as [|e q'].
  *simpl.
   auto.
  * simpl.
    split.
Admitted.

End Init.

Module Push.

Definition action (n:nat) (st:State) : State :=
  mkState (insert n (st.(queue))).

Theorem PO_Safety:
  forall st : State,
    Inv_1 st
    -> forall n : nat,
         let st' := action n st in
         Inv_1 st'.
Proof.
  intros st.
  unfold Inv_1.
  unfold action.
  intros S n.
  simpl.
  apply Sorted_insert.
  exact S.
Qed.

(**  ** QUESTION 3 [++++]

Compléter la preuve ci-dessous.

_Remarque_ : il faut un certain nombre de lemmes intermédiaires
concernant Permutation : réflexivité, symmétrie, transitivité,
 comportement vis-à-vis de insert et cons (e::l)...

 *)

Theorem PO_Simulation:
  forall st : State, forall ast : AbstractQueue.State,
    AbstractQueue.Inv_1 ast
    -> Inv_1 st
    -> Glue_Inv_1 st ast
    -> forall n : nat, forall ast' : AbstractQueue.State,
         AbstractQueue.Push.action_Prop_1 n ast ast'
         -> AbstractQueue.Push.action_Prop_2 n ast ast'
         -> let st' := action n st in
            Glue_Inv_1 st' ast'.
Proof.
  (* A COMPLETER *)
Admitted.

End Push.

Module Pull.

(**  QUESTION 4 [+++]

Donner les spécifications et les obligationres de l'événement [Pull].

*)

End Pull.

End ConcreteQueue.

(** QUESTION 5 [+++]

Modifier la machine concrète pour garantir la _convergence_
 de l'événement [Pull].

*)

(** QUESTION 6 [+++]

Démontrer l'obligation de preuve _Deadlock freedom_  sur
la machine concrète.

 *)


Require Import FP.Data.WeakSetoid.
Require Import FP.Data.Function.
Require Import FP.Data.Relation.
Require Import FP.Classes.Eqv.
Require Import FP.Data.Function.
Require Import FP.Classes.WeakEqv.
Require Import FP.Classes.Reflexive.

Import WeakSetoid.Notation.
Import Eqv.Notation.
Import WeakEqv.Notation.
Import Function.Notation.

(*
  -- what I want the goal for compose_Q to actually look like...
  refine(
    let rawf := fun (g:DD (B ⇨ C)) (f:DD (A ⇨ B)) (x:DD A) => g ⊛ (f ⊛ x) in
    let pf1 : forall g f, proper weqv (fun x => rawf g f x) := _ in
    let pf2 : forall g, proper weqv (fun f => (mk_DD_f (fun x => rawf g f x) (pf1 g f))) := _ in
    mk_DD_f (fun g => mk_DD_f (fun f => mk_DD_f (fun x => rawf g f x) (pf1 g f)) (pf2 g)) _
             ) ; abstract (intros ; repeat (unfold rawf ; decide_weqv)).
*)

Definition id_Q {A:WeakSetoid} : DD (A ⇨ A) := λ x → x.
Definition id_Q_beta {A:WeakSetoid} (x:DD A) : id_Q ⊛ x ≃ x := DD_proper x.
Definition compose_Q {A B C:WeakSetoid} : DD ((B ⇨ C) ⇨ (A ⇨ B) ⇨ (A ⇨ C)) := λ g f x → g ⊛ (f ⊛ x).
Definition compose_Q_beta {A B C:WeakSetoid} (g:DD (B ⇨ C)) (f:DD (A ⇨ B)) (x:DD A) : compose_Q ⊛ g ⊛ f ⊛ x ≃ g ⊛ (f ⊛ x) :=
  reflexivity.
Definition apply_Q {A B:WeakSetoid} : DD ((A ⇨ B) ⇨ A ⇨ B) := λ f x → f ⊛ x.
Definition apply_Q_beta {A B:WeakSetoid} (f:DD (A ⇨ B)) (x:DD A) : apply_Q ⊛ f ⊛ x ≃ f ⊛ x :=
  reflexivity.
Definition flip_Q {A B C:WeakSetoid} : DD ((A ⇨ B ⇨ C) ⇨ B ⇨ A ⇨ C) := λ f y x → f ⊛ x ⊛ y.
Definition flip_Q_beta {A B C:WeakSetoid} (f:DD (A ⇨ B ⇨ C)) (y:DD B) (x:DD A) : flip_Q ⊛ f ⊛ y ⊛ x ≃ f ⊛ x ⊛ y :=
  reflexivity.
Definition apply_to_Q {A B:WeakSetoid} : DD (A ⇨ (A ⇨ B) ⇨ B) := flip_Q ⊛ apply_Q.
Definition apply_to_Q_beta {A B:WeakSetoid} (x:DD A) (f:DD (A ⇨ B)) : apply_to_Q ⊛ x ⊛ f ≃ f ⊛ x :=
  reflexivity.


Theorem nnnpnp : forall P : Prop, ~~~P -> ~P.
Proof.
  intros.
  unfold not. unfold not in H.
  intros.
  apply H.
  intros.
  apply (H1 H0).
Qed.

Theorem nnnppq : forall P Q : Prop, ~~~P -> P -> Q.
Proof.
  intros.
  unfold not in H.
  assert (~P) as nP.
    apply (nnnpnp P H).
  unfold not in nP.
  apply False_ind.
  apply (nP H0).
Qed.


Require Import A1_Plan A2_Orientation.

Section LINES.

(* La regle est le constructeur de droite a partir de deux points distincts. *)

Inductive Line  : Set := | Ruler : forall A B : Point, A <> B -> Line.

(* Les points A et B sont les points de construction de la droite. *)

Definition LineA := fun l : Line => let (A, _, _) := l in A.

Definition LineB := fun l : Line => let (_, B, _) := l in B.

Definition LineH : forall l : Line, LineA l <> LineB l.
Proof.
	destruct l as (A, B, H); exact H.
Defined.

(* La droite est la representation graphique de la figure formee des points colineaires aux points de construction de la droite. *)

Definition OnLine (l : Line) := let (A,B,_) := l in Collinear A B.

(* Une figure est representee par une droite si l'on sait construire une droite dont la representation graphique coincide avec la figure. *)

Definition IsLine (f : Figure) := {l : Line | forall M : Point, f M <-> OnLine l M}.

(* Deux droites sont paralleles si un demi plan de l'une est inclus dans un demi plan de l'autre. *)

Definition ParallelLines (l1 l2 : Line) :=
	EquiDirected (LineA l1) (LineB l1) (LineA l2) (LineB l2).

(* Deux droites sont secantes si elles ne sont pas paralleles. *)

Definition SecantLines (l1 l2 : Line) := ~ParallelLines l1 l2.

Definition lineOoUu := Ruler Oo Uu DistinctOoUu.

End LINES.


Require Import Coq.Vectors.Vector.
Require Import Coq.Vectors.Fin.
Require Import Coq.ZArith.ZArith.

Require Import UkModulo.Digits.AccountDigits.
Require Import UkModulo.Notations.Vector.

Open Scope Z.
Open Scope vector_scope.

Definition t := Vector.t Z 14.

Definition dot_mul (w : t) (d : AccountDigits.t) : {r : t | forall n : Fin.t 14, r[@n] = w[@n] * (digit_value d[@n])}.
  remember (as_vector_z d)    as d1  eqn: Heqd1.
  remember (proj1_sig d1)     as v   eqn: Heq1.
  remember (proj2_sig d1)     as Hd1 eqn: Heq2.
  remember (fun a b => a * b) as f   eqn: Heqf.
  refine (exist _ (map2 f w v) _).
  intros n.
  rewrite <- (Hd1 n).
  rewrite <- Heq1.
  now apply VectorSpec.nth_map2.
Defined.

Definition sum (weights : t) :
    {total : Z | forall (u v w x y z a b c d e f g h : Z), weights = [u; v; w; x; y; z; a; b; c; d; e; f; g; h] ->
                    total = u + v + w + x + y + z + a + b + c + d + e + f + g + h}.
  refine (exist _ (fold_left Z.add 0 weights) _).
  intros; subst weights.
  now unfold fold_left.
Defined.

Section Sum_digits.

(*  Definition sum_digits : Z -> Z :=
*)

End Sum_digits.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defcollinear_1 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_2 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_3 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_4 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_5 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_6 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_7 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_inequalitysymmetric_8 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_extension_9 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable defsameside_10 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_11 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).

Theorem lemma_samesidereflexive_12 : (forall A B P : Universe, (~(col_ A B P) -> oS_ P P A B)).
Proof.
  time tac.
Qed.

End FOFProblem.