Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list.

Require Import Mmx.ast_instructions.
Require Import Mmx.binary.

(* (* functions to encode decode instructions *) *)
(* (* TODO :: Here this function can't be call for immediate *) *)
(*=operand_to_bin *)

Definition operand_to_bin (o : operande) : option (list bool) :=
  match o with
  | imm_o (imm k) => n_bit 8 k
  | reg_o (reg k) => n_bit 8 k
  end.
(*=End *)
(*=operand_to_bin_double *)
Definition operand_to_bin_double (o : operande) : option (list bool) :=
  (*=End *)
  match o with
  | imm_o (imm k) => n_bit 16 k
  | reg_o (reg k) => n_bit 16 k
  end.

(* -----------------------------------now for instr_operande_t_n ----------------------------------*)
(*=operand_to_bin_hypothesis_reg *)
Lemma operand_to_bin_hypothesis_reg : forall (l : list bool) (r : register),
    operand_to_bin (reg_o r) = Some l -> reg (bit_n l) = r.
(*=End *)
Proof.
  intros.
  unfold operand_to_bin in H.
  destruct r.
  Search (n_bit).
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

(*=operand_to_bin_hypothesis_imm *)
Lemma operand_to_bin_hypothesis_imm : forall (l : list bool) (i : imediate),
    operand_to_bin (imm_o i) = Some l -> imm (bit_n l) = i.
(*=End *)
Proof.
  intros.
  unfold operand_to_bin in H.
  destruct i.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_double_hypothesis_reg : forall (l : list bool) (r : register),
    operand_to_bin_double (reg_o r) = Some l -> reg (bit_n l) = r.
Proof.
  intros.
  unfold operand_to_bin_double in H.
  destruct r.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_double_hypothesis_imm : forall (l : list bool) (i : imediate),
    operand_to_bin_double (imm_o i) = Some l -> imm (bit_n l) = i.
Proof.
  intros.
  unfold operand_to_bin_double in H.
  destruct i.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

(* -----------------------------------Other operand_to_bin lemma ----------------------------------*)
(*=operand_to_bin_size *)
Lemma operand_to_bin_size : forall (o : operande) (l : list bool),
    operand_to_bin o = Some l -> length l = 8.
(*=End *)
Proof.
  destruct o.
  -unfold operand_to_bin.
   intros l H.
   destruct i in H.
   apply size_n_bit in H.
   rewrite H.
   reflexivity.
   -unfold operand_to_bin.
    intros l H.
    destruct r in H.
    apply size_n_bit in H.
    rewrite H.
    reflexivity.
Qed.

Lemma operand_to_bin_double_size : forall (o : operande) (l : list bool),
    operand_to_bin_double o = Some l -> length l = 16.
Proof.
  destruct o.
  -unfold operand_to_bin.
   intros l H.
   destruct i in H.
   apply size_n_bit in H.
   rewrite H.
   reflexivity.
   -unfold operand_to_bin.
    intros l H.
    destruct r in H.
    apply size_n_bit in H.
    rewrite H.
    reflexivity.
Qed.

(* HERE i don't make any garantee about the result if the binary_instruction is to small but i will have some lemma to give it *)
(*=get_first_n_bit *)
Fixpoint get_first_n_bit  (bi : list bool) (size : nat) : (list bool*list bool) :=
  match size with
  | 0 => ([],bi)
  | S n => match bi with
           | h :: tl => match get_first_n_bit tl n with
                        | (l1,l2) => (h :: l1,l2)
                        end
           | [] => ([],[])
           end
  end.
(*=End *)
Definition testList := [true ; false ; true ; false ; false ; false ; true ; true ].
Definition testList' := [true ; false ; true].

Lemma get_first_n_bit_size_nil_n : forall (n : nat) (l : list bool), length l = n -> get_first_n_bit l n= (l,[]).
Proof.
  induction n.
  -intros.
   Search (length _ = 0).
   apply length_zero_iff_nil in H.
   rewrite H.
   reflexivity.
  -intros.
   unfold get_first_n_bit.
   destruct l.
   +reflexivity.
   +fold get_first_n_bit.
    assert (get_first_n_bit l n = (l,[])) by (apply IHn; auto).
    rewrite H0.
    reflexivity.
Qed.

Lemma get_first_n_bit_size_tl : forall  (n : nat) (l : list bool) (tl : list bool), length l = n -> get_first_n_bit (l ++ tl) n = (l,tl).
Proof.
  induction n.
  -intros.
   apply length_zero_iff_nil in H.
   rewrite H.
   simpl.
   destruct tl.
   +reflexivity.
   +reflexivity.
  -intros.
   unfold get_first_n_bit.
   destruct l.
   fold get_first_n_bit.
   +discriminate.
   +simpl.
    fold get_first_n_bit.
    assert (get_first_n_bit (l ++ tl) n = (l,tl)).
    {
      apply IHn.
      simpl in H.
      inversion H.
      reflexivity.
    }
    rewrite H0.
    reflexivity.
Qed.

Lemma get_first_n_bit_size_4 : forall (l1 l2 l3 l4 : list bool),
    length l1 = 8 -> get_first_n_bit (l1 ++ l2 ++ l3 ++ l4) 8 = (l1,l2 ++ l3 ++ l4).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl 8 l1 (l2 ++ l3 ++ l4)).
  intros.
  auto.
Qed.

Lemma get_first_n_bit_size_3 : forall (n : nat) (l1 l2 l3 : list bool),
    length l1 = n -> get_first_n_bit (l1 ++ l2 ++ l3) n = (l1,l2 ++ l3).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl n l1 (l2 ++ l3)).
  intros.
  auto.
Qed.

Lemma get_first_n_bit_size_2 : forall (n : nat) (l1 l2 : list bool),
    length l1 = n -> get_first_n_bit (l1 ++ l2) n = (l1,l2).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl n l1 l2).
  intros.
  auto.
Qed.

(* Lemma get_first_n_bit_size : forall (bi : list bool) (size : nat), n < (length bi) -> get_first_n_bit bi n = ( *)

(*=monade *)
Definition M A := option A.

Definition ret {A} (a : A) : M A := Some a.

Definition bind {A B} (ma : M A)(k : A -> M B): M B :=
  match ma with
  | Some a => k a
  | None => None
  end.
(*=End *)
Check bind.

Lemma ret_rewrite : forall (A : Type) (a : A), ret a = Some a.
Proof. intros. unfold ret. reflexivity. Qed.

Lemma bind_rewrite : forall (A B : Type) (ma : M A) (k : A -> M B) (res : B), bind ma k = Some res -> exists (a : A), k a = Some res /\ Some a = ma.
  intros.
  remember ma.
  destruct m.
  -exists a.
   split.
   +rewrite <- H.
    reflexivity.
   +reflexivity.
  -simpl in H.
   discriminate.
Qed.

(* TODO :: to delete but can't find this theorem so proof of it *)
Lemma commut_equal : forall (A : Type) (a b : A), a = b -> b = a.
Proof.
  intros. rewrite H. reflexivity. Qed.

(*=notation *)
Notation "'let!' x ':=' ma 'in' k" := (bind ma (fun x => k)) (at level 30).
(*=End *)

(* TODO :: here i know that i can always get a binary_instruction but some function don't allow me to  *)
(* return a binary_instruction without encapsulate it into an option type *)

Fixpoint encode_o (lt : list op_type) (lo : list operande) : option (list bool) :=
  match lt,lo with
  | [], [] => Some []
  | t :: ty, o :: to =>
    match t, o with
    | imm_t, imm_o (imm v) =>  let! bits := encode_o ty to in
                         let! oi  := n_bit 8 v in
                         let! r := Some(oi ++ bits) in
                         ret r
    | reg_t, reg_o (reg v) =>  let! bits := encode_o ty to in
                         let! oi := n_bit 8 v in
                         let! r := Some(oi ++ bits) in
                         ret r
    | _, _ => None
    end
  | _, _ => None
  end.

Fixpoint encode (ins : instruction) : option binary_instruction :=
  match ins with
  | cinstr (cinstr_s t lt) l =>
    let! k := lookup t encdec in
    let! code := n_bit 8 k in
    let! ops := encode_o lt l in
    ret (code ++ ops)
  end.

Lemma encode_size_neq : forall (lt : list op_type) (lo : list operande),
    length lt <> length lo <-> encode_o lt lo = None.
Admitted.
Lemma encode_size_eq : forall (lt : list op_type) (lo : list operande) (t: list bool),
    length lt = length lo <-> encode_o lt lo = Some t.
Admitted.

(*
(* theese are the encode functions for the different type of instruction *)
(*=encode_t_n *)
Definition encode_t_n (i : instruction_tern_n) : option binary_instruction :=
  let! k := lookup (tag_t_n (i.(instr_opcode_t_n))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_n)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_n)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_n)) in
  ret (code ++ o1 ++ o2 ++ o3).

(*=End *)
Definition encode_t_i (i : instruction_tern_i) : option binary_instruction :=
  let! k := lookup (tag_t_i (i.(instr_opcode_t_i))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i)) in
  ret (code ++ o1 ++ o2 ++ o3).
Definition encode_t_i2 (i : instruction_tern_i2) : option binary_instruction :=
  let! k := lookup (tag_t_i2 (i.(instr_opcode_t_i2))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i2)) in
  let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i2)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_i2)) in
  ret (code ++ o1 ++ o2 ++ o3).
Definition encode_t_i3 (i : instruction_tern_i3) : option binary_instruction :=
  let! k := lookup (tag_t_i3 (i.(instr_opcode_t_i3))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i3)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i3)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_i3)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i4 (i : instruction_tern_i4) : option binary_instruction :=
  let! k := lookup (tag_t_i4 (i.(instr_opcode_t_i4))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i4)) in
  let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i4)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i4)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i5 (i : instruction_tern_i5) : option binary_instruction :=
  let! k := lookup (tag_t_i5 (i.(instr_opcode_t_i5))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i5)) in
  let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i5)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i5)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i6 (i : instruction_tern_i6) : option binary_instruction :=
  let! k := lookup (tag_t_i6 (i.(instr_opcode_t_i6))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i6)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i6)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i6)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_d_n (i : instruction_duo_n) : option binary_instruction :=
  let! k := lookup (tag_d_n (i.(instr_opcode_d_n))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_d_n)) in
  let! o2 := operand_to_bin_double (reg_o i.(instr_operande2_d_n)) in
  ret (code ++ o1 ++ o2).

Definition encode_d_i (i : instruction_duo_i) : option binary_instruction :=
  let! k := lookup (tag_d_i (i.(instr_opcode_d_i))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_d_i)) in
  let! o2 := operand_to_bin_double (imm_o i.(instr_operande2_d_i)) in
  ret (code ++ o1 ++ o2).

Definition encode_d_i2 (i : instruction_duo_i2) : option binary_instruction :=
  let! k := lookup (tag_d_i2 (i.(instr_opcode_d_i2))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_d_i2)) in
  let! o2 := operand_to_bin_double (reg_o i.(instr_operande2_d_i2)) in
  ret (code ++ o1 ++ o2).

Definition encode_d_i3 (i : instruction_duo_i3) : option binary_instruction :=
  let! k := lookup (tag_d_i3 (i.(instr_opcode_d_i3))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_d_i3)) in
  let! o2 := operand_to_bin_double (imm_o i.(instr_operande2_d_i3)) in
  ret (code ++ o1 ++ o2).

Definition encode_u (i : instruction_uno) : option binary_instruction :=
  let! k := lookup (tag_u (i.(instr_opcode_s))) encdec in
  let! code := n_bit 8 k in
  match (i.(instr_operande)) with
  | imm im => let! o := n_bit 24 im in
              ret (code ++ o)
  end.

(* now the general encode function which take a general instruction *)

(*=encode *)
Definition encode (i : instruction) : option binary_instruction :=
  match i with
  | instr_t_n t => encode_t_n t
  | instr_t_i t => encode_t_i t
  | instr_t_i2 t => encode_t_i2 t
  | instr_t_i3 t => encode_t_i3 t
  | instr_t_i4 t => encode_t_i4 t
  | instr_t_i5 t => encode_t_i5 t
  | instr_t_i6 t => encode_t_i6 t
  | instr_d_n t => encode_d_n t
  | instr_d_i t => encode_d_i t
  | instr_d_n2 t => encode_d_i2 t
  | instr_d_n3 t => encode_d_i3 t
  | instr_u t => encode_u t
  end.
(*=End *)

*)

(* this is the decode function (with this one we only need one general function) *)
(*=decode *)
(* FIXME : maybe need to type encode and decode by (M (list operande)) * binary_instruction*)
Fixpoint decode_sig (lt : list op_type) (bi : binary_instruction) : M (list operande) :=
  match lt, get_first_n_bit bi 8 with
  | imm_t::tl, (li, next) =>
    let! lr := decode_sig tl next in
    ret ( imm_o (imm (bit_n li)) :: lr)
  | reg_t::tl, (li, next) =>
    let! lr := decode_sig tl next in
    ret ( reg_o (reg (bit_n li)) :: lr)
  | [], _ => ret ( [] )
  end
  .

Definition decode (bi : binary_instruction) : M (instruction) :=
  match get_first_n_bit bi 8 with
  | (li,next) => let! t := lookdown (bit_n li) encdec in
                 match t with
                 | tg =>
                   let! lo := lookup_sig tg sig_dico in
                   let! li := decode_sig lo next in
                   ret (cinstr (cinstr_s t lo) li )
                 end
  end
.
(*
Definition decode (bi : binary_instruction) : option instruction :=
  if length bi =? 32
  then
  match get_first_n_bit bi 8 with
  | (li,next) => let! t := lookdown (bit_n li) encdec in
                 match t with
                 | tag_u u =>
                   match get_first_n_bit next 24 with
                   | (op,[]) =>
                     ret (instr_u (mk_instr_uno u (imm (bit_n op))))
                   | _ => None
                   end
(*=End *)
                          | tag_t_n tn =>
                            match get_first_n_bit next 8 with
                            | (op1,next) =>match get_first_n_bit next 8 with
                                           | (op2,next) => match get_first_n_bit next 8 with
                                                           | (op3,[]) =>
                                                             ret (instr_t_n (mk_instr_t_n tn
                                                                                (reg (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                           | _ => None
                                                           end
                                           end
                            end
                            | tag_t_i ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i (mk_instr_t_i ti
                                                                                (reg (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i2 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                               | (op2,next) => match get_first_n_bit next 8 with
                                                               | (op3,[]) =>
                                                                 ret (instr_t_i2 (mk_instr_t_i2 ti
                                                                                (reg (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                               | _ => None
                                                               end
                                             end
                              end
                            | tag_t_i3 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i3 (mk_instr_t_i3 ti
                                                                                (imm (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i4 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i4 (mk_instr_t_i4 ti
                                                                                (reg (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i5 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i5 (mk_instr_t_i5 ti
                                                                                (imm (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i6 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i6 (mk_instr_t_i6 ti
                                                                                (imm (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_d_i di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_i (mk_instr_d_i di
                                                                            (reg (bit_n op1))
                                                                            (imm (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_i2 di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n2 (mk_instr_d_i2 di
                                                                              (imm (bit_n op1))
                                                                              (reg (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_i3 di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n3 (mk_instr_d_i3 di
                                                                              (imm (bit_n op1))
                                                                              (imm (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_n dn =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n (mk_instr_d_n dn
                                                                            (reg (bit_n op1))
                                                                            (reg (bit_n op2))))
                                             | _ => None
                                             end
                              end
                          end
  end
  else None.
*)

(* little test (this is the end of the file) *)

(* flux d'instruction il faut faire une fonction qui decode le debut de la liste et retourne la suite de la liste *)
Print fold_right.

(* flux d'instruction il faut faire une fonction qui decode le debut de la liste et retourne la suite de la liste *)
Print fold_right.
(*=cut_32 *)
Fixpoint cut32_n (n : nat) (l : list bool) : (list (list bool)) :=
  match n with
  | 0 => []
  | S n' => (firstn 32 l) :: (cut32_n n' (skipn 32 l))
  end.

Definition cut32 (l : list bool) : option (list (list bool)) :=
  let n := length l in
  if n mod 32 =? 0 then Some (cut32_n (n / 32) l) else None.
(*=End *)

(* i make the option choice because it's easyer for the proof *)
(*=concat_listes_32 *)
Fixpoint concat_listes_32 (l : list (list bool)) : option (list bool) :=
  match l with
  | [] => Some []
  | h :: tl => let! res := concat_listes_32 tl in
               if length h =? 32 then Some (h ++ res)
               else None
end.
(*=End *)

Definition test_liste := [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true].
Compute length test_liste.
Definition test_liste2 := [false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false].
Compute length test_liste2.

Fixpoint check_length_32 (l : list (list bool)) : bool :=
  match l with
  | [] => true
  | l' :: tl => (length l' =? 32) && check_length_32 tl
  end.

(* other way to define encode_flux*)
(*=traverse *)
Fixpoint traverse {A} (l : list (option A)) : option (list A) :=
  match l with
  | [] => Some []
  | (Some e) :: tl => match traverse tl with
                      | Some l => Some (e :: l)
                      | None => None
                      end
  | None :: _ => None
  end.
(*=End *)
(* encode_flux definitions *)
(*=encode_flux *)

(* TODO NEED TO FINISH FLUX *)
(*

Definition encode_flux_opt
   (li : list instruction) : list (option binary_instruction) :=
  map encode li.
Definition encode_flux
   (li : list instruction) : option (list binary_instruction) :=
  traverse (encode_flux_opt li).

Definition encode_flux_b (li : list instruction) : option (list bool) :=
  match encode_flux li with
  | None => None
  | Some res => concat_listes_32 res
  end.
(*=End *)

(*=decode_flux *)
Definition decode_flux_opt (lbi : list binary_instruction) : list (option instruction) :=
  map decode lbi.
Definition decode_flux_decoup (lbi : list binary_instruction) : option (list instruction) :=
  traverse (decode_flux_opt lbi).
Definition decode_flux (lb : list bool) : option (list instruction) :=
  let! lbi := cut32 lb in
  decode_flux_decoup lbi.
(*=End *)

(* Some little tests about encode and decode_flux *)

Definition my_instr := instr_t_n (mk_instr_t_n AND (reg 10) (reg 11) (reg 12)).
Definition my_instr2 := instr_t_n (mk_instr_t_n ADD (reg 1) (reg 2) (reg 3)).
Definition my_instr_liste := [my_instr;my_instr;my_instr;my_instr2].

Compute traverse (encode_flux_opt my_instr_liste).

Definition my_instr_list_encoded_decoded' := match encode_flux my_instr_liste with
                                      | Some lol => decode_flux_decoup lol
                                      | None => None
                                            end.
Compute my_instr_list_encoded_decoded'.

Definition my_instr_list_encoded_decoded := match encode_flux_b my_instr_liste with
                                      | Some lol => decode_flux lol
                                      | None => None
                                             end.
Compute my_instr_list_encoded_decoded.
(* it seem's to work *)

*)


Require Import Arith Div2 List.
Require Import BellantoniCook.Lib BellantoniCook.Bitstring BellantoniCook.Cobham BellantoniCook.CobhamLib.

Opaque bs2nat.
Opaque Cond.

Lemma bs2nat_smash' : forall u v n,
  bs2nat v = power 2 n ->
  bs2nat (smash' u v) = power 2 (length u + n).
Proof.
  induction u; simpl; intros; auto.
  rewrite bs2nat_false, (IHu v n); trivial.
Qed.

Lemma bs2nat_smash_bs : forall u v,
  bs2nat (smash_bs u v) = power 2 (length u * length v).
Proof.
  induction u; simpl; intros; auto.
  rewrite bs2nat_smash' with (n := length u * length v); trivial.
Qed.

Lemma Smash_correct : forall l,
  bs2nat (Sem Smash l) = power 2 (length (hd nil l) * length (hd nil (tl l))).
Proof.
  intros [ | u [ | v l] ]; trivial; simpl.
  rewrite mult_0_r; simpl.
  induction u as [ | [ | ] u IH]; trivial.
  apply bs2nat_smash_bs.
Qed.

Lemma Zero_correct_bs n l:
  Sem (Zero_e n) l = nil.
Proof.
  trivial.
Qed.

Lemma Zero_correct n l:
  bs2nat (Sem (Zero_e n) l) = 0.
Proof.
  trivial.
Qed.

Definition False_e n :=
  Comp n (Succ false) [Zero_e n].

Lemma arity_False: forall n : nat, arity (False_e n) = ok_arity n.
Proof.
  simpl; simpl.
  intros.
  rewrite <- beq_nat_refl.
  simpl.
  trivial.
Qed.

Lemma rec_bounded_False: forall n : nat, rec_bounded (False_e n).
Proof.
 intros; simpl; intuition.
Qed.

Lemma False_correct: forall (n : nat) (l : list bs), bs2nat (Sem (False_e n) l) = 0.
Proof.
 intros; simpl; auto.
Qed.

Lemma False_correct_bs: forall (n : nat) (l : list bs), Sem (False_e n) l = [false].
Proof.
 intros; simpl; auto.
Qed.

Lemma One_correct n l:
  bs2nat (Sem (One_e n) l) = 1.
Proof.
  trivial.
Qed.

Lemma One_correct_bs n l:
  Sem (One_e n) l = [true].
Proof.
  trivial.
Qed.

Opaque Zero_e One_e False_e Rev_e RemoveLSZ_e.

Definition Normalize_e : Cobham :=
  Comp 1 Rev_e [Comp 1 RemoveLSZ_e [Rev_e]].

Lemma arity_Normalize :
  arity Normalize_e = ok_arity 1.
Proof.
  trivial.
Qed.

Lemma rec_bounded_Normalize :
  rec_bounded Normalize_e.
Proof.
  simpl; intuition.
  apply rec_bounded_Rev.
  apply rec_bounded_RemoveLSZ.
  apply rec_bounded_Rev.
Qed.

Lemma Normalize_correct : forall l,
  bs2nat (Sem Normalize_e l) = bs2nat (Sem (Proj 1 0) l).
Proof.
  destruct l as [ | v l]; trivial;simpl.
  induction v as [ | [ | ] v IH]; trivial.

  rewrite bs2nat_true.
  do 2 rewrite Rev_correct in *; simpl in *.
  rewrite RemoveLSZ_app, <- IH.
  destruct (Sem RemoveLSZ_e [rev v]); trivial; simpl.
  rewrite rev_unit; trivial.

  rewrite bs2nat_false.
  do 2 rewrite Rev_correct in *; simpl in *.
  rewrite RemoveLSZ_app, <- IH.
  destruct (Sem RemoveLSZ_e [rev v]); trivial; simpl.
  rewrite rev_unit; trivial.
Qed.

Lemma Normalize_normal : forall l,
  Sem Normalize_e l = nil \/ bs2nat (Sem Normalize_e l) <> 0.
Proof.
  destruct l as [ | v l].
  tauto.
  simpl.
  induction v as [ | [ | ] v IH].

  tauto.

  do 2 rewrite Rev_correct in *.
  simpl in *.
  rewrite RemoveLSZ_app.
  destruct (Sem RemoveLSZ_e [rev v]).
  right.
  discriminate.
  right.
  simpl.
  rewrite rev_unit.
  discriminate.

  do 2 rewrite Rev_correct in *.
  simpl in *.
  rewrite RemoveLSZ_app.
  destruct (Sem RemoveLSZ_e [rev v]).
  trivial.
  simpl in *.
  rewrite rev_unit.
  simpl.
  right.
  rewrite bs2nat_false.
  destruct IH as [IH | IH].
  apply app_eq_nil in IH.
  destruct IH as [_ IH].
  congruence.
  omega.
Qed.

Opaque Normalize_e.

(** Def 1 of (Rose) *)

Definition Succ_e : Cobham :=
  Rec
    (Comp 0 (Succ true) [Zero])
    (Comp 2 (Succ true) [Proj 2 0])
    (Comp 2 (Succ false) [Proj 2 1])
    (Comp 1 (Succ true) [Proj 1 0]).

Lemma arity_Succ : arity Succ_e = ok_arity 1.
Proof.
  trivial.
Qed.

Lemma length_Succ : forall l,
  length (Sem Succ_e l) <= length (Sem (Comp 1 (Succ true) [Proj 1 0]) l).
Proof.
  destruct l as [ | v l]; trivial; simpl.
  induction v as [ | [ | ] v IH]; trivial; simpl; omega.
Qed.

Lemma le_1_length_Succ v :
  1 <= length (Sem Succ_e [v]).
Proof.
  destruct v as [ | [ | ] v]; trivial; simpl; omega.
Qed.

Lemma le_length_Succ v :
  length v <= length (Sem Succ_e [v]).
Proof.
induction v as [ | [ | ] v IH].
simpl; omega.
simpl in *.
omega.
trivial.
Qed.

Lemma Succ_length v :
  length (Sem Succ_e v) <= S (length (hd nil v)).
Proof.
 intros; simpl.
 induction (hd nil v); simpl; auto.
 case a; simpl; omega.
Qed.

Lemma rec_bounded_Succ :
  rec_bounded Succ_e.
Proof.
 simpl; intuition.
 eapply le_trans.
 eapply le_trans.
 2:apply length_Succ.
 simpl; trivial.
 trivial.
Qed.

Lemma Succ_correct : forall l,
  bs2nat (Sem Succ_e l) = 1 + bs2nat (hd nil l).
Proof.
  destruct l as [ | v l]; trivial; simpl hd.
  induction v as [ | [ | ] v IH]; trivial.
  simpl Sem in *.
  rewrite bs2nat_false, bs2nat_true, IH; ring.
Qed.

Opaque Succ_e.

(** Def 2 of (Rose) *)

Definition Pred'_e : Cobham :=
  Rec
    Zero
    (Comp 2 (Succ true) [Proj 2 1])
    (Comp 2 (Succ false) [Proj 2 0])
    (Proj 1 0).

Lemma arity_Pred' : arity Pred'_e = ok_arity 1.
Proof.
  trivial.
Qed.

Lemma rec_bounded_Pred' :
  rec_bounded Pred'_e.
Proof.
  simpl.
  intuition.
  destruct l as [ | v l].
  trivial.
  simpl.
  induction v as [ | [ | ] v IH].
  trivial.
  trivial.
  simpl; omega.
Qed.

Lemma Pred'_correct : forall l,
  hd nil l = nil \/ bs2nat (hd nil l) <> 0 ->
  bs2nat (Sem Pred'_e l) =  bs2nat (hd nil l) - 1.
Proof.
intros l H.
destruct l as [ | v l].
simpl.
trivial.
simpl hd.
induction v as [ | [ | ] v IH].

trivial.

simpl Sem in *.
rewrite bs2nat_false, bs2nat_true.
omega.

simpl Sem in *.
rewrite bs2nat_false, bs2nat_true, IH.
simpl in H.
destruct H as [H | H].
congruence.
rewrite bs2nat_false in H.
omega.
simpl in *.
destruct H as [H | H].
congruence.
rewrite bs2nat_false in H.

simpl in H.
right.
omega.
Qed.

Opaque Pred'_e.

Definition Pred_e : Cobham :=
  Comp 1 Pred'_e [Normalize_e].

Lemma arity_Pred : arity Pred_e = ok_arity 1.
Proof.
trivial.
Qed.

Lemma rec_bounded_Pred :
  rec_bounded Pred_e.
Proof.
simpl.
intuition.
apply rec_bounded_Pred'.
apply rec_bounded_Normalize.
Qed.

Lemma Pred_correct : forall l,
  bs2nat (Sem Pred_e l) =  bs2nat (hd nil l) - 1.
Proof.
intro l.
simpl.
rewrite Pred'_correct.
simpl.
rewrite Normalize_correct.
simpl.
rewrite hd_nth_0.
trivial.
apply Normalize_normal.
Qed.

Opaque Pred_e.

(** Def 3 of (Rose) *)

Definition OneMinus'_e : Cobham :=
  Rec2
    (One_e 0)
    (Zero_e 2)
    (One_e 1).

Lemma arity_OneMinus' : arity OneMinus'_e = ok_arity 1.
Proof.
trivial.
Qed.

Lemma rec_bounded_OneMinus' :
  rec_bounded OneMinus'_e.
Proof.
simpl.
intuition.
apply rec_bounded_One.
apply rec_bounded_One.
apply rec_bounded_Zero.
apply rec_bounded_Zero.
destruct l as [ | v l].
trivial.
simpl.
induction v as [ | [ | ] v IH].
trivial.
auto with arith.
auto with arith.
Qed.

Lemma OneMinus'_correct : forall l,
  hd nil l = nil \/ bs2nat (hd nil l) <> 0 ->
  bs2nat (Sem OneMinus'_e l) = 1 - bs2nat (hd nil l).
Proof.
intros [ | v l] H.
trivial.
simpl hd.
destruct v as [ | [ | ] v].
trivial.
trivial.
simpl Sem in *.
simpl in *.
rewrite Zero_correct.
rewrite bs2nat_false in *.
destruct H as [H | H].
congruence.
destruct (2 * bs2nat v).
tauto.
trivial.
Qed.

Opaque OneMinus'_e.

Definition OneMinus_e : Cobham :=
  Comp 1 OneMinus'_e [Normalize_e].

Lemma arity_OneMinus : arity OneMinus_e = ok_arity 1.
Proof.
trivial.
Qed.

Lemma rec_bounded_OneMinus :
  rec_bounded OneMinus_e.
Proof.
simpl.
intuition.
apply rec_bounded_OneMinus'.
apply rec_bounded_Normalize.
Qed.

Lemma OneMinus_correct : forall l,
  bs2nat (Sem OneMinus_e l) = 1 - bs2nat (hd nil l).
Proof.
intro l.
simpl.
rewrite OneMinus'_correct.
simpl.
rewrite Normalize_correct.
simpl.
rewrite hd_nth_0.
trivial.
apply Normalize_normal.
Qed.

Opaque OneMinus_e.

(** Def 4 of (Rose) *)

Definition Div2_e : Cobham :=
  Rec2
    Zero
    (Proj 2 0)
    (Proj 1 0).

Lemma arity_Div2 : arity Div2_e = ok_arity 1.
Proof.
trivial.
Qed.

Lemma length_Div2 : forall l,
  length (Sem Div2_e l) = length (hd nil l) - 1.
Proof.
destruct l as [ | v l].
trivial.
simpl.
induction v as [ | [ | ] v IH].
trivial.
simpl; omega.
simpl; omega.
Qed.

Lemma rec_bounded_Div2 :
  rec_bounded Div2_e.
Proof.
simpl.
intuition.
destruct l as [ | v l].
trivial.
simpl.
destruct v as [ | [ | ] v].
trivial.
simpl; omega.
simpl; omega.
Qed.

Lemma Div2_correct_bs : forall l,
  Sem Div2_e l =
  tl (hd nil l).
Proof.
destruct l as [ | v l].
trivial.
simpl.
destruct v as [ | [ | ] v]; trivial.
Qed.

Lemma Div2_correct : forall l,
  bs2nat (Sem Div2_e l) = div2 (bs2nat (hd nil l)).
Proof.
intros [ | v l].
trivial.
rewrite Div2_correct_bs.
simpl.
apply bs2nat_tl.
Qed.

Opaque Div2_e.

(** Def 5 of (Rose) *)

Definition Mod2_e : Cobham :=
  Rec
    Zero
    (False_e 2)
    (One_e 2)
    (One_e 1).

Lemma arity_Mod2 : arity Mod2_e = ok_arity 1.
Proof.
simpl.
trivial.
Qed.

Lemma rec_bounded_Mod2 :
  rec_bounded Mod2_e.
Proof.
simpl.
intuition.
apply rec_bounded_One.
apply rec_bounded_False.
apply rec_bounded_One.
destruct l as [ | v l].
simpl; omega.
simpl.
induction v as [ | [ | ] v IH].
simpl; omega.
auto with arith.
auto with arith.
Qed.

Lemma Mod2_correct_bs : forall l,
  (hd nil l) <> nil ->
  Sem Mod2_e l = [hd true (hd nil l)].
Proof.
  intros.
  simpl.
  destruct (hd nil l); simpl; trivial.
  elim H; trivial.
  case b.
  rewrite One_correct_bs.
  trivial.
  rewrite False_correct_bs.
  trivial.
Qed.

Lemma Mod2_correct : forall l,
  bs2nat (Sem Mod2_e l) = mod2 (bs2nat (hd nil l)).
Proof.
unfold mod2.
destruct l as [ | v l].
trivial.
simpl hd.
destruct v as [ | [ | ] v].
trivial.
simpl Sem in *.
rewrite One_correct, bs2nat_true.
change (1 + 2 * bs2nat v) with (S (2 * bs2nat v)).
rewrite div2_double_plus_one.
omega.
simpl Sem in *.
rewrite bs2nat_false.
rewrite div2_double.
auto with arith.
Qed.

Opaque Mod2_e.

(** Def 6 of (Rose) *)

Definition Length_e : Cobham :=
  Rec2
    Zero
    (Comp 2 Succ_e [Proj 2 1])
    (Proj 1 0).

Lemma arity_Length : arity Length_e = ok_arity 1.
Proof.
  trivial.
Qed.

Lemma rec_bounded_Length :
  rec_bounded Length_e.
Proof.
simpl.
intuition.
apply rec_bounded_Succ.
apply rec_bounded_Succ.
destruct l as [ | v l].
trivial.
simpl.
induction v as [ | [ | ] v IH].
trivial.
simpl.
eapply le_trans.
apply length_Succ.
simpl; omega.
simpl.
eapply le_trans.
apply length_Succ.
simpl; omega.
Qed.

Lemma Length_correct : forall l,
  bs2nat (Sem Length_e l) = length (hd nil l).
Proof.
destruct l as [ | v l].
trivial.
simpl hd.
induction v as [ | [ | ] v IH].
trivial.
simpl.
rewrite Succ_correct.
simpl.
f_equal.
trivial.
simpl.
rewrite Succ_correct.
simpl.
f_equal.
trivial.
Qed.

Opaque Length_e.

(** Def 7 of (Rose) *)

Definition MultOneMinus'_e : Cobham :=
  Comp 2 Cond [
    Proj 2 1;
    Proj 2 0;
    Zero_e 2;
    Zero_e 2
  ].

Lemma arity_MultOneMinus' : arity MultOneMinus'_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_MultOneMinus' :
  rec_bounded MultOneMinus'_e.
Proof.
simpl.
intuition.
apply rec_bounded'_spec with 4.
apply arity_Cond.
apply rec_bounded_Cond.
apply rec_bounded_Zero.
apply rec_bounded_Zero.
Qed.

Lemma MultOneMinus'_correct : forall l,
  hd nil (tl l) = nil \/ bs2nat (hd nil (tl l)) <> 0 ->
  bs2nat (Sem MultOneMinus'_e l) = bs2nat (hd nil l) * (1 - bs2nat (hd nil (tl l))).
Proof.
intros [ | u [ | v l] ] H.
trivial.
auto with arith.
simpl.
rewrite Cond_correct.
simpl in *.
destruct v as [ | [ | ] v].
auto with arith.
trivial.
rewrite Zero_correct.
rewrite bs2nat_false in *.
destruct (2 * bs2nat v).
destruct H.
congruence.
tauto.
trivial.
Qed.

Opaque MultOneMinus'_e.

Definition MultOneMinus_e : Cobham :=
  Comp 2 MultOneMinus'_e [Proj 2 0; Comp 2 Normalize_e [Proj 2 1]].

Lemma arity_MultOneMinus : arity MultOneMinus_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_MultOneMinus :
  rec_bounded MultOneMinus_e.
Proof.
simpl.
intuition.
apply rec_bounded_MultOneMinus'.
apply rec_bounded_Normalize.
Qed.

Lemma MultOneMinus_correct : forall l,
  bs2nat (Sem MultOneMinus_e l) = bs2nat (hd nil l) * (1 - bs2nat (hd nil (tl l))).
Proof.
intro l.
simpl.
rewrite MultOneMinus'_correct.
simpl.
rewrite Normalize_correct.
simpl.
rewrite hd_nth_1, hd_nth_0.
trivial.
simpl.
apply Normalize_normal.
Qed.

Opaque MultOneMinus_e.

(** Def 8 of (Rose) *)

Definition PlusOneMinus'_e : Cobham :=
  Comp 2 Cond [
    Proj 2 1;
    Comp 2 Succ_e [Proj 2 0];
    Proj 2 0;
    Proj 2 0
  ].

Lemma arity_PlusOneMinus' : arity PlusOneMinus'_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_PlusOneMinus' :
  rec_bounded PlusOneMinus'_e.
Proof.
simpl.
intuition.
apply rec_bounded'_spec with 4.
apply arity_Cond.
apply rec_bounded_Cond.
apply rec_bounded_Succ.
Qed.

Lemma PlusOneMinus'_correct : forall l,
  hd nil (tl l) = nil \/ bs2nat (hd nil (tl l)) <> 0 ->
  bs2nat (Sem PlusOneMinus'_e l) = bs2nat (hd nil l) + (1 - bs2nat (hd nil (tl l))).
Proof.
intros [ | u [ | v l] ] H.
trivial.
simpl.
rewrite Cond_correct.
simpl.
rewrite Succ_correct, bs2nat_nil.
simpl; ring.
simpl.
rewrite Cond_correct.
simpl.
destruct v as [ | [ | ] v].
rewrite Succ_correct, bs2nat_nil.
simpl; ring.
trivial.
simpl in H.
rewrite bs2nat_false in *.
destruct (2 * bs2nat v).
destruct H.
congruence.
tauto.
trivial.
Qed.

Lemma PlusOneMinus'_length : forall l,
  length (Sem PlusOneMinus'_e [nth 0 l nil; Sem Normalize_e [nth 1 l nil]])
  <= S (length (hd nil l)).
Proof.
 intros; simpl.
 rewrite Cond_correct; simpl.
 rewrite hd_nth_0.
 destruct (Sem Normalize_e [nth 1 l nil]); auto.
 apply Succ_length.
 case b; auto.
Qed.

Opaque PlusOneMinus'_e.

Definition PlusOneMinus_e : Cobham :=
  Comp 2 PlusOneMinus'_e [Proj 2 0; Comp 2 Normalize_e [Proj 2 1] ].

Lemma arity_PlusOneMinus : arity PlusOneMinus_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_PlusOneMinus :
  rec_bounded PlusOneMinus_e.
Proof.
simpl.
intuition.
apply rec_bounded_PlusOneMinus'.
apply rec_bounded_Normalize.
Qed.

Lemma PlusOneMinus_correct : forall l,
  bs2nat (Sem PlusOneMinus_e l) = bs2nat (hd nil l) + (1 - bs2nat (hd nil (tl l))).
Proof.
intro l.
simpl.
rewrite PlusOneMinus'_correct.
simpl.
rewrite Normalize_correct.
simpl.
rewrite hd_nth_1, hd_nth_0.
trivial.
simpl.
apply Normalize_normal.
Qed.

Lemma PlusOneMinus_length : forall l,
  length (Sem PlusOneMinus_e [nth 0 l nil; nth 1 l nil]) <= S (length (nth 0 l nil)).
Proof.
 intros; simpl.
 rewrite <- hd_nth_0 at 2.
 apply PlusOneMinus'_length.
Qed.

Opaque PlusOneMinus_e.

(** Def 9 of (Rose) *)

Definition OneMinusMultPlus'_e : Cobham :=
  Rec
    (Proj 1 0)
    (Comp 3 (Succ false) [Proj 3 0])
    (Comp 3 (Succ true) [Proj 3 0])
    (Comp 2 Smash [Comp 2 Succ_e [Proj 2 1]; Comp 2 (Succ true) [Proj 2 0]]).

Lemma arity_OneMinusMultPlus' : arity OneMinusMultPlus'_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_OneMinusMultPlus' :
  rec_bounded OneMinusMultPlus'_e.
Proof.
simpl.
intuition.
apply rec_bounded_Succ.
destruct l as [ | v l].
simpl; omega.
simpl.
induction v as [ | [ | ] v IH]; simpl.
rewrite length_smash.
simpl.
rewrite mult_1_r.
eapply le_trans; [idtac | apply le_n_S; apply le_length_Succ].
omega.
rewrite length_smash.
simpl.
apply le_n_S.
rewrite <- (mult_1_l (length v)).
apply mult_le_compat.
apply le_1_length_Succ.
omega.
rewrite length_smash.
simpl.
apply le_n_S.
rewrite <- (mult_1_l (length v)).
apply mult_le_compat.
apply le_1_length_Succ.
omega.
Qed.

Lemma OneMinusMultPlus'_correct : forall l,
  hd nil l = nil \/ bs2nat (hd nil l) <> 0 ->
  bs2nat (Sem OneMinusMultPlus'_e l) =
  (1 - bs2nat (hd nil l)) * bs2nat (hd nil (tl l)) +
  bs2nat (hd nil l) * (1 - (1 - bs2nat (hd nil l))).
Proof.
intros [ | v l] H.
trivial.
simpl.
destruct v as [ | [ | ] v]; simpl.
rewrite bs2nat_nil, hd_nth_0.
ring.
rewrite bs2nat_true.
simpl; ring.
simpl in *.
rewrite bs2nat_false in *.
destruct (2 * bs2nat v).
destruct H.
congruence.
tauto.
ring.
Qed.

Opaque OneMinusMultPlus'_e.

Definition OneMinusMultPlus_e : Cobham :=
  Comp 2 OneMinusMultPlus'_e [Comp 2 Normalize_e [Proj 2 0]; Proj 2 1].

Lemma arity_OneMinusMultPlus : arity OneMinusMultPlus_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_OneMinusMultPlus :
  rec_bounded OneMinusMultPlus_e.
Proof.
simpl.
intuition.
apply rec_bounded_OneMinusMultPlus'.
apply rec_bounded_Normalize.
Qed.

Lemma OneMinusMultPlus_correct : forall l,
  bs2nat (Sem OneMinusMultPlus_e l) =
  (1 - bs2nat (hd nil l)) * bs2nat (hd nil (tl l)) +
  bs2nat (hd nil l) * (1 - (1 - bs2nat (hd nil l))).
Proof.
intro l.
simpl.
rewrite OneMinusMultPlus'_correct.
simpl.
rewrite Normalize_correct.
simpl.
rewrite hd_nth_1, hd_nth_0.
trivial.
apply Normalize_normal.
Qed.

Opaque OneMinusMultPlus_e.

(** Def 10 of (Rose) *)

Definition PlusMod2_e : Cobham :=
  Comp 2 Cond [
     Proj 2 1;
     Proj 2 0;
     Comp 2 Succ_e [Proj 2 0];
     Proj 2 0
  ].

Lemma arity_PlusMod2 :
  arity PlusMod2_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_PlusMod2 :
  rec_bounded PlusMod2_e.
Proof.
simpl.
intuition.
apply rec_bounded'_spec with 4.
apply arity_Cond.
apply rec_bounded_Cond.
apply rec_bounded_Succ.
Qed.

Lemma PlusMod2_correct : forall l,
  bs2nat (Sem PlusMod2_e l) =
  bs2nat (hd nil l) + mod2 (bs2nat (hd nil (tl l))).
Proof.
unfold mod2.
intros [ | u [ | v l] ]; simpl.
trivial.
rewrite Cond_correct, bs2nat_nil; simpl.
omega.
rewrite Cond_correct; simpl.
destruct v as [ | [ | ] v].
rewrite bs2nat_nil.
simpl; omega.
rewrite bs2nat_true, Succ_correct.
change (1 + 2 * bs2nat v) with (S (2 * bs2nat v)).
rewrite div2_double_plus_one.
simpl hd; omega.
rewrite bs2nat_false, div2_double.
omega.
Qed.

Opaque PlusMod2_e.

(** Def 11 of (Rose) *)

Definition PlusOneMinusMod2_e : Cobham :=
  Comp 3 Cond [
    Proj 3 2;
    Proj 3 0;
    Comp 3 PlusOneMinus_e [Proj 3 0; Proj 3 1];
    Proj 3 0
  ].

Lemma arity_PlusOneMinusMod2 :
  arity PlusOneMinusMod2_e = ok_arity 3.
Proof.
trivial.
Qed.

Lemma rec_bounded_PlusOneMinusMod2 :
  rec_bounded PlusOneMinusMod2_e.
Proof.
simpl.
intuition.
apply rec_bounded'_spec with 4.
apply arity_Cond.
apply rec_bounded_Cond.
apply rec_bounded_PlusOneMinus.
Qed.

Lemma PlusOneMinusMod2_correct : forall l,
  bs2nat (Sem PlusOneMinusMod2_e l) =
  bs2nat (hd nil l) +
  (1 - bs2nat (hd nil (tl l))) *
  mod2 (bs2nat (hd nil (tl (tl l)))).
Proof.
unfold mod2.
intros [ | u [ | v [ | w l] ] ]; simpl.
trivial.
trivial.
rewrite Cond_correct.
simpl.
rewrite bs2nat_nil.
simpl; ring.
rewrite Cond_correct.
simpl.
destruct w as [ | [ | ] w].
rewrite bs2nat_nil.
simpl; ring.
rewrite PlusOneMinus_correct.
simpl.
rewrite bs2nat_true.
change (1 + 2 * bs2nat w) with (S (2 * bs2nat w)).
rewrite div2_double_plus_one.
case (bs2nat v).
omega.
trivial.
rewrite bs2nat_false.
rewrite div2_double.
case (bs2nat v).
omega.
trivial.
Qed.

Lemma PlusOneMinusMod2_length : forall l,
  length (Sem PlusOneMinusMod2_e l) <= S (length (hd nil l)).
Proof.
 intros; simpl.
 rewrite Cond_correct; simpl.
 rewrite hd_nth_0.
 destruct (nth 2 l nil); auto.
 case b; auto.
 apply PlusOneMinus_length.
Qed.

Opaque PlusOneMinusMod2_e.

(** Def 13 of (Rose) *)

Definition MultTwoPowerLength'_e : Cobham :=
  Rec2
    (Proj 1 0)
    (Comp 3 (Succ false) [Proj 3 1])
    (Comp 2 Smash [Comp 2 (Succ true) [Proj 2 0]; Comp 2 (Succ true) [Proj 2 1] ] ).

(* FIXME: According to Rose (Def 13), 'plus 1' in arguments of Smash are not necessary
 *)

Lemma arity_MultTwoPowerLength' :
  arity MultTwoPowerLength'_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_MultTwoPowerLength' :
  rec_bounded MultTwoPowerLength'_e.
Proof.
simpl.
intuition.
destruct l as [ | u [ | v l] ]; simpl.
omega.
rewrite length_smash; simpl.
rewrite mult_1_r.
induction u as [ | [ | ] u IH]; simpl; omega.
rewrite length_smash', length_smash; simpl.
induction u as [ | [ | ] u IH]; simpl; omega.
Qed.

Lemma MultTwoPowerLength'_correct : forall l,
  bs2nat (Sem MultTwoPowerLength'_e l) =
  power 2 (length (hd nil l)) * bs2nat (hd nil (tl l)).
Proof.
destruct l as [ | u [ | v l] ].
trivial.
simpl.
rewrite bs2nat_nil, mult_0_r.
induction u as [ | [ | ] u IH].
trivial.
simpl.
rewrite bs2nat_false.
omega.
simpl.
rewrite bs2nat_false.
omega.
induction u as [ | [ | ] u IH]; simpl in *.
trivial.
rewrite bs2nat_false, plus_0_r, IH.
ring.
rewrite bs2nat_false, plus_0_r, IH.
ring.
Qed.

Opaque MultTwoPowerLength'_e.

Definition MultTwoPowerLength_e : Cobham :=
  Comp 2 MultTwoPowerLength'_e [Proj 2 1; Proj 2 0].

Lemma arity_MultTwoPowerLength :
  arity MultTwoPowerLength_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_MultTwoPowerLength :
  rec_bounded MultTwoPowerLength_e.
Proof.
simpl.
intuition.
apply rec_bounded_MultTwoPowerLength'.
Qed.

Lemma MultTwoPowerLength_correct : forall l,
  bs2nat (Sem MultTwoPowerLength_e l) =
  bs2nat (hd nil l) * power 2 (length (hd nil (tl l))).
Proof.
intro l.
simpl.
rewrite MultTwoPowerLength'_correct; simpl.
rewrite hd_nth_0, hd_nth_1.
ring.
Qed.

Opaque MultTwoPowerLength_e.

(** Def 14 of (Rose) *)

Definition DivTwoPower'_e : Cobham :=
  Rec2
    (Proj 1 0)
    (Comp 3 Div2_e [Proj 3 1])
    (Proj 2 1).

Lemma arity_DivTwoPower' :
  arity DivTwoPower'_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma length_DivTwoPower' : forall l,
  length (Sem DivTwoPower'_e l) = length (hd nil (tl l)) - length (hd nil l).
Proof.
intros [ | u [ | v l] ].
trivial.
simpl.
induction u as [ | [ | ] u IH].
trivial.
simpl.
rewrite length_Div2.
simpl; omega.
simpl.
rewrite length_Div2.
simpl; omega.
induction u as [ | [ | ] u IH].
simpl; omega.
simpl in *.
rewrite length_Div2.
simpl; omega.
simpl in *.
rewrite length_Div2.
simpl; omega.
Qed.

Lemma rec_bounded_DivTwoPower' :
  rec_bounded DivTwoPower'_e.
Proof.
simpl.
intuition.
apply rec_bounded_Div2.
apply rec_bounded_Div2.
destruct l as [ | u [ | v l] ].
trivial.
simpl.
induction u as [ | [ | ] u IH].
trivial.
simpl.
rewrite length_Div2.
simpl; omega.
simpl.
rewrite length_Div2.
simpl; omega.
induction u as [ | [ | ] u IH].
trivial.
simpl in *.
rewrite length_Div2.
simpl; omega.
simpl in *.
rewrite length_Div2.
simpl; omega.
Qed.

Lemma DivTwoPower'_correct_bs : forall l,
  Sem DivTwoPower'_e l =
  fun_power (length (hd nil l)) (@tl _) (hd nil (tl l)).
Proof.
intros [ | u [ | v l] ].
trivial.
simpl.
induction u as [ | [ | ] u IH].
trivial.
simpl.
rewrite Div2_correct_bs.
simpl; congruence.
simpl.
rewrite Div2_correct_bs.
simpl; congruence.
simpl.
induction u as [ | [ | ] u IH].
trivial.
simpl.
rewrite Div2_correct_bs.
simpl; congruence.
simpl.
rewrite Div2_correct_bs.
simpl; congruence.
Qed.

Lemma DivTwoPower'_correct : forall l,
  bs2nat (Sem DivTwoPower'_e l) =
  fun_power (length (hd nil l)) div2 (bs2nat (hd nil (tl l))).
Proof.
intro l.
rewrite DivTwoPower'_correct_bs.
induction (length (hd nil l)).
trivial.
simpl.
rewrite bs2nat_tl.
congruence.
Qed.

Opaque DivTwoPower'_e.

Definition DivTwoPower_e : Cobham :=
  Comp 2 DivTwoPower'_e [Proj 2 1; Proj 2 0].

Lemma arity_DivTwoPower :
  arity DivTwoPower_e = ok_arity 2.
Proof.
trivial.
Qed.

Lemma rec_bounded_DivTwoPower :
  rec_bounded DivTwoPower_e.
Proof.
simpl.
intuition.
apply rec_bounded_DivTwoPower'.
Qed.

Lemma DivTwoPower_correct_bs : forall l,
  Sem DivTwoPower_e l =
  fun_power (length (hd nil (tl l))) (@tl _) (hd nil l).
Proof.
intro l.
simpl.
rewrite DivTwoPower'_correct_bs.
simpl.
rewrite <- hd_nth_0, <- hd_nth_1.
trivial.
Qed.

Lemma length_DivTwoPower : forall l,
  length (Sem DivTwoPower_e l) = length (hd nil l) - length (hd nil (tl l)).
Proof.
intro l.
simpl.
rewrite length_DivTwoPower'.
simpl.
rewrite <- hd_nth_0, <- hd_nth_1.
trivial.
Qed.

Lemma skipn_tl : forall n (l : bs),
  skipn (S n) l = tl (skipn n l).
Proof.
  intros.
  destruct (le_lt_dec (length l) n).
  rewrite skipn_nil; simpl.
  rewrite skipn_nil; simpl; auto.
  omega.
  rewrite (skipn_hd n l true).
  reflexivity.
  trivial.
Qed.

Lemma DivTwoPower_correct : forall l,
  Sem DivTwoPower_e l =
  skipn (length (nth 1 l nil)) (nth 0 l nil).
Proof.
  intros l.
  simpl.
  rewrite DivTwoPower'_correct_bs; simpl.
  induction (nth 1 l nil); simpl; auto.
  rewrite IHl0.
  destruct (nth 0 l nil); simpl.
  rewrite skipn_nil; simpl; auto.
  omega.
  rewrite <- skipn_tl.
  simpl.
  trivial.
Qed.

Opaque DivTwoPower_e.

(** Def 15 of (Rose) *)

Definition DivDivTwoPower_e : Cobham :=
  Comp 3 DivTwoPower_e [Proj 3 0; Comp 3 DivTwoPower_e [Proj 3 1; Proj 3 2] ].

Lemma arity_DivDivTwoPower :
  arity DivDivTwoPower_e = ok_arity 3.
Proof.
trivial.
Qed.

Lemma rec_bounded_DivDivTwoPower :
  rec_bounded DivDivTwoPower_e.
Proof.
simpl.
intuition.
apply rec_bounded_DivTwoPower.
apply rec_bounded_DivTwoPower.
Qed.

Lemma DivDivTwoPower_correct : forall l,
  Sem DivDivTwoPower_e l =
  skipn (length (nth 1 l nil) - length (nth 2 l nil)) (nth 0 l nil).
Proof.
  intros l.
  simpl.
  rewrite DivTwoPower_correct; simpl.
  rewrite DivTwoPower_correct; simpl.
  f_equal.
  rewrite length_skipn; trivial.
Qed.

Opaque DivDivTwoPower_e.

(** Def 16 of (Rose) *)

Fixpoint Repeat_e (n l : nat) (b : bool) : Cobham :=
  match l with
    | 0 => Zero_e n
    | S l' => Comp n (Succ b) [Repeat_e n l' b]
  end.

Lemma arity_Repeat : forall n len b,
  arity (Repeat_e n len b) = ok_arity n.
Proof.
induction len as [ | len' IH]; simpl; trivial; intros [ | ];
  rewrite IH; simpl; rewrite <- beq_nat_refl; trivial.
Qed.

Lemma rec_bounded_Repeat : forall n len b,
  rec_bounded (Repeat_e n len b).
Proof.
intros n len b.
induction len as [ | len' IH]; simpl.
apply rec_bounded_Zero.
intuition.
Qed.

Lemma length_Repeat : forall n l b l',
  length (Sem (Repeat_e n l b) l') = l.
Proof.
  induction l; simpl; auto.
Qed.

Opaque Repeat_e.

Definition RoseS'_e : Cobham :=
  Rec2
    (Zero_e 2)
    (Comp 4 PlusOneMinusMod2_e [
      Comp 4 (Succ false) [Proj 4 1];
      Comp 4 DivTwoPower_e [Comp 4 DivTwoPower_e [Proj 4 2; Proj 4 0]; Proj 4 3];
      Comp 4 DivDivTwoPower_e [Proj 4 2; Proj 4 2; Comp 4 (Succ false) [Proj 4 0]]
    ])
    (Comp 3 Smash [Proj 3 0; Repeat_e 3 2 true]).

Definition arity_RoseS' :
  arity RoseS'_e = ok_arity 3.
Proof.
trivial.
Qed.

Lemma rec_bounded_RoseS' :
  rec_bounded RoseS'_e.
Proof.
simpl.
intuition.
apply rec_bounded_Repeat.
apply rec_bounded_Zero.
apply rec_bounded_PlusOneMinusMod2.
apply rec_bounded_DivTwoPower.
apply rec_bounded_DivTwoPower.
apply rec_bounded_DivDivTwoPower.
apply rec_bounded_PlusOneMinusMod2.
apply rec_bounded_DivTwoPower.
apply rec_bounded_DivTwoPower.
apply rec_bounded_DivDivTwoPower.
rewrite <- hd_nth_0.
induction (hd nil l); simpl.
rewrite Zero_correct_bs; simpl; auto with arith.
case a.
eapply le_trans.
apply PlusOneMinusMod2_length.
simpl.
rewrite length_smash'.
rewrite length_Repeat.
omega.
eapply le_trans.
apply PlusOneMinusMod2_length.
simpl.
rewrite length_smash'.
rewrite length_Repeat.
omega.
Qed.

Definition RoseS_e : Cobham :=
  Comp 3 RoseS'_e [Proj 3 2; Proj 3 0; Proj 3 1].

Lemma arity_RoseS :
  arity RoseS_e = ok_arity 3.
Proof.
trivial.
Qed.

Opaque RoseS'_e.

Lemma rec_bounded_RoseS :
  rec_bounded RoseS_e.
Proof.
simpl.
intuition.
apply rec_bounded_RoseS'.
Qed.

Transparent RoseS'_e.

Lemma bs2nat_firstn_false : forall n l,
  bs2nat (firstn n (false :: l)) = 2 * bs2nat (firstn (n-1) l).
Proof.
  intros.
  destruct n.
  simpl.
  rewrite bs2nat_nil; ring.
  simpl firstn.
  rewrite bs2nat_false.
  f_equal.
  f_equal.
  f_equal.
  omega.
Qed.

Lemma bs2nat_app : forall l1 l2,
  bs2nat (l1 ++ l2) = bs2nat l1 + bs2nat (repeat (length l1) false ++ l2).
Proof.
 intros.
 induction l1; simpl.
 rewrite bs2nat_nil; auto.
 rewrite bs2nat_false; simpl.
 destruct a; simpl.
 repeat rewrite bs2nat_true.
 rewrite IHl1; simpl.
 simpl; ring.
 repeat rewrite bs2nat_false.
 rewrite IHl1; simpl.
 simpl; ring.
Qed.

Lemma bs2nat_power : forall l n,
  bs2nat (repeat n false ++ l) = (power 2 n) * (bs2nat l).
Proof.
 induction n; simpl; auto.
 rewrite bs2nat_false; simpl.
 rewrite IHn; ring.
Qed.

Fixpoint RoseS_spec (x y z : bs) :=
  match z with
    | nil => nil
    | _ :: z' =>
      if leb (length z) (length x - length y)
        then false :: RoseS_spec x y z'
        else hd false (skipn (length x - length z) x) :: RoseS_spec x y z'
  end.

Lemma RoseS_spec2_false : forall x y z,
  length z <= length x - length y ->
  bs2nat (RoseS_spec x y z) = 0.
Proof.
 induction z; simpl; intros.
 rewrite bs2nat_nil; trivial.
 case_eq (length x - length y); intros.
 rewrite H0 in H.
 elimtype False; omega.
 case_eq (leb (length z) n); intros.
 apply leb_complete in H1.
 rewrite bs2nat_false, IHz; auto.
 omega.
 apply leb_complete_conv in H1.
 elimtype False; omega.
Qed.

Lemma skipn_roseS : forall x y z,
  bs2nat (skipn (length z) (RoseS_spec x y z)) = 0.
Proof.
  induction z; simpl.
  rewrite bs2nat_nil; auto.
  case_eq (length x - length y); intros; auto.
  case_eq (leb (length z) n); intros; auto.
Qed.

Lemma RoseS_cons : forall x y z b1 b2,
  length z <= length x ->
  RoseS_spec (b1 :: x) (b2 :: y) z = RoseS_spec x y z.
Proof.
  induction z; simpl; trivial; intros.
  case_eq (length x - length y); intros.
  rewrite IHz;[ | omega ]; clear IHz.
  f_equal.
  destruct x; simpl in *.
  elimtype False; omega.
  destruct y; simpl in *.
  discriminate.
  destruct z; simpl.
  rewrite <- minus_n_O; trivial.
  simpl in *.
  cutrewrite (length x - length z = S (length x - S (length z))).
  simpl; trivial.
  omega.
  case_eq (leb (length z) n); intros.
  rewrite IHz; auto.
  omega.
  rewrite IHz.
  f_equal.
  apply leb_complete_conv in H1.
  destruct x; simpl in *.
  discriminate.
  destruct y; simpl in *.
  elimtype False; omega.
  destruct z; simpl.
  rewrite <- minus_n_O; trivial.
  cutrewrite (length x - length z = S (length x - S (length z))).
  simpl; trivial.
  simpl in *; omega.
  omega.
Qed.

Lemma bs2nat_cons_eq : forall b l1 l2,
  bs2nat l1 = bs2nat l2 ->
  bs2nat (b :: l1) = bs2nat (b :: l2).
Proof.
  intros.
  case b.
  repeat rewrite bs2nat_true; ring [H].
  repeat rewrite bs2nat_false; ring [H].
Qed.

Fixpoint RoseS_spec' (x : bs) (y z : nat) :=
  match z with
    | 0 => nil
    | S z' =>
      if leb z (length x - y)
        then false :: RoseS_spec' x y z'
        else hd false (skipn (length x - z) x) :: RoseS_spec' x y z'
  end.


(* Attempt to do examples from the SEwB book *)

Require Import List.

Section Resources.

  Variable Elt : Set.
  Definition Res := list Elt.

  Variable eq_dec : forall (x y : Elt), {x = y} + {x <> y}.

  Definition free :
    forall (x:Elt) (rfree : Res),
      ~ In x rfree ->
      {rfree' : Res | In x rfree' /\ forall (y:Elt), x <> y -> In y rfree -> In y rfree'}.
  Proof.
    refine
      (fun (x : Elt) (rfree: Res) (p : ~In x rfree) =>
	exist _ (x::rfree) _). firstorder.
  Defined.

  Fixpoint remove (a : Elt) (r : Res) {struct r} : Res :=
    match r with
      | nil => nil
      | h::t =>
	match eq_dec a h with
	  | left _ => remove a t
	  | right _ =>  h::(remove a t)
	end
    end.

  Lemma remove_correct : forall (x : Elt) (r : Res),
    ~ In x (remove x r).
  Proof.
    simple induction r. firstorder.
    intros. simpl. case (eq_dec x a). firstorder.
    firstorder.
  Defined.

  Hint Resolve remove_correct.

  Ltac case_eq_dec :=
    match goal with
      | [ _ : _ |- context[eq_dec ?x ?y] ] =>
        case (eq_dec x y) ; firstorder ; try subst ; intros ; try congruence
    end.

  Hint Extern 1 (In _ _) => case_eq_dec.

  Lemma remove_inv_neq : forall (x y : Elt) (r : Res),
    x <> y -> In y r -> In y (remove x r).
  Proof.
    simple induction r ; simpl ; eauto.
  Defined.

  Hint Resolve remove_inv_neq.

  Definition alloc :
    forall (x:Elt) (rfree : Res),
      In x rfree ->
      {rfree' : Res | ~In x rfree' /\ forall (y:Elt), x <> y -> In y rfree -> In y rfree'}.
  Proof.
    refine
      (fun (x : Elt) (rfree: Res) (p : In x rfree) =>
	exist _ (remove x rfree) _). firstorder.
  Defined.

End Resources.

Require Import Coq.Sets.Constructive_sets.

Section Res_Prop.

  Variable Elt : Set.
  Variable eq_dec : forall (x y : Elt), {x = y} + {x <> y}.

  Definition ResSet := Ensemble Elt.

  (* Implicit Arguments In [U]. *)

  Definition freeRes :
    forall (x:Elt) (rfree : ResSet),
      ~ In Elt rfree x -> sigT
      (fun (rfree' : ResSet) =>
	In Elt rfree' x /\ forall (y:Elt), x <> y -> In Elt rfree y -> In Elt rfree' y).
  Proof.
    firstorder. refine (existT _ (Add Elt rfree x) _). firstorder.
  Defined.

  Definition allocRes :
    forall (x:Elt) (rfree : ResSet),
      In Elt rfree x -> sigT
      (fun (rfree' : ResSet) =>
	~ In Elt rfree' x /\ forall (y:Elt), x <> y -> In Elt rfree y -> In Elt rfree' y).
  Proof.
    firstorder. refine (existT _ (Subtract Elt rfree x) _). firstorder.
  Defined.

End Res_Prop.

Section.

End.


Require Export projective_space_axioms.
Require Setoid.

(* We derive some lemmas needed to show decidability of equality *)
(*
Module Type MoreProjectiveSpace.

Parameter Line : Type.
Parameter Point : Type.
Parameter Incid : Point -> Line -> Prop.

Axiom incidABl : forall (A B:Point)(l:Line), ~Incid A l /\ Incid B l -> A <> B.
Axiom incidAl1l2 : forall (l1 l2:Line)(A:Point), ~Incid A l1 /\ Incid A l2 -> l2 <> l1.
Axiom a1_unique : forall (A B :Point)(l1 l2:Line),
  A<>B -> Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> l1=l2.
Axiom a2_unique : forall(l1 l2 :Line)(A B :Point),
  l1<>l2 -> Incid A l1 -> Incid A l2 -> Incid B l1 -> Incid B l2 -> A = B.
Axiom eq_line_dec : forall d1 d2 : Line, d1 = d2\/d1 <> d2.
Axiom eq_point_dec : forall A B: Point, A = B\/A <> B.

Axiom second_point : forall A:Point, forall l:Line, Incid A l -> exists B : Point, (B<>A)/\(Incid B l).

End MoreProjectiveSpace.
*)

Module ProjectiveSpaceFacts (DecPoints: FSetInterface.WS) (M: ProjectiveSpace DecPoints).

(*: MoreProjectiveSpace
 with Definition Line:=M.Line
with Definition Point:= M.Point
with Definition Incid := M.Incid.
*)

Definition Line:=M.Line.
Definition Point:= M.Point.
Definition Incid := M.Incid.

Import M. (* to avoid qualified names *)

Lemma incidABl : forall (A B:Point)(l:Line), ~Incid A l /\ Incid B l -> A <> B.
intros A B l H HAB.
subst A.
tauto.
Qed.

Hint Resolve incidABl : incidence.

Lemma incidAl1l2 : forall (l1 l2:Line)(A:Point), ~Incid A l1 /\ Incid A l2 -> l2 <> l1.
intros l1 l2 A H Hl2l1.
subst l1.
tauto.
Qed.

Hint Resolve incidAl1l2 : incidence.

Lemma a1_unique : forall (A B :Point)(l1 l2:Line),
  ~ A [==] B -> Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> l1=l2.
intros.
assert (A[==]B\/l1=l2).
eapply uniqueness; intuition.
intuition.
Qed.

Lemma a2_unique : forall(l1 l2 :Line)(A B :Point),
  l1<>l2 -> Incid A l1 -> Incid A l2 -> Incid B l1 -> Incid B l2 -> A [==] B.
intros.
assert (A [==] B\/l1=l2).
eapply uniqueness; intuition.
intuition.
Qed.

Lemma eq_line_dec :
  forall d1 d2 : Line, d1 = d2\/d1 <> d2.
generalize a3_1 a3_2.
intros Hsa31' Hsa32'.
intros l1 l2.
elim (Hsa31' l1).
intros M HM; elim HM; clear HM; intros N HN; elim HN; clear HN; intros P HMNP.
elim (incid_dec M l2).
intros HMl2; elim (incid_dec N l2).
intros HNl2.
left.
decompose [and] HMNP.
assert ((N [==] M)\/(l1=l2)).
apply uniqueness; intuition.
assert (~ N [==] M).
unfold dist3 in *.
decompose [and] H.
intro.
apply H4.
apply DecPoints.eq_sym.
auto.
intuition.

intro.
right.
apply incidAl1l2 with (A:=N).
intuition.
intro.
right.
apply incidAl1l2 with (A:=M); intuition.
Qed.

Lemma two_lines_aux :
  forall P, forall l, ~Incid P l -> exists m:Line, exists n:Line, m<>n /\ Incid P m /\ Incid P n.
generalize a3_1 a3_2 a3_3.
intros H1 H2 H3.
intros P l HPl.
elim (H1 l).
intros A HA; elim HA; clear HA; intros B HB; elim HB; clear HB; intros C HC.
elim (a1_exists P A).
intros l1 Hl1.
elim (a1_exists P B).
intros l2 Hl2.
exists l1.
exists l2.
intuition.
subst.
assert ((A [==] B)\/l2=l).
apply uniqueness; intuition.
case H9.
intro.
unfold dist3 in *;  intuition.
intro.
subst;
intuition.
Qed.

Lemma two_lines_P : forall P:Point, exists l1:Line, exists l2:Line, l1<>l2/\Incid P l1/\Incid P l2.
generalize a3_3 a3_2 a3_1.
intros H1 H2 H3.
intros P.
elim H2; intros l1 Hl1; elim Hl1; clear Hl1; intros l2 Hl2.
elim (incid_dec P l1).
intros.
elim (incid_dec P l2).
intros.
assert False.
apply (Hl2 P); intuition.
intuition.
intros HPl2.
eapply two_lines_aux; eauto with incidence.
intros HPl2.
eapply two_lines_aux; eauto with incidence.
Qed.

Lemma only_one_intersection : forall l1 l2:Line, forall B C:Point,Incid C l1 /\ ~Incid C l2 /\ Incid B l2 /\ ~Incid B l1 ->
exists l3:Line,   l1 <>l3 /\ l2 <> l3/\ (Intersect l3 l1) /\(Intersect l3 l2).
Proof.
intros l1 l2 B C (HCl1,(HCl2,( HBl2, HBl1))).
elim (a1_exists B C).
intros l (HBl, HCl).
exists l.
split.
intro; subst; intuition.
split.
intro;subst;intuition.
unfold Intersect; firstorder.
Qed.

Lemma two_points_not_incident_l1l2 :
forall l1 l2:Line, l1<>l2 -> exists B,
(Incid B l1 /\ ~Incid B l2) /\ exists C,
(~Incid C l1 /\ Incid C l2).
Proof.
intros l1 l2 Hl1l2.
elim (a3_1 l1); intros A1 HA1; elim HA1; clear HA1; intros B1 HB1; elim HB1; clear HB1; intros C1 Hl1.
elim (a3_1 l2); intros A2 HA2; elim HA2; clear HA2; intros B2 HB2; elim HB2; clear HB2; intros C2 Hl2.
elim (incid_dec A1 l2).
intros.
assert (~Incid B1 l2).
intro.
assert (A1 [==] B1).
apply a2_unique with (l1:=l1) (l2:=l2); intuition.
unfold dist3 in *;intuition.
elim (incid_dec A2 l1).
intros.
assert (~Incid B2 l1).
intro.
assert (A2 [==] B2).
apply a2_unique with (l1:=l1) (l2:=l2); intuition.
unfold dist3 in *;intuition.
firstorder.

intro.

firstorder.
intro.
exists A1.
firstorder.

elim (incid_dec A2 l1).
intros HA2l1.
assert (~Incid B2 l1).
intro.
assert (A2 [==] B2).
apply a2_unique with (l1:=l1) (l2:=l2); intuition.
unfold dist3 in *;intuition.
firstorder.
intros HA2l1.
firstorder.
Qed.

Lemma third_line : forall l1 l2:Line,
exists l3 :Line,  l1 <>l3 /\ l2 <> l3/\ (Intersect l3 l1) /\(Intersect l3 l2).
Proof.
intros l1 l2.
elim (eq_line_dec l1 l2).
intro; subst.
elim (a3_1 l2); intros A2 HA2; elim HA2; clear HA2; intros B2 HB2; elim HB2; clear HB2; intros C2 Hl2.
elim (two_lines_P A2).
intros d1 Hd1; elim Hd1; intros d2 Hd.
elim (eq_line_dec l2 d1).
intro; subst.
exists d2.
unfold Intersect in *; firstorder.
intro; subst.
exists d1.
unfold Intersect in *; firstorder.
intros Hl1l2.
elim (two_points_not_incident_l1l2 l1 l2 Hl1l2).
intros A (HA, Hex).
elim Hex; intros B HB.
apply (only_one_intersection l1 l2 B A).
intuition.
Qed.

Lemma a3_3simplified : forall l1 l2:Line, exists l3 :Line, l1 <>l3 /\ l2 <> l3.
Proof.
intros l1 l2; elim (third_line l1 l2).
intros l H; elim H; intros A HA; elim HA; intros B HB.
exists l; intuition.
Qed.

Lemma second_line : forall l1 : Line, exists l2:Line, l1<>l2.
Proof.
intros l1.
elim a3_2.
intros d1 H; elim H; intros d2 H'.
elim (third_line l1 d2).
intros d (Hd1, (Hd2, (HexI, HexJ))).
exists d.
intuition.
Qed.

Lemma second_point : forall A:Point, forall l:Line, Incid A l -> exists B : Point, (~ B [==]A)/\(Incid B l).
Proof.
intros A l HAl.
elim (a3_1 l).
intros P1 H.
elim H; intros P2 H'.
elim H'; intros P3 H''.
elim (DecPoints.eq_dec A P1).
intros HAP1.
exists P2.
unfold dist3 in *.
intuition.
apply H2.
apply DecPoints.eq_trans with (s':=A).
apply DecPoints.eq_sym.
assumption.
apply DecPoints.eq_sym.
assumption.
intros Hnew.
exists P1.
intuition.
apply Hnew.
apply DecPoints.eq_sym.
assumption.
Qed.

Export Setoid.

Add Parametric Relation : (Point) (DecPoints.eq)
  reflexivity proved by DecPoints.eq_refl
  symmetry proved by DecPoints.eq_sym
  transitivity proved by DecPoints.eq_trans
as PointsEqSetoid .

Axiom Incid_mor :
forall x y : Point, x[==]y -> forall y0 : Line, Incid x y0 <-> Incid y y0.

Add Parametric Morphism (Point:Type) : Incid
with signature (DecPoints.eq ) ==> eq ==> iff  as incid_mor.
Proof.
apply Incid_mor.
Qed.

Lemma third_point : forall A B:Point, forall l:Line,
 ~ A [==]B /\
   Incid A l/\Incid B l ->
exists C:Point, dist3 A B C/\Incid C l.
Proof.
intros A B l HABl.
elim (a3_1 l).
intros P1 H.
elim H; intros P2 H'.
elim H'; intros P3 H''.
clear H H'.
elim (DecPoints.eq_dec A P1).
intros HAP1.

decompose [and] H''.
unfold dist3 in *.
setoid_rewrite <- HAP1 in H.

elim (DecPoints.eq_dec B P2).
intros HBP2.
setoid_rewrite <- HBP2 in H.
exists P3.
unfold dist3 in *; intuition.
intros HBP2.
exists P2.
unfold dist3 in *; intuition.
intros HBP2.
decompose [and] HABl; clear HABl.
decompose [and] H''; clear H''.
unfold dist3 in H0.
decompose [and] H0;clear H0.

elim (DecPoints.eq_dec B P1).
intros HBP1.
elim (DecPoints.eq_dec A P2).
intros.
exists P3.
unfold dist3.
rewrite HBP1 in *.
rewrite a in *.
intuition.

intros HAP2.
rewrite HBP1 in *.

elim (DecPoints.eq_dec B P2).
intros.
rewrite a in *.
cut False;
intuition.

exists P2.
unfold dist3 in *; intuition.
apply H.
rewrite H0.
assumption.
intros HBP1.

exists P1.
unfold dist3 in *;intuition.
Qed.

End ProjectiveSpaceFacts.


Require Import Init.Init.
Require Import Relation.Relation.
Require Import Structure.Binary_Op.

Definition cmonoid (A R e: J)
  := binop A R ∧ assoc A R ∧ commu A R ∧ ident A R e.

Section cmonoid.
  Variable A R e a b c d: J.
  Variable H0: cmonoid A R e.
  Variable H1: a ∈ A.
  Variable H2: b ∈ A.
  Variable H3: c ∈ A.
  Variable H4: d ∈ A.
  Notation "x + y" := (x +[R] y).

  Lemma cmonoid_assoc: assoc A R.
  Proof.
    apply H0.
  Qed.

  Lemma cmonoid_commu: commu A R.
  Proof.
    apply H0.
  Qed.

  Lemma cmonoid_ident: ident A R e.
  Proof.
    apply H0.
  Qed.

  Lemma cmonoid_identr: identr A R e.
  Proof.
    apply ident_er.
    apply cmonoid_ident.
  Qed.

  Lemma cmonoid_identl: identl A R e.
  Proof.
    apply ident_el.
    apply cmonoid_ident.
  Qed.

  Lemma cmonoid_op_eq: a = b → c = d → a + c = b + d.
  Proof.
    intros P1 P2.
    apply (eq_cl (λ x, _ = x + _) P1).
    apply (eq_cl (λ x, _ = _ + x) P2).
    apply eq_r.
  Qed.

  Lemma cmonoid_op_eq2: a = b → a + c = b + c.
  Proof.
    intros P1.
    apply (eq_cl (λ x, _ = x + _) P1).
    apply eq_r.
  Qed.

  Lemma cmonoid_132: a + b + c = a + c + b.
  Proof.
    apply (eq_cr (λ x, _ = x) (cmonoid_assoc _ _ _ H1 H3 H2)).
    apply (eq_cr (λ x, _ = _ + x) (cmonoid_commu _ _ H3 H2)).
    apply (eq_cl (λ x, _ = x) (cmonoid_assoc _ _ _ H1 H2 H3)).
    apply eq_r.
  Qed.

  Lemma cmonoid_213: a + b + c = b + a + c.
  Proof.
    apply (eq_cr (λ x, _ = x + _) (cmonoid_commu _ _ H2 H1)).
    apply eq_r.
  Qed.

  Lemma cmonoid_231: a + b + c = b + c + a.
  Proof.
    apply (eq_cr (λ x, _ = x) (cmonoid_assoc _ _ _ H2 H3 H1)).
    apply (eq_cr (λ x, _ = _ + x) (cmonoid_commu _ _ H3 H1)).
    apply (eq_cl (λ x, _ = x) (cmonoid_assoc _ _ _ H2 H1 H3)).
    apply cmonoid_213.
  Qed.

  Lemma cmonoid_312: a + b + c = c + a + b.
  Proof.
    apply (eq_cr (λ x, _ = x + _) (cmonoid_commu _ _ H3 H1)).
    apply cmonoid_132.
  Qed.

  Lemma cmonoid_321: a + b + c = c + b + a.
  Proof.
    apply (eq_cr (λ x, _ = x + _) (cmonoid_commu _ _ H3 H2)).
    apply cmonoid_231.
  Qed.
End cmonoid.


Require Import List.
Require Import String.

Definition ident := (string*nat)%type.

Inductive natexp : Set :=
| z : natexp
| s : natexp -> natexp.

Inductive listexp : Set :=
| n : listexp
| c : natexp -> listexp -> listexp.

Inductive con : Set :=
| nc : natexp -> con
| lc : listexp -> con.
b

Inductive Expr : Set :=
| bvar : nat -> Expr
| fvar : ident -> Expr
| con : ident -> Expr
| f : ident -> Expr
| appl : ident -> list Expr -> Expr
| lam : list Expr -> Expr
| explet : ident -> Expr -> Expr
| expcase : Expr -> list (Patr*Expr) -> Expr
with Patr : Set :=
| patr : ident -> list Expr -> Patr.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import Arith.

Require Import folProp.
Require Import folProof.
Require Import subProp.
Require Import folLogic3.
Require Import folReplace.
Require Import NN.
Require Import PAtheory.
Require Export LNN2LNT.
Require Import subAll.
Require Import ListExt.

Lemma NN2PA :
 forall f : fol.Formula LNN,
 folProof.SysPrf LNN NN f -> SysPrf PA (LNN2LNT_formula f).
Proof.
intros.
apply translateProof with NN.
apply closedPA1.
intros.
unfold NN in H0.
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0 as [x H0| x H0].
induction H0.
apply Axm; repeat (try right; constructor) || left.
induction H0.
apply Axm; repeat (try right; constructor) || left.
induction H0.
apply Axm; repeat (try right; constructor) || left.
induction H0.
apply Axm; repeat (try right; constructor) || left.
induction H0.
apply Axm; repeat (try right; constructor) || left.
induction H0.
apply Axm; repeat (try right; constructor) || left.
induction H0.
apply NN72PA.
induction H0.
apply NN82PA.
induction H0.
apply NN92PA.
apply H.
Qed.

Lemma PAboundedLT :
 forall (m : nat) (a : Formula) (x : nat),
 (forall n : nat,
  n < m -> SysPrf PA (substituteFormula LNT a x (natToTerm n))) ->
 SysPrf PA (impH (LNN2LNT_formula (LT (fol.var LNN x) (LNN.natToTerm m))) a).
Proof.
simple induction m; intros.
apply impI.
apply
 contradiction with (LNN2LNT_formula (LT (fol.var LNN x) (LNN.natToTerm 0))).
apply Axm; right; constructor.
apply sysWeaken.
replace (notH (LNN2LNT_formula (LT (fol.var LNN x) (LNN.natToTerm 0)))) with
 (LNN2LNT_formula (fol.notH LNN (LT (fol.var LNN x) (LNN.natToTerm 0)))).
apply NN2PA.
apply nn7.
reflexivity.
apply impI.
eapply orE.
apply impE with (LNN2LNT_formula (LT (fol.var LNN x) (LNN.natToTerm (S n)))).
apply sysWeaken.
assert
 (SysPrf PA
    (LNN2LNT_formula
       (LNN.impH (LT (fol.var LNN x) (LNN.Succ (LNN.natToTerm n)))
          (LNN.orH (LT (fol.var LNN x) (LNN.natToTerm n))
             (LNN.equal (fol.var LNN x) (LNN.natToTerm n)))))).
apply NN2PA.
apply nn8.
simpl in H1.
simpl in |- *.
unfold orH, fol.orH in |- *.
apply H1.
apply Axm; right; constructor.
apply sysWeaken.
simpl in H.
apply H.
auto.
apply sysWeaken.
apply impI.
rewrite <- (subFormulaId LNT a x).
rewrite LNN2LNT_natToTerm.
apply impE with (substituteFormula LNT a x (natToTerm n)).
apply (subWithEquals LNT).
apply eqSym.
apply Axm; right; constructor.
apply sysWeaken.
apply H0.
apply lt_n_Sn.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.schedule.global.basic.schedule.
Require Import prosa.classic.analysis.apa.workload_bound.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module InterferenceBoundGeneric.

  Section Definitions.

    Import Schedule WorkloadBound.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Variable num_cpus: nat.

    (* Let tsk be the task to be analyzed. *)
    Variable tsk: sporadic_task.

    Let task_with_response_time := (sporadic_task * time)%type.

    (* Assume a known response-time bound for each interfering task ... *)
    Variable R_prev: seq task_with_response_time.

    (* ... and an interval length delta. *)
    Variable delta: time.

    Section PerTask.

      Variable tsk_R: task_with_response_time.
      Let tsk_other := fst tsk_R.
      Let R_other := snd tsk_R.

      (* Based on the workload bound, Bertogna and Cirinei define the
         following interference bound for a task. *)
      Definition interference_bound_generic :=
        minn (W task_cost task_period tsk_other R_other delta) (delta - (task_cost tsk) + 1).

    End PerTask.

  End Definitions.

End InterferenceBoundGeneric.


Require Export D.

(** **** Problem #10 : 1 star, optional (fst_swap_is_snd) *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
 intros. destruct p. reflexivity.
Qed.


Require Export Coq.Bool.Bool.

Lemma negb_true_elim
 :  forall x
 ,  true   = negb x
 -> false  = x.
Proof. destruct x; auto. Qed.

Lemma negb_true_intro
 :  forall x
 ,  false = x
 -> true  = negb x .
Proof. destruct x; eauto. Qed.

Lemma negb_false_elim
 :  forall x
 ,  false  = negb x
 -> true   = x.
Proof. destruct x; auto. Qed.

Ltac norm_negb
 := match goal with
    | [H : true  = negb _ |- _ ]
    => apply negb_true_elim in H

    | [H : false = negb _ |- _ ]
    => apply negb_false_elim in H
    end.

(********************************************************************)
Lemma beq_true_split
 :  forall A B
 ,  true = andb A B
 -> true = A /\ true = B.
Proof.
 intros.
 destruct A.
  tauto.
  simpl in H. congruence.
Qed.
Hint Resolve beq_true_split.

Lemma beq_false_split
 :  forall A B
 ,  false = andb A B
 -> false = A \/ false = B.
Proof.
 intros.
 destruct A.
  simpl in H. subst. tauto.
  tauto.
Qed.
Hint Resolve beq_false_split.

Lemma beq_false_join
 :  forall A B
 ,  false = A \/ false = B
 -> false = andb A B.
Proof.
 intros.
 inversion H. subst.
 tauto.
 destruct A; tauto.
Qed.
Hint Resolve beq_false_split.

Ltac norm_andb
 := match goal with
    | [H : true  = andb _ _ |- _]
    => apply beq_true_split in H

    | [H : andb _ _ = true |- _]
    => symmetry in H; apply beq_true_split in H

    | [H : false = andb _ _ |- _]
    => apply beq_false_split in H

    | [H : andb _ _ = false |- _]
    => symmetry in H; apply beq_false_split in H
    end.

(********************************************************************)
Ltac norm_orb
 := match goal with
    | [H : true    = orb _ _ |- _]
    => symmetry in H; apply orb_true_iff in H

    | [H : orb _ _ = true    |- _]
    => apply orb_true_iff in H

    | [H : false   = orb _ _ |- _]
    => symmetry in H; apply orb_false_iff in H

    | [H : orb _ _ = false   |- _]
    => apply orb_false_iff in H
    end.


Require Export P05.

Lemma merge_sort_permutation fuel l
      (FUEL: fuel >= length l):
  Permutation l (merge_sort' fuel l).
Proof. exact FILL_IN_HERE. Qed.


From TCC Require Import CpdtTactics.
Require Import Psatz.
From Coq Require Import Arith.

Ltac inv H := inversion H; clear H; subst.

Notation "A :: B" := (cons A B).
Notation "[]" := nil.
Notation "[[ A ]]" := (A :: nil).

Definition watermark : Type := (nat * nat).

Definition dot (w1 w2: watermark) : watermark :=
  match w1,w2 with
  | (q,q') , (p,p') => if Nat.ltb p q' then (q, p' + q' - p) else (q + p - q', p')
  end.

Notation "x <.> y" := (dot x y) (at level 50, left associativity).

Definition weakened (w1 w2: watermark) : Prop :=
  (fst w1 >= fst w2) /\ ((fst w1 - fst w2) >= (snd w1 - snd w2)).

Lemma max_choice : forall x y, max x y = x \/ max x y = y.
Proof.
  induction x,y; lia.
Qed.

Lemma min_choice : forall x y, min x y = x \/ min x y = y.
Proof.
  induction x,y; lia.
Qed.

Ltac rew :=
  match goal with
  | H: ?n1 <? ?n2 = true |- _ => rewrite Nat.ltb_lt in H
  | H: ?n1 <? ?n2 = false |- _ => rewrite Nat.ltb_ge in H
  end.

Ltac destr n1 n2 := destruct (n1 <? n2) eqn:?.
Ltac dd n := destruct n eqn:?.

Ltac sl := simpl; try lia.

Lemma ge_weak : forall q q' p w, p >= q -> weakened (q,q') w -> weakened (p, q') w.
Proof.
  induction q; intros.
  - inv H0. unfold weakened. simpl in *. inv H1. rewrite H3.
    lia.
  - inv H0. unfold weakened. simpl in *. dd (fst w). lia.
    lia.
Qed.

Lemma le_weak : forall q q' p w, p <= q -> weakened (q',q) w -> weakened (q', p) w.
Proof.
  intros. inv H0. unfold weakened. simpl in *.
  split; auto. lia. Qed.

Lemma weak_trans : forall w1 w2 w3, weakened w1 w2 -> weakened w2 w3 -> weakened w1 w3.
Proof.
  intros. destruct w1, w2, w3. induction n; intros.
  - inv H; inv H0; simpl in *. inv H1. inv H2. inv H. inv H3.
    unfold weakened. simpl. rewrite H1. rewrite H0. lia.
  - unfold weakened in *. simpl in *. dd n1; dd n3; lia.
Qed.

Lemma weak_dot : forall w1 w2 w3, weakened w1 w2 -> weakened (w1 <.> w3) (w2 <.> w3).
Proof.
  intros. destruct w1, w2, w3. unfold weakened in *.
  simpl in *. inv H. destr n3 n0; destr n3 n2; simpl; repeat rew; lia.
Qed.

Lemma weak_dot' : forall w1 w2 w3 w4, weakened w1 w2 -> weakened w3 w4 -> weakened (w1 <.> w3) (w2 <.> w4).
Proof.
  intros. destruct w1, w2, w3, w4. inv H; inv H0. unfold weakened. simpl in *.
  destr n3 n0; destr n5 n2; simpl; repeat rew; lia.
Qed.

Lemma dot_left_assoc : forall w1 w2 w3, w1 <.> (w2 <.> w3) = (w1 <.> w2) <.> w3.
Proof.
  intros. destruct w1, w2, w3. simpl. destr n3 n2; destr n1 n0; simpl;
  try (rewrite Heqb); simpl; destr n3 (n2 + n0 - n1); destr (n1 + n3 - n2) n0;
  simpl; repeat rew; crush. Qed.

Lemma weak_S : forall q q' p p', weakened (p,p') (q,q') -> weakened (S p, p') (S q, q').
Proof.
  intros. inv H. unfold weakened. simpl in *. lia.
Qed.

Lemma zero_null : forall w, w <.> (0,0) = w.
Proof. intros. destruct w. simpl.
  destr 0 n0; rew; simpl. rewrite Nat.sub_0_r. auto.
  Search (?x <= 0). apply le_n_0_eq in Heqb. rewrite <- Heqb.
  rewrite Nat.add_0_r. rewrite Nat.sub_0_r. auto.
Qed.

Lemma weak_refl : forall w, weakened w w.
Proof.
  intros; unfold weakened; destruct w; simpl; lia.
Qed.

Lemma dot_ge_fst : forall w1 w2, fst (w1 <.> w2) >= fst w1.
Proof.
  intros; destruct w1,w2; simpl. destr n1 n0; rew; simpl.
  auto. lia. Qed.

Lemma dot_ge_snd : forall w1 w2, snd (w1 <.> w2) >= snd w2.
Proof.
  intros. destruct w1,w2; simpl. destr n1 n0; rew; simpl. lia. lia. Qed.

Definition mnx (w1 w2: watermark) : watermark :=
  match w1, w2 with
  | (p,q), (p',q') => (max p p', min q q')
  end.

Lemma mnx_comm : forall w1 w2,
  mnx w1 w2 = mnx w2 w1.
Proof.
  intros. destruct w1,w2; unfold mnx. rewrite Nat.max_comm.
  rewrite Nat.min_comm. auto.
Qed.

Lemma mnx_choice_l : forall w1 w2, (fst (mnx w1 w2) = fst w1) \/
  (fst (mnx w1 w2) = fst w2).
Proof.
  intros. destruct w1,w2. simpl. apply max_choice.
Qed.

Lemma mnx_choice_r : forall w1 w2, (snd (mnx w1 w2) = snd w1) \/
  (snd (mnx w1 w2) = snd w2).
Proof.
  intros. destruct w1,w2. simpl. apply min_choice.
Qed.

Lemma mnx_fst_implies : forall w1 w2 v,
  (fst (mnx w1 w2) = v) -> (v >= fst w1 /\ v >= fst w2).
Proof.
  intros. destruct w1,w2; simpl in *. lia. Qed.

Lemma mnx_snd_implies : forall w1 w2 v,
  (snd (mnx w1 w2) = v) -> (v <= snd w1 /\ v <= snd w2).
Proof.
  intros; destruct w1,w2; simpl in *. lia. Qed.

Lemma mnx_weakened_trans : forall w1 w2 w3,
  weakened w1 w3 -> weakened (mnx w1 w2) w3.
Proof.
  intros. pose (mnx_choice_l w1 w2).
  pose (mnx_choice_r w1 w2).
  unfold weakened in *.
  pose (mnx_fst_implies w1 w2); pose (mnx_snd_implies w1 w2).
  destruct H. destruct o; [pose (a (fst w1) H1) | pose (a (fst w2) H1)]; destruct a1;
  destruct o0; [pose (a0 (snd w1) H4) | pose (a0 (snd w2) H4)
  | pose (a0 (snd w1) H4) | pose (a0 (snd w2) H4)]; split;
  try (rewrite H1); try (rewrite H4); auto; try lia.
Qed.

Lemma mnx_weakened_trans' : forall w1 w2 w3,
  weakened w1 w3 -> weakened (mnx w2 w1) w3.
Proof.
  intros. rewrite mnx_comm. apply mnx_weakened_trans; auto.
Qed.

Definition minx (w1 w2: watermark) : watermark :=
  match w1, w2 with
  | (p,q), (p',q') => (min p p', max q q')
  end.

Lemma mnx_minx_weak : forall w1 w2,
  weakened (mnx w1 w2) (minx w1 w2).
Proof.
  intros.
  destruct w1,w2. unfold mnx,minx.
  unfold weakened. split. simpl.
  lia. simpl. lia. Qed.

Lemma mnx_minx_weak_ultra : forall w1 w2 w3 w4,
  weakened w1 w3 ->
  weakened w2 w4 ->
  weakened (mnx w1 w2) (minx w3 w4).
Proof.
  intros.
  assert (weakened (mnx w1 w2) (minx w1 w2)). apply mnx_minx_weak.
  destruct w1,w2,w3,w4. unfold weakened in *.
  simpl in *. destruct H,H0,H1. split; sl. Qed.


(* CyclicPerm_Type library *)

(** * Cyclic Permutations
Definition and basic properties of cyclic permutations in Type. *)

Require Import CMorphisms.

Require Import List_Type.
Require Import List_Type_more.
Require Import Permutation_Type_more.

(** Definition *)
Inductive CPermutation_Type {A} : list A -> list A -> Type :=
| cperm_Type : forall l1 l2, CPermutation_Type (l1 ++ l2) (l2 ++ l1).

Instance cperm_perm_Type {A} : Proper (CPermutation_Type ==> (@Permutation_Type A)) id.
Proof.
intros l1 l2 HC.
inversion HC.
apply Permutation_Type_app_comm.
Qed.

Instance cperm_Type_refl {A} : Reflexive (@CPermutation_Type A).
Proof.
intros l.
assert (CPermutation_Type (nil ++ l) (l ++ nil))
  as HC by (eapply cperm_Type).
simpl in HC.
rewrite app_nil_r in HC.
assumption.
Qed.

Instance cperm_Type_sym {A} : Symmetric (@CPermutation_Type A).
Proof.
intros l1 l2 HC.
inversion HC.
eapply cperm_Type.
Qed.

Instance cperm_Type_trans {A} : Transitive (@CPermutation_Type A).
Proof.
intros l1 l2 l3 HC1 HC2.
inversion HC1 ; inversion HC2 ; subst.
apply dichot_Type_app in H1.
destruct H1 as [[l2' [Hl1 Hl2]] | [l4' [Hr1 Hr2]]] ; subst.
- rewrite <- app_assoc.
  rewrite app_assoc.
  eapply cperm_Type.
- rewrite <- app_assoc.
  rewrite (app_assoc l6).
  eapply cperm_Type.
Qed.

Instance cperm_Type_equiv {A} : Equivalence (@CPermutation_Type A).
Proof.
split.
- apply cperm_Type_refl.
- apply cperm_Type_sym.
- apply cperm_Type_trans.
Qed.

Lemma cperm_Type_app {A} : forall l1 l2 l3 : list A,
  CPermutation_Type (l1 ++ l2) l3 -> CPermutation_Type (l2 ++ l1) l3.
Proof.
intros l1 l2 l3 HC.
apply (cperm_Type_trans _ (l1 ++ l2)) ; try assumption.
eapply cperm_Type.
Qed.

Lemma cperm_Type_app_rot {A} : forall (l1 : list A) l2 l3,
   CPermutation_Type (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1).
Proof.
intros l1 l2 l3.
rewrite (app_assoc l2).
apply cperm_Type.
Qed.

Lemma cperm_Type_last {A} : forall (a : A) l,
  CPermutation_Type (a :: l) (l ++ a :: nil).
Proof.
intros.
rewrite <- (app_nil_l l).
rewrite app_comm_cons.
apply cperm_Type.
Qed.

Lemma cperm_Type_swap {A} : forall a b : A,
  CPermutation_Type (a :: b :: nil) (b :: a :: nil).
Proof.
intros.
change (a :: b :: nil) with ((a :: nil) ++ (b :: nil)).
change (b :: a :: nil) with ((b :: nil) ++ (a :: nil)).
apply cperm_Type.
Qed.

Lemma cperm_Type_cons {A} : forall l1 (a : A) l2,
  CPermutation_Type (l1 ++ (a :: nil)) l2 -> CPermutation_Type (a :: l1) l2.
Proof.
intros l1 a l2 HC.
apply (cperm_Type_app l1 (a :: nil)) ; assumption.
Qed.

Lemma cperm_Type_morph_cons {A} : forall P : list A -> Prop,
  (forall a l, P (l ++ a :: nil) -> P (a :: l)) ->
  Proper (CPermutation_Type ==> Basics.impl) P.
Proof with try eassumption.
assert (forall P : list A -> Prop,
         (forall a l, P (l ++ a :: nil) -> P (a :: l)) ->
         forall l1 l2, CPermutation_Type l1 l2 -> P l1 -> P l2)
  as Himp.
{
intros P HP l1 l2 HC.
inversion HC ; subst ; clear HC.
revert l0 ; induction l3 using rev_ind ; intros l0 HPl.
- rewrite app_nil_r in HPl...
- rewrite app_assoc in HPl.
  apply HP in HPl.
  rewrite <- app_assoc.
  rewrite <- app_comm_cons.
  rewrite app_nil_l...
  apply IHl3...
}
intros P HP l1 l2 HC H.
eapply Himp...
Qed.

Lemma cperm_Type_nil {A} : forall l : list A,
  CPermutation_Type nil l -> l = nil.
Proof.
intros.
apply Permutation_Type_nil.
apply cperm_perm_Type.
assumption.
Qed.

Lemma cperm_Type_nil_cons {A} : forall l (a : A),
  CPermutation_Type nil (a :: l) -> False.
Proof.
intros l a HC.
apply cperm_Type_nil in HC.
inversion HC.
Qed.

Lemma cperm_Type_one {A} : forall a b : A,
  CPermutation_Type (a :: nil) (b :: nil) -> a = b.
Proof.
intros.
apply Permutation_Type_length_1.
apply cperm_perm_Type.
assumption.
Qed.

Lemma cperm_Type_two {A} : forall a1 a2 b1 b2 : A,
  CPermutation_Type (a1 :: a2 :: nil) (b1 :: b2 :: nil) ->
    { a1 = b1 /\ a2 = b2 } +  { a1 = b2 /\ a2 = b1 }.
Proof.
intros.
apply Permutation_Type_length_2.
apply cperm_perm_Type.
assumption.
Qed.

Lemma cperm_Type_one_inv {A} : forall l (a : A),
  CPermutation_Type (a :: nil) l -> l = a :: nil.
Proof.
intros.
apply Permutation_Type_length_1_inv.
apply cperm_perm_Type.
assumption.
Qed.

Lemma cperm_Type_two_inv {A} : forall (a : A) b l,
  CPermutation_Type (a :: b :: nil) l ->
  { l = a :: b :: nil } + { l = b :: a :: nil }.
Proof.
intros.
apply Permutation_Type_length_2_inv.
apply cperm_perm_Type.
assumption.
Qed.

Lemma cperm_Type_vs_elt_inv {A} : forall (a : A) l l1 l2,
  CPermutation_Type l (l1 ++ a :: l2) ->
    { pl | l2 ++ l1 = snd pl ++ fst pl & l = fst pl ++ a :: snd pl }.
Proof.
intros a l l1 l2 HC.
inversion HC ; subst.
symmetry in H1.
dichot_Type_elt_app_exec H1 ; subst.
- exists (l0 ++ l1, l) ; simpl ;
    rewrite <- app_assoc ; reflexivity.
- exists (l4, l2 ++ l3) ; simpl ;
    rewrite <- app_assoc ; reflexivity.
Qed.

Lemma cperm_Type_vs_cons_inv {A} : forall (a : A) l l1,
  CPermutation_Type l (a :: l1) ->
    { pl | l1 = snd pl ++ fst pl & l = fst pl ++ a :: snd pl }.
Proof.
intros a l l1 HC.
rewrite <- (app_nil_l (a::_)) in HC.
apply cperm_Type_vs_elt_inv in HC.
destruct HC as [(l' & l'') H1 H2].
rewrite app_nil_r in H1 ; subst.
exists (l', l'') ; split ; reflexivity.
Qed.

Lemma cperm_Type_app_app_inv {A} : forall l1 l2 l3 l4 : list A,
  CPermutation_Type (l1 ++ l2) (l3 ++ l4) ->
     { ql : _ & prod (prod
        (CPermutation_Type l1 (fst (fst ql) ++ fst (snd ql)))
        (CPermutation_Type l2 (snd (fst ql) ++ snd (snd ql))))
        (prod
        (CPermutation_Type l3 (fst (fst ql) ++ snd (fst ql)))
        (CPermutation_Type l4 (fst (snd ql) ++ snd (snd ql)))) }
   + { pl : _ & prod (prod
        (CPermutation_Type l1 (l4 ++ fst pl))
        (CPermutation_Type l3 (l2 ++ snd pl)))
        (CPermutation_Type (fst pl) (snd pl)) }
   + { pl : _ & prod (prod
        (CPermutation_Type l2 (l4 ++ fst pl))
        (CPermutation_Type l3 (l1 ++ snd pl)))
        (CPermutation_Type (fst pl) (snd pl)) }
   + { pl : _ & prod (prod
        (CPermutation_Type l1 (l3 ++ fst pl))
        (CPermutation_Type l4 (l2 ++ snd pl)))
        (CPermutation_Type (fst pl) (snd pl)) }
   + { pl : _ & prod (prod
        (CPermutation_Type l2 (l3 ++ fst pl))
        (CPermutation_Type l4 (l1 ++ snd pl)))
        (CPermutation_Type (fst pl) (snd pl)) }.
Proof with try assumption.
intros l1 l2 l3 l4 HC.
inversion HC as [lx ly Hx Hy].
dichot_Type_app_exec Hx ; dichot_Type_app_exec Hy ; subst.
- left ; left ; left ; right.
  exists (l ++ l0, l0 ++ l).
  simpl ; split ; [ split | ] ;
    try (rewrite <- ? app_assoc ; apply cperm_Type_app_rot).
  apply cperm_Type.
- dichot_Type_app_exec Hy0 ; subst.
  + left ; left ; left ; left.
    exists (l, l0, (lx, l5)).
    simpl ; split ; [ split | split ] ; try apply cperm_Type...
    * apply cperm_Type_refl.
    * apply cperm_Type_refl.
  + left ; right.
    exists (l1 ++ lx , lx ++ l1).
    split ; [ split | ] ;
      try (rewrite <- ? app_assoc ; apply cperm_Type_app_rot)...
    apply cperm_Type.
- dichot_Type_app_exec Hy1 ; subst.
  + left ; left ; right.
    exists (ly ++ l2, l2 ++ ly).
    split ; [ split | ] ;
      try (rewrite <- ? app_assoc ; apply cperm_Type_app_rot)...
    apply cperm_Type.
  + left ; left ; left ; left.
    exists (l, ly, (l3, l0)).
    simpl ; split ; [ split | split ] ; try apply cperm_Type...
    * apply cperm_Type_refl.
    * apply cperm_Type_refl.
- right.
  exists (l5 ++ l0, l0 ++ l5).
  split ; [ split | ] ;
    try (rewrite <- ? app_assoc ; apply cperm_Type_app_rot)...
  apply cperm_Type.
Qed.

(** [rev], [in], [map], [Forall], [Exists], etc. *)
Instance cperm_Type_rev {A} : Proper (CPermutation_Type ==> CPermutation_Type) (@rev A).
Proof.
intro l ; induction l ; intros l' HC.
- apply cperm_Type_nil in HC ; subst ; apply cperm_Type_refl.
- apply cperm_Type_sym in HC.
  apply cperm_Type_vs_cons_inv in HC.
  destruct HC as [(l1 & l2) Heq1 Heq2] ; subst.
  simpl ; rewrite ? rev_app_distr ; simpl.
  rewrite <- app_assoc.
  apply cperm_Type.
Qed.

Instance cperm_Type_in {A} (a : A) : Proper (CPermutation_Type ==> Basics.impl) (In a).
Proof with try eassumption.
intros l l' HC Hin.
eapply Permutation_Type_in...
apply cperm_perm_Type...
Qed.

Instance cperm_Type_map {A B} (f : A -> B) :
   Proper (CPermutation_Type ==> CPermutation_Type) (map f).
Proof.
intros l l' HC.
inversion HC ; subst ; rewrite ? map_app.
apply cperm_Type.
Qed.

Lemma cperm_Type_map_inv {A B} : forall(f : A -> B) l1 l2,
  CPermutation_Type l1 (map f l2) ->
    { l : _ & l1 = map f l & (CPermutation_Type l2 l) }.
Proof with try assumption.
induction l1 ; intros l2 HP.
- exists nil ; try reflexivity.
  simpl ; destruct l2...
  + apply cperm_Type_refl.
  + apply cperm_Type_nil in HP.
    inversion HP.
- apply cperm_Type_sym in HP.
  assert (Heq := HP).
  apply cperm_Type_vs_cons_inv in Heq.
  destruct Heq as [(l3 & l4) Heq1 Heq2].
  simpl in Heq1 ; simpl in Heq2 ; symmetry in Heq2.
  decomp_map_Type Heq2 ; subst ; simpl.
  exists (x :: l6 ++ l0).
  + simpl ; rewrite ? map_app ; reflexivity.
  + constructor.
Qed.

Instance cperm_Type_Forall {A} (P : A -> Prop) :
  Proper (CPermutation_Type ==> Basics.impl) (Forall P).
Proof with try eassumption.
intros l1 l2 HC HF.
eapply Permutation_Type_Forall...
apply cperm_perm_Type...
Qed.

Instance cperm_Type_Exists {A} (P : A -> Prop) :
  Proper (CPermutation_Type ==> Basics.impl) (Exists P).
Proof with try eassumption.
intros l1 l2 HC HE.
eapply Permutation_Type_Exists...
apply cperm_perm_Type...
Qed.

Instance cperm_Type_Forall_Type {A} (P : A -> Type) :
  Proper (CPermutation_Type ==> Basics.arrow) (Forall_Type P).
Proof with try eassumption.
intros l1 l2 HC HF.
eapply Permutation_Type_Forall_Type...
apply cperm_perm_Type...
Qed.

Instance cperm_Type_Exists_Type {A} (P : A -> Type) :
  Proper (CPermutation_Type ==> Basics.arrow) (Exists_Type P).
Proof with try eassumption.
intros l1 l2 HC HE.
eapply Permutation_Type_Exists_Type...
apply cperm_perm_Type...
Qed.

Lemma cperm_Type_Forall2 {A B} (P : A -> B -> Type) :
  forall l1 l1' l2, CPermutation_Type l1 l1' -> Forall2_Type P l1 l2 ->
    { l2' : _ & CPermutation_Type l2 l2' & Forall2_Type P l1' l2' }.
Proof.
intros l1 l1' l2 HP.
revert l2 ; induction HP ; intros l2' HF ; inversion HF ; subst.
- exists nil ; auto.
  + reflexivity.
  + symmetry in H0 ; apply app_eq_nil in H0 as [Heq1 Heq2] ; subst.
    constructor.
- destruct l1 ; inversion H0 ; subst.
  + rewrite app_nil_l in H0 ; subst.
    exists (y :: l').
    * reflexivity.
    * rewrite app_nil_l in HF ; simpl ; rewrite app_nil_r ; assumption.
  + apply Forall2_Type_app_inv_l in X0 as ([(la & lb) H1 H2] & Heq).
    simpl in Heq ; rewrite Heq.
    exists (lb ++ y :: la).
    * rewrite app_comm_cons ; constructor.
    * apply Forall2_Type_app ; auto.
      constructor ; auto.
Qed.

Lemma cperm_Type_image {A B} : forall (f : A -> B) a l l',
  CPermutation_Type (a :: l) (map f l') -> { a' | a = f a' }.
Proof.
intros f a l l' HP.
eapply Permutation_Type_image.
apply cperm_perm_Type ; eassumption.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the static semantics of statements and expressions, pg. 63.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.

Inductive K : Delta -> Tau -> Kappa -> Prop :=

 | K_int   : forall (d : Delta),
                  K d cint B

 | K_B     : forall (d : Delta) (alpha : TVar),
                  K (d ++ [(alpha, B)]) (tv_t alpha) B

 | K_star_A  : forall (d : Delta) (alpha : TVar),
                  K  (d ++ [(alpha, A)]) (ptype (tv_t alpha)) B

 | K_B_A     : forall (d : Delta) (tau : Tau),
                  K  d tau B ->
                  K  d tau A

 | K_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (cross t0 t1) A

 | K_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (arrow t0 t1) A

 | K_A_B    :  forall (d : Delta) (tau : Tau),
                    K d tau A ->
                    K d (ptype tau) B

 | K_utype  : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau),
                   K (d ++ [(alpha, k)]) tau A ->
                   getD d alpha = None ->
                   K d (utype alpha k tau) A

 | K_etype  : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau) (p : Phi),
                   getD d alpha = None ->
                   K (d ++ [(alpha, k)]) tau A ->
                   K d (etype p alpha k tau) A.

Inductive AK : Delta -> Tau -> Kappa -> Prop :=

 | AK_K_AK  : forall (d : Delta) (tau : Tau) (k : Kappa),
                   K  d tau k ->
                   AK d tau k

 | AK_A     : forall (d : Delta) (alpha : TVar),
                   AK d (tv_t alpha) A.

Inductive ASGN : Delta -> Tau -> Prop :=

  | ASGN_cint  : forall (d : Delta),
                      ASGN d cint

  | ASGN_B     : forall (d : Delta) (alpha : TVar),
                      ASGN (d ++ [(alpha, B)]) (tv_t alpha)

  | ASGN_ptype : forall (d : Delta) (tau : Tau),
                      ASGN d (ptype tau)

  | ASGN_cross : forall (d : Delta) (t0 t1 : Tau),
                      ASGN d t0 ->
                      ASGN d t1 ->
                      ASGN d (cross t0 t1)

  | ASGN_arrow : forall (d : Delta) (t0 t1 : Tau),
                      ASGN d t0 ->
                      ASGN d t1 ->
                      ASGN d (arrow t0 t1)

  | ASGN_utype : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau),
                      ASGN (d ++ [(alpha, k)]) tau ->
                      ASGN d (utype alpha k tau)

  | ASGN_etype : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau),
                      ASGN (d ++ [(alpha, k)]) tau ->
                      ASGN d (etype nowitnesschange alpha k tau).

Inductive WFDG : Delta -> Gamma -> Prop :=
  | WFDG_d_nil : forall (d: Delta),
                     WFDG d nil
  | WFDG_xt      : forall (d: Delta) (g: Gamma) (x : EVar) (tau : Tau),
                     K d tau A ->
                     WFDG d g ->
                     WFDG d (g ++ [(x,tau)]).

Inductive WFU : Upsilon -> Prop :=
  | WFU_nil : WFU nil
  | WFU_A   : forall (u : Upsilon) (tau : Tau) (p : P) (x : EVar),
                 WFU  u ->
                 K nil tau A ->
                 WFU (u ++ [(p_e x p, tau)]).

Inductive WFC : Delta -> Upsilon -> Gamma -> Prop :=
  | WFC_DGU : forall (d : Delta) (g: Gamma) (u : Upsilon),
                WFDG d g ->
                WFU u ->
                WFC d u g.