Set Implicit Arguments.

Require Import Behavior.
Require Import Expr.

Local Open Scope behavior.
Local Open Scope tla.

Definition refines (A C : Type)
  (m : C -> A)    (* Projection from "concrete" to "abstract" states *)
  (P : Expr A)    (* "Abstract" specification *)
  (Q : Expr C)    (* "Concrete" specification *)
  := valid (Q `=> map m P).

Theorem refines_refl :
  forall (A : Type) (P : Expr A),
    refines (fun x => x) P P.
Proof.
  unfold refines, valid. simpl.
  intros.
  rewrite map_id.
  assumption.
Qed.

Theorem refines_trans :
  forall (A B C : Type) (m1 : B -> A) (m2 : C -> B) P Q R,
    refines m1 P Q ->
    refines m2 Q R ->
    refines (fun x => m1 (m2 x)) P R.
Proof.
  unfold refines, valid. simpl.
  intros A B C m1 m2 P Q R HQP HRQ s H.
  rewrite <- map_map.
  rewrite map_eval.
  apply HQP.
  rewrite <- map_eval.
  apply HRQ.
  assumption.
Qed.

Theorem refinement_preserves_invariant :
  forall (A C : Type)
         (m : C -> A)
         (P : Expr A)
         (Q : Expr C)
         (I : Predicate A),
    refines m P Q ->
    valid (P `=> [] `I) ->
    valid (Q `=> [] map m `I).
Proof.
  unfold refines, valid. simpl. unfold shift. simpl.
  intros A C m P Q I Hrefines Hinv s H n.
  specialize (Hinv (fun x => m (s x))).
  apply Hinv.
  rewrite <- map_eval.
  intuition.
Qed.

Lemma refine_conj :
  forall (A C : Type) s (m : C -> A) Pa Pc Qa Qc,
    eval (Qc `=> map m Qa) s ->
    eval (Pc `=> map m Pa) s ->
    eval (Pc `/\ Qc) s ->
    eval (map m (Pa `/\ Qa)) s.
Proof. firstorder. Qed.

Theorem refine_predicate :
  forall (A C : Type) (m : C -> A) (Pa : Predicate A) (Pc : Predicate C),
    (forall x, Pc x -> Pa (m x)) ->
    refines m `Pa `Pc.
Proof. firstorder. Qed.

Theorem refine_always :
  forall (A C : Type) (m : C -> A) P Q,
    refines m P Q ->
    refines m ([]P) ([]Q).
Proof. firstorder. Qed.
(*
Theorem refine_box :
  forall (A C : Type) (m : C -> A) (ra : Action A) (rc : Action C),
    (forall x y, rc x y -> ra (m x) (m y)) ->
    refines m ([ra]) ([rc]).
Proof.
  unfold refines, valid. simpl.
  intros.
  intuition; auto using f_equal.
Qed.
*)
Theorem refine_always_box :
  forall (A C : Type) (m : C -> A) (ra : Action A) (rc : Action C),
    (forall x y, rc x y -> ra (m x) (m y)) ->
    refines m ([][ra]) ([][rc]).
Proof.
  intros.
  unfold refines, valid. intros s. simpl.
  intros H0 n. specialize H0 with n.
  destruct H0 as [H0|H0]; [left; auto | right; rewrite H0; trivial].
Qed.
(*
Theorem refine_skip_skip :
  forall (A C : Type) (m : C -> A),
    refines m SKIP SKIP.
Proof.
  unfold refines, valid. simpl.
  auto using f_equal.
Qed.
 *)

Lemma disj_pw_impl :
  forall P1 Q1 P2 Q2 : Prop,
    (P1 -> P2) ->
    (Q1 -> Q2) ->
    (P1 \/ Q1) ->
    (P2 \/ Q2).
Proof. firstorder. Qed.


Require Import Reals.
Require Import Psatz.

(**********************)
(** Unitary Programs **)
(**********************)

(* Note: We only support application of 1-, 2-, and 3-qubit unitaries.
   We could instead allow something more general (e.g. application of
   an arbitrary unitary to a list of arguments), but this would make
   proofs longer for little added benefit. *)
Inductive ucom (U: nat -> Set) (dim : nat) : Set :=
| useq :  ucom U dim -> ucom U dim -> ucom U dim
| uapp1 : U 1 -> nat -> ucom U dim
| uapp2 : U 2 -> nat -> nat -> ucom U dim
| uapp3 : U 3 -> nat -> nat -> nat -> ucom U dim.

(* Set the dimension argument to be implicit. *)
Arguments useq {U dim}.
Arguments uapp1 {U dim}.
Arguments uapp2 {U dim}.
Arguments uapp3 {U dim}.

Declare Scope ucom_scope.
Delimit Scope ucom_scope with ucom.
Local Open Scope ucom.
Notation "p1 ; p2" := (useq p1 p2) (at level 50) : ucom_scope.

(** Example Gate Set **)

(* The gate set below is used for computing the semantics of programs. The
   R rotation unitary allows for easy description of any single-qubit gate
   and CNOT is the standard two-qubit gate. *)
Inductive base_Unitary : nat -> Set :=
  | U_R                  : R -> R -> R -> base_Unitary 1
  | U_CNOT               : base_Unitary 2.

Definition base_ucom := ucom base_Unitary.

(* Some useful shorthands. *)
Definition U_H := U_R (PI/2) 0 PI.
Definition U_X := U_R PI 0 PI.
Definition U_Y := U_R PI (PI/2) (PI/2).
Definition U_Z := U_R 0 0 PI.
Definition H {dim} n : base_ucom dim := uapp1 U_H n.
Definition X {dim} n : base_ucom dim := uapp1 U_X n.
Definition Y {dim} n : base_ucom dim := uapp1 U_Y  n.
Definition Z {dim} n : base_ucom dim := uapp1 U_Z n.
Definition ID {dim} n : base_ucom dim := uapp1 (U_R 0 0 0) n.
Definition SKIP {dim} : base_ucom dim := ID 0.
Definition Rx {dim} θ n : base_ucom dim := uapp1 (U_R θ (-(PI/2)) (PI/2)) n.
Definition Ry {dim} θ n : base_ucom dim := uapp1 (U_R θ 0 0) n.
Definition Rz {dim} λ n : base_ucom dim := uapp1 (U_R 0 0 λ) n.
Definition T {dim} n : base_ucom dim := Rz (PI / 4) n.
Definition TDAG {dim} n : base_ucom dim := Rz (- (PI / 4)) n.
Definition P {dim} n : base_ucom dim := Rz (PI / 2) n.
Definition PDAG {dim} n : base_ucom dim := Rz (- (PI / 2)) n.
Definition CNOT {dim} m n : base_ucom dim := uapp2 U_CNOT m n.
Definition CZ {dim} m n : base_ucom dim :=
  H n ; CNOT m n ; H n.
Definition SWAP {dim} m n : base_ucom dim :=
  CNOT m n; CNOT n m; CNOT m n.
Definition U1 {dim} a n : base_ucom dim := uapp1 (U_R 0 0 a) n.
Definition U2 {dim} a b n : base_ucom dim := uapp1 (U_R (PI / 2) a b) n.
Definition U3 {dim} a b c n : base_ucom dim := uapp1 (U_R a b c) n.

(* Standard Toffoli decomposition *)
Definition CCX {dim} a b c : base_ucom dim :=
  H c ; CNOT b c ; TDAG c ; CNOT a c ;
  T c ; CNOT b c ; TDAG c ; CNOT a c ;
  CNOT a b ; TDAG b ; CNOT a b ;
  T a ; T b ; T c ; H c.

(* CCZ is the same as CCX, but without the Hadamards *)
Definition CCZ {dim} a b c : base_ucom dim :=
  CNOT b c ; TDAG c ; CNOT a c ;
  T c ; CNOT b c ; TDAG c ; CNOT a c ;
  CNOT a b ; TDAG b ; CNOT a b ;
  T a ; T b ; T c.

(*************************)
(** Well Typed Circuits **)
(*************************)

Inductive uc_well_typed {U dim} : ucom U dim -> Prop :=
| WT_seq : forall c1 c2, uc_well_typed c1 -> uc_well_typed c2 -> uc_well_typed (c1; c2)
| WT_app1 : forall u n, n < dim -> uc_well_typed (uapp1 u n)
| WT_app2 : forall u m n, m < dim -> n < dim -> m <> n -> uc_well_typed (uapp2 u m n)
| WT_app3 : forall u m n p, m < dim -> n < dim -> p < dim ->
    m <> n -> n <> p -> m <> p -> uc_well_typed (uapp3 u m n p).

(* No ucom is well-typed for dim = 0. *)
Lemma uc_well_typed_implies_dim_nonzero : forall {U dim} (c : ucom U dim),
  uc_well_typed c -> dim > 0.
Proof.
  intros U dim c WT.
  induction WT; try apply (Nat.lt_lt_0 n); assumption.
Qed.

(* Equivalent boolean version *)
Fixpoint uc_well_typed_b {U dim} (c : ucom U dim) : bool :=
  match c with
  | c1 ; c2 => uc_well_typed_b c1 && uc_well_typed_b c2
  | uapp1 _ n => n <? dim
  | uapp2 _ m n => (m <? dim) && (n <? dim) && (negb (m =? n))
  | uapp3 _ m n p => (m <? dim) && (n <? dim) && (p <? dim) &&
      (negb (m =? n)) && (negb (n =? p)) && (negb (m =? p))
  end.

Lemma uc_well_typed_b_equiv : forall {U dim} (c : ucom U dim),
  uc_well_typed_b c = true <-> uc_well_typed c.
Proof.
  intros U dim c. split; intros H.
  - induction c;
    constructor;
    simpl in H;
    repeat match goal with
    | H : (_ && _)%bool = true |- _ => apply Bool.andb_true_iff in H as [? ?]
    | H : (_ <? _) = true |- _ => apply Nat.ltb_lt in H
    | H : negb (_ =? _) = true |- _ => apply Bool.negb_true_iff in H;
                                     apply Nat.eqb_neq in H
    end;
    try apply IHc1;
    try apply IHc2;
    assumption.
  - induction H; subst; simpl;
    repeat match goal with
    | |- (_ && _)%bool = true => apply Bool.andb_true_iff; split
    | |- (_ <? _) = true => apply Nat.ltb_lt
    | |- negb (_ =? _) = true => apply Bool.negb_true_iff; apply Nat.eqb_neq
    end;
    try apply IHuc_well_typed1;
    try apply IHuc_well_typed2;
    assumption.
Qed.

Local Close Scope ucom.

(**********************)
(** General Programs **)
(**********************)

Declare Scope com_scope.
Delimit Scope com_scope with com.
Local Open Scope com_scope.

Inductive com (U: nat -> Set) (dim : nat) : Set :=
| skip : com U dim
| seq : com U dim -> com U dim -> com U dim
| uc : ucom U dim -> com U dim
| meas : nat -> com U dim -> com U dim -> com U dim.

Arguments skip {U dim}.
Arguments seq {U dim}.
Arguments uc {U dim}.
Arguments meas {U dim}.

Definition from_ucom {U dim} (c : ucom U dim) : com U dim := uc c.
Coercion from_ucom : ucom >-> com.

Notation "p1 ; p2" := (seq p1 p2) (at level 50) : com_scope.
Notation "'mif' n 'then' p1 'else' p2" := (meas n p1 p2) (at level 40) : com_scope.
Notation "'measure' n" := (meas n skip skip) (at level 40) : com_scope.
Notation "'reset' n" := (meas n (X n) skip) (at level 40) : com_scope.
Notation "n <- 1" := (meas n skip (X n)) (at level 20) : com_scope.
Notation "n <- 0" := (reset n) (at level 20) : com_scope.

Definition base_com := com base_Unitary.

(* Well-typedness for non-unitary programs. *)
Inductive c_well_typed {U dim} : com U dim -> Prop :=
| WT_skip : c_well_typed skip
| WT_cseq : forall c1 c2, c_well_typed c1 -> c_well_typed c2 -> c_well_typed (c1; c2)
| WT_uc : forall u, uc_well_typed u -> c_well_typed (uc u)
| WT_meas : forall n c1 c2, n < dim -> c_well_typed c1 -> c_well_typed c2 -> c_well_typed (meas n c1 c2).

(*****************************)
(** Higher-level Constructs **)
(*****************************)

Fixpoint crepeat {U dim} (k : nat) (p : com U dim) : com U dim :=
  match k with
  | 0    => skip
  | S k' => p ; crepeat k' p
  end.

Fixpoint while {U dim} (max_iters : nat) (n : nat) (p : com U dim) : com U dim :=
  match max_iters with
  | 0        => skip
  | S iters' => mif n then p ; while iters' n p else skip
  end.


(* Finite maps for labels *)

Require Import Coq.Strings.Ascii Coq.NArith.NArith Coq.Strings.String Coq.Structures.OrderedType Coq.FSets.FMapAVL.

Require Import Bedrock.Nomega Bedrock.Labels.

Local Open Scope string_scope.
Local Open Scope N_scope.

Definition ascii_lt (a1 a2 : ascii) := N_of_ascii a1 < N_of_ascii a2.

Fixpoint string_lt (s1 s2 : string) : bool :=
  match s1, s2 with
    | "", String _ _ => true
    | String _ _, "" => false
    | String a1 s1', String a2 s2' => match (N_of_ascii a1) ?= (N_of_ascii a2) with
                                        | Datatypes.Lt => true
                                        | Gt => false
                                        | Datatypes.Eq => string_lt s1' s2'
                                      end
    | _, _ => false
  end.

Section CompSpec.
  Variables (A : Type) (eq lt : A -> A -> Prop)
    (x y : A) (c : comparison).

  Hypothesis H : CompSpec eq lt x y c.

  Theorem Comp_eq : (forall z, lt z z -> False)
    -> x = y -> c = Datatypes.Eq.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.

  Theorem Comp_lt : (forall z z', lt z z' -> eq z z' -> False)
    -> (forall z z', lt z z' -> lt z' z -> False)
    -> lt x y -> c = Datatypes.Lt.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.

  Theorem Comp_gt : (forall z z', lt z' z -> eq z z' -> False)
    -> (forall z z', lt z z' -> lt z' z -> False)
    -> lt y x -> c = Datatypes.Gt.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.
End CompSpec.

Implicit Arguments Comp_eq [A eq0 lt x y c].
Implicit Arguments Comp_lt [A eq0 lt x y c].
Implicit Arguments Comp_gt [A eq0 lt x y c].

Theorem Nlt_irrefl' : forall n : N, n < n -> False.
  exact Nlt_irrefl.
Qed.

Theorem Nlt_irrefl'' : forall n n' : N, n = n' -> n < n' -> False.
  intros; subst; eapply Nlt_irrefl'; eauto.
Qed.

Theorem Nlt_notboth : forall x y, x < y -> y < x -> False.
  intros; eapply Nlt_irrefl'; eapply Nlt_trans; eauto.
Qed.

Hint Immediate Nlt_irrefl' Nlt_irrefl'' Nlt_notboth.

Ltac rewr' := eauto; congruence || eapply Nlt_trans; eassumption.

Ltac rewr := repeat match goal with
                      | [ _ : context[?X ?= ?Y] |- _ ] => specialize (Ncompare_spec X Y); destruct (X ?= Y); inversion 1
                    end; simpl in *; (rewrite (Comp_eq (@Ncompare_spec _ _)); rewr')
  || (rewrite (Comp_lt (@Ncompare_spec _ _)); rewr')
    || (rewrite (Comp_gt (@Ncompare_spec _ _)); rewr').

Theorem string_lt_trans : forall s1 s2 s3, string_lt s1 s2 = true
  -> string_lt s2 s3 = true
  -> string_lt s1 s3 = true.
  induction s1; simpl; intuition; destruct s2; destruct s3; simpl in *; try congruence; rewr.
Qed.

Section hide_hints.
  Hint Resolve string_lt_trans.

  Theorem string_lt_irrel : forall s, string_lt s s = false.
    induction s; simpl; intuition rewr.
  Qed.

  Hint Rewrite string_lt_irrel : LabelMap.

  Lemma string_tail_neq : forall a1 a2 s1 s2,
    N_of_ascii a1 = N_of_ascii a2
    -> (String a1 s1 = String a2 s2 -> False)
    -> (s1 = s2 -> False).
    intros.
    apply (f_equal ascii_of_N) in H.
    repeat rewrite ascii_N_embedding in H.
    congruence.
  Qed.

  Hint Immediate string_tail_neq.

  Theorem string_lt_sym : forall s1 s2, s1 <> s2
    -> string_lt s1 s2 = false
    -> string_lt s2 s1 = true.
    induction s1; destruct s2; simpl; intuition; rewr.
  Qed.

  Hint Resolve string_lt_sym.

  Definition label'_lt (l1 l2 : label') : bool :=
    match l1, l2 with
      | Global _, Local _ => true
      | Local _, Global _ => false
      | Global s1, Global s2 => string_lt s1 s2
      | Local n1, Local n2 => match n1 ?= n2 with
                                | Datatypes.Lt => true
                                | _ => false
                              end
    end.

  Theorem label'_lt_trans : forall l1 l2 l3, label'_lt l1 l2 = true
    -> label'_lt l2 l3 = true
    -> label'_lt l1 l3 = true.
    induction l1; simpl; intuition; destruct l2; destruct l3; simpl in *; try congruence; eauto; rewr.
  Qed.

  Hint Immediate label'_lt_trans.

  Theorem label'_lt_irrel : forall l, label'_lt l l = false.
    induction l; simpl; intuition; autorewrite with LabelMap; auto; rewr.
  Qed.

  Hint Rewrite label'_lt_irrel : LabelMap.

  Theorem label'_lt_sym : forall l1 l2, l1 <> l2
    -> label'_lt l1 l2 = false
    -> label'_lt l2 l1 = true.
    induction l1; destruct l2; simpl; intuition.
    eapply string_lt_sym; eauto; congruence.
    rewr.
  Qed.

  Hint Resolve label'_lt_sym.

  Definition label'_eq : forall x y : label', {x = y} + {x <> y}.
    decide equality; apply string_dec || apply N_eq_dec.
  Defined.
End hide_hints.

Module LabelKey.
  Definition t := label.

  Definition eq := @eq t.
  Definition lt (l1 l2 : label) := string_lt (fst l1) (fst l2) = true
    \/ (fst l1 = fst l2 /\ label'_lt (snd l1) (snd l2) = true).

  Theorem eq_refl : forall x : t, eq x x.
    congruence.
  Qed.

  Theorem eq_sym : forall x y : t, eq x y -> eq y x.
    congruence.
  Qed.

  Theorem eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    congruence.
  Qed.

  Section hide_hints.
    Hint Resolve string_lt_trans.
    Hint Rewrite string_lt_irrel : LabelMap.
    Hint Immediate string_tail_neq.
    Hint Resolve string_lt_sym.
    Hint Immediate label'_lt_trans.
    Hint Rewrite label'_lt_irrel : LabelMap.
    Hint Resolve label'_lt_sym.
    Hint Rewrite string_lt_irrel label'_lt_irrel : LabelMap.

    Theorem lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
      unfold lt; intuition (congruence || eauto).
    Qed.

    Theorem lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
      unfold lt, eq; intuition; subst; autorewrite with LabelMap in *; discriminate.
    Qed.

    Definition compare' (x y : t) : comparison :=
      if string_lt (fst x) (fst y)
        then Datatypes.Lt
        else if string_dec (fst x) (fst y)
          then if label'_lt (snd x) (snd y)
            then Datatypes.Lt
            else if label'_eq (snd x) (snd y)
              then Datatypes.Eq
              else Gt
          else Gt.

    Lemma label_eq : forall x y : label, fst x = fst y
      -> snd x = snd y
      -> x = y.
      destruct x; destruct y; simpl; congruence.
    Qed.

    Hint Immediate label_eq.

    Definition compare (x y : t) : Structures.OrderedType.Compare lt eq x y.
      refine (match compare' x y as c return c = compare' x y -> Structures.OrderedType.Compare lt eq x y with
                | Datatypes.Lt => fun _ => Structures.OrderedType.LT _
                | Datatypes.Eq => fun _ => Structures.OrderedType.EQ _
                | Gt => fun _ => Structures.OrderedType.GT _
              end (refl_equal _)); abstract (unfold compare', eq, lt in *;
                repeat match goal with
                         | [ H : context[if ?E then _ else _] |- _ ] => let Heq := fresh "Heq" in case_eq E; (intros ? Heq || intro Heq);
                           rewrite Heq in H; try discriminate
                       end; intuition).
    Defined.

    Definition eq_dec x y : { eq x y } + { ~ eq x y }.
      refine (if string_dec (fst x) (fst y)
        then if label'_eq (snd x) (snd y)
          then left _ _
          else right _ _
        else right _ _); abstract (unfold eq in *; destruct x; destruct y; simpl in *; congruence).
    Defined.
  End hide_hints.
End LabelKey.

Module LabelMap := FMapAVL.Make(LabelKey).

Remove Hints LabelMap.E.eq_sym LabelMap.E.eq_refl LabelMap.E.eq_trans LabelMap.E.lt_not_eq LabelMap.E.lt_trans
  LabelMap.Raw.Proofs.L.PX.eqk_refl LabelMap.Raw.Proofs.L.PX.eqk_sym
  LabelMap.Raw.Proofs.L.PX.eqk_trans
  LabelMap.Raw.Proofs.PX.eqk_refl LabelMap.Raw.Proofs.PX.eqk_sym LabelMap.Raw.Proofs.PX.eqk_trans
  LabelMap.Raw.Proofs.L.PX.eqke_refl LabelMap.Raw.Proofs.L.PX.eqke_sym LabelMap.Raw.Proofs.L.PX.eqke_trans
  LabelMap.Raw.Proofs.PX.eqke_refl LabelMap.Raw.Proofs.PX.eqke_sym LabelMap.Raw.Proofs.PX.eqke_trans
  LabelMap.Raw.Proofs.L.PX.MO.lt_eq LabelMap.Raw.Proofs.L.PX.MO.eq_lt LabelMap.Raw.Proofs.L.MX.lt_eq
  LabelMap.Raw.Proofs.L.MX.eq_lt LabelMap.Raw.Proofs.PX.MO.lt_eq LabelMap.Raw.Proofs.PX.MO.eq_lt
  LabelMap.Raw.Proofs.MX.lt_eq LabelMap.Raw.Proofs.MX.eq_lt
  LabelMap.Raw.Proofs.L.PX.eqk_ltk LabelMap.Raw.Proofs.L.PX.ltk_eqk LabelMap.Raw.Proofs.L.PX.ltk_trans
  LabelMap.Raw.Proofs.PX.eqk_ltk LabelMap.Raw.Proofs.PX.ltk_eqk LabelMap.Raw.Proofs.PX.ltk_trans
  LabelMap.Raw.Proofs.L.PX.MO.lt_antirefl
  LabelMap.Raw.Proofs.L.MX.lt_antirefl LabelMap.Raw.Proofs.PX.MO.lt_antirefl LabelMap.Raw.Proofs.MX.lt_antirefl
  LabelMap.Raw.Proofs.L.PX.eqk_not_ltk LabelMap.Raw.Proofs.L.PX.ltk_not_eqke
  LabelMap.Raw.Proofs.L.PX.ltk_not_eqk LabelMap.Raw.Proofs.L.PX.MO.lt_not_gt
  LabelMap.Raw.Proofs.L.PX.MO.eq_not_gt LabelMap.Raw.Proofs.L.PX.MO.eq_neq
  LabelMap.Raw.Proofs.L.PX.MO.neq_eq LabelMap.Raw.Proofs.L.PX.MO.eq_le
  LabelMap.Raw.Proofs.L.PX.MO.le_eq LabelMap.Raw.Proofs.L.PX.MO.eq_not_lt
  LabelMap.Raw.Proofs.L.PX.MO.gt_not_eq LabelMap.Raw.Proofs.L.MX.lt_not_gt
  LabelMap.Raw.Proofs.L.MX.eq_not_gt LabelMap.Raw.Proofs.L.MX.eq_neq
  LabelMap.Raw.Proofs.L.MX.neq_eq LabelMap.Raw.Proofs.L.MX.eq_le
  LabelMap.Raw.Proofs.L.MX.le_eq LabelMap.Raw.Proofs.L.MX.eq_not_lt
  LabelMap.Raw.Proofs.L.MX.gt_not_eq LabelMap.Raw.Proofs.PX.eqk_not_ltk
  LabelMap.Raw.Proofs.PX.ltk_not_eqke LabelMap.Raw.Proofs.PX.ltk_not_eqk
  LabelMap.Raw.Proofs.PX.MO.lt_not_gt LabelMap.Raw.Proofs.PX.MO.eq_not_gt
  LabelMap.Raw.Proofs.PX.MO.eq_neq LabelMap.Raw.Proofs.PX.MO.neq_eq
  LabelMap.Raw.Proofs.PX.MO.eq_le LabelMap.Raw.Proofs.PX.MO.le_eq
  LabelMap.Raw.Proofs.PX.MO.eq_not_lt LabelMap.Raw.Proofs.PX.MO.gt_not_eq
  LabelMap.Raw.Proofs.MX.lt_not_gt LabelMap.Raw.Proofs.MX.eq_not_gt
  LabelMap.Raw.Proofs.MX.eq_neq LabelMap.Raw.Proofs.MX.neq_eq
  LabelMap.Raw.Proofs.MX.eq_le LabelMap.Raw.Proofs.MX.le_eq
  LabelMap.Raw.Proofs.MX.eq_not_lt LabelMap.Raw.Proofs.MX.gt_not_eq
  LabelMap.Raw.Proofs.L.PX.Sort_Inf_NotIn LabelMap.Raw.Proofs.PX.Sort_Inf_NotIn
  LabelMap.Raw.Proofs.L.PX.Inf_eq LabelMap.Raw.Proofs.L.PX.MO.Inf_lt
  LabelMap.Raw.Proofs.L.MX.Inf_lt LabelMap.Raw.Proofs.PX.Inf_eq
  LabelMap.Raw.Proofs.PX.MO.Inf_lt LabelMap.Raw.Proofs.MX.Inf_lt
  LabelMap.Raw.Proofs.L.PX.Inf_lt LabelMap.Raw.Proofs.L.PX.MO.Inf_lt
  LabelMap.Raw.Proofs.L.MX.Inf_lt LabelMap.Raw.Proofs.PX.Inf_lt
  LabelMap.Raw.Proofs.PX.MO.Inf_lt LabelMap.Raw.Proofs.MX.Inf_lt
  LabelMap.Raw.InRight LabelMap.Raw.InLeft LabelMap.Raw.InRoot
  LabelMap.Raw.Proofs.L.PX.InA_eqke_eqk LabelMap.Raw.Proofs.L.PX.MO.In_eq
  LabelMap.Raw.Proofs.L.PX.MO.ListIn_In LabelMap.Raw.Proofs.L.MX.In_eq
  LabelMap.Raw.Proofs.L.MX.ListIn_In LabelMap.Raw.Proofs.PX.InA_eqke_eqk
  LabelMap.Raw.Proofs.PX.MO.In_eq LabelMap.Raw.Proofs.PX.MO.ListIn_In
  LabelMap.Raw.Proofs.MX.In_eq LabelMap.Raw.Proofs.MX.ListIn_In
  LabelMap.Raw.Proofs.L.PX.In_inv_3 LabelMap.Raw.Proofs.PX.In_inv_3
  LabelMap.Raw.Proofs.L.PX.In_inv_2 LabelMap.Raw.Proofs.PX.In_inv_2
  LabelMap.Raw.MapsRight LabelMap.Raw.MapsLeft
  LabelMap.Raw.MapsRoot LabelMap.Raw.Proofs.L.PX.MO.Sort_NoDup
  LabelMap.Raw.Proofs.L.MX.Sort_NoDup LabelMap.Raw.Proofs.PX.MO.Sort_NoDup
  LabelMap.Raw.Proofs.MX.Sort_NoDup
  LabelMap.Raw.BSLeaf LabelMap.Raw.BSNode LabelMap.Raw.Leaf LabelMap.Raw.Node.

Require Coq.FSets.FMapFacts.
Module LabelFacts := FMapFacts.WFacts_fun(LabelKey)(LabelMap).


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Infrastructure.

Require Import List. Import ListNotations.
Require Import Strings.String.

Lemma Typing_chk: forall G e A,
  Typing G e Inf A ->
  exists B, Typing G e Chk B.
Proof.
  introv Typ.
  inductions Typ; eauto.
Qed.

Lemma Typing_chk2: forall G e A,
  Typing G e Chk A ->
  exists B, Typing G e Inf B.
Proof.
  introv Typ.
  inductions Typ; eauto.
Qed.

(* Common Lemmas *)
Lemma Typing_regular_1 : forall e G dir A,
    Typing G e dir A -> lc_exp e.
Proof.
  intros e G dir A H.
  induction H;
    eauto.
Qed.

Lemma Typing_regular_2 : forall G e dir T,
    Typing G e dir T -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Lemma Typing_weaken : forall G E F e dir T,
    Typing (E ++ G) e dir T ->
    uniq (E ++ F ++ G) ->
    Typing (E ++ F ++ G) e dir T.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply Typ_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma Typing_weakening : forall (E F : ctx) e dir T,
    Typing E e dir T ->
    uniq (F ++ E) ->
    Typing (F ++ E) e dir T.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply~ Typing_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma fv_in_dom: forall G e dir T,
    Typing G e dir T -> fv_exp e [<=] dom G.
Proof.
  intros G e dir T H.
  induction H; simpl; try fsetdec.
  - Case "typing_var".
    apply binds_In in H0.
    fsetdec.
  - Case "typing_abs".
    pick fresh x.
    assert (Fx : fv_exp (open_exp_wrt_exp e (e_var_f x)) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (open_exp_wrt_exp e (e_var_f x))) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma value_no_fv : forall v dir T,
    Typing [] v dir T -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (fv_in_dom [] v).
  intuition eauto.
Qed.

Lemma subst_value : forall v dir T z u,
    Typing [] v dir T -> subst_exp u z v = v.
Proof.
  intros v dir T z u Typ.
  lets* Fv: value_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma Typing_subst_1 : forall (E F : ctx) e u dir S T (z : atom),
    Typing (F ++ [(z,S)] ++ E) e dir T ->
    Typing E u Inf S ->
    Typing (F ++ E) ([z ~> u] e) dir T.
Proof.
  intros.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  induction H; intros F Eq; subst; simpl; autos*;
    lets Lc  : Typing_regular_1 H0;
    lets Uni : Typing_regular_2 H0.
  -
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    apply~ Typing_weakening.
    solve_uniq.
  -
    pick fresh x and apply Typ_abs; eauto.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
Qed.

Lemma typing_c_subst_simpl : forall E e u dir S T z,
  Typing ([(z,S)] ++ E) e dir T ->
  Typing E u Inf S ->
  Typing E ([z ~> u] e) dir T.
Proof.
  intros E e u dir S T z H1 H2.
  rewrite_env (nil ++ E).
  eapply Typing_subst_1.
    simpl_env. apply H1.
    apply H2.
Qed.

Lemma principle_inf: forall v A,
  value v -> Typing nil v Inf A -> (principal_type v) = A .
Proof.
  introv Val Typ.
  gen A.
  induction Val; introv  Typ; try solve [inverts* Typ].
Qed.

(* stronger than inf unique *)
Lemma Typing_strenthening : forall G e A1 A2,
    []  ⊢ e ⇒ A1 ->
    G ⊢ e ⇒ A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2 G.
  inductions Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    inverts H0.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
Qed.

Lemma inference_unique : forall G e A1 A2,
    Typing G e Inf A1 ->
    Typing G e Inf A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2.
  induction Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
Qed.


 Require Import Coq.Arith.Arith .
Require Import Coq.Bool.Bool .
Require Export Coq.Strings.String .
Require Import Coq.Logic.FunctionalExtensionality .
Require Import Coq.Lists.List .
Import ListNotations.
Require Import Coq.Logic.ProofIrrelevance.
Require Import ZArith.

(* A: tuple constructors*)
Record person := mkPerson{
  pname: string
}.

Record staff := mkStaff {
  sp : person;
  jobTitle: string
}.

Record faculty := mkFaculty{
  fp: person;
  rank: string
  fpapers: list string;
}.

Record student := mkStudent{
  stname: string;
  spapers: list string;
}.

(* B: tuple constructors*)
Record staff' := mkStaff'{
  sname : string;
  sjobTitle: string;
}.

Record faculty' := mkFaculty'{
  fname : string;
  frank: string;
}.

Export ListNotations.

(* Staff to Person *)
Definition staff_toPerson (s:staff) : person := sp s.
Definition staff_toPersonList (sl: list staff) := map staff_toPerson sl.

(* Staff to Staff' *)
Definition staff_toStaff' (s:staff) : staff' :=
  match s with
  |mkStaff (mkPerson i n) j => mkStaff' i n j
end.
Definition staff_toStaff'List (sl: list staff) := map staff_toStaff' sl.

(* Faculty to Person *)
Definition faculty_toPerson (f:faculty) : person := fp f.
Definition faculty_toPersonList (fl: list faculty) := map faculty_toPerson fl.

(* Faculty to Faculty' *)
Definition faculty_toFaculty' (f:faculty) : faculty' :=
  match f with
  |mkFaculty (mkPerson i n) j => mkFaculty' i n j
end.
Definition faculty_toFaculty'List (fl: list faculty) := map faculty_toFaculty' fl.

(* Staff' to Person *)
Definition staff'_toPerson (s':staff') : person :=
  match s' with
  |mkStaff' i n _ => mkPerson i n
end.
Definition staff'_toPersonList (sl': list staff') := map staff'_toPerson sl'.

(* Faculty' to Person *)
Definition faculty'_toPerson (f':faculty') : person :=
  match f' with
  |mkFaculty' i n _ => mkPerson i n
end.
Definition faculty'_toPersonList (fl': list faculty') := map faculty'_toPerson fl'.

(* Staff' to Staff *)
Definition staff'_toStaff (s': staff') : staff :=
 match s' with
  |mkStaff' i n j => mkStaff (mkPerson i n) j
end.
Definition staff'_toSaffList (sl': list staff') := map staff'_toStaff sl'.

(* Faculty' to Faculty *)
Definition faculty'_toFaculty (f': faculty') : faculty :=
 match f' with
  |mkFaculty' i n r => mkFaculty (mkPerson i n) r
end.
Definition faculty'_toFacultyList (fl': list faculty') :=
map faculty'_toFaculty fl'.

Definition disjoint {A: Type}(l m:list A) := forall a:A, In a l -> ~ In a m.

Definition abstract (super: list person) (sub1: list person) (sub2: list person):=
 super = sub1 ++ sub2 /\ disjoint sub1 sub2.

(* A: database constructor *)
Record class_diagram := mkCD{
  person_list: list person;
  staff_list: list staff;
  faculty_list: list faculty;
  abstract_inh: abstract person_list (map sp staff_list) (map fp faculty_list);

  v_staff'_list:= (staff_toStaff'List staff_list);
  v_faculty'_list := (faculty_toFaculty'List faculty_list)
}.

(* B: database constructor *)
Record class_diagram' := mkCD'{
  staff'_list: list staff';
  faculty'_list: list faculty';
  constraint': disjoint (staff'_toPersonList staff'_list) (faculty'_toPersonList faculty'_list);

  v_staff_list:= (staff'_toSaffList staff'_list);
  v_faculty_list:= (faculty'_toFacultyList faculty'_list);
  v_person_list:= (staff'_toPersonList staff'_list) ++ (faculty'_toPersonList faculty'_list);
}.

Lemma staff'List: forall sl': list staff',
staff'_toPersonList sl' = staff_toPersonList (staff'_toSaffList sl').
Proof.
intros.
induction sl'.
- reflexivity.
- simpl. f_equal.
  + destruct a as [sid sname sjobTitle]. simpl. reflexivity.
  + assumption.
Qed.

Lemma faculty'List: forall fl': list faculty',
faculty'_toPersonList fl' = faculty_toPersonList (faculty'_toFacultyList fl').
Proof.
intros.
induction fl'.
- reflexivity.
- simpl. f_equal.
  + destruct a as [fid fname frank]. simpl. reflexivity.
  + assumption.
Qed.

Lemma reconstructStaffList : forall sl: list staff,
sl = staff'_toSaffList (staff_toStaff'List sl).
Proof.
induction sl as [|s sl].
-reflexivity.
- rewrite IHsl. simpl. replace (staff'_toStaff (staff_toStaff' s)) with s.
  + f_equal. rewrite <- IHsl. assumption.
  + destruct s as [[i n] j]. reflexivity.
Qed.

Lemma reconstructFacultyList : forall fl: list faculty,
fl = faculty'_toFacultyList (faculty_toFaculty'List fl).
Proof.
induction fl as [|f fl].
-reflexivity.
- rewrite IHfl. simpl. replace (faculty'_toFaculty (faculty_toFaculty' f)) with f.
  + f_equal. rewrite <- IHfl. assumption.
  + destruct f as [[i n] r]. reflexivity.
Qed.

Lemma staffPerson: forall sl: list staff,
(staff_toPersonList sl) = (staff'_toPersonList (staff_toStaff'List sl)).
Proof.
induction sl as [| s sl].
reflexivity.
simpl.
f_equal.
- destruct s as [[pid pname] jobTitle]. simpl. reflexivity.
- assumption.
Qed.

Lemma facultyPerson: forall fl: list faculty,
(faculty_toPersonList fl) =
    (faculty'_toPersonList (faculty_toFaculty'List fl)).
Proof.
induction fl as [| f fl].
reflexivity.
simpl.
f_equal.
- destruct f as [[pid pname] rank]. simpl. reflexivity.
- assumption.
Qed.

Lemma toCD'Const: forall pl sl fl,
abstract pl sl fl->
         disjoint (staff'_toPersonList (staff_toStaff'List sl))
  (faculty'_toPersonList (faculty_toFaculty'List fl)).
Proof.
intros.
unfold abstract in H.
inversion H.
rewrite <- staffPerson.
rewrite <- facultyPerson.
assumption.
Qed.

Definition toCD' (cd:class_diagram) : class_diagram' :=
  match cd with
  | mkCD pl sl fl abs vsl' vfl' => mkCD' vsl' vfl' (toCD'Const pl sl fl abs)
end.

Definition toCD'_Def (cd: class_diagram) : class_diagram'.
Proof.
destruct cd as [pl sl fl abs vsl' vfl'].
refine{|staff'_list:=vsl';  faculty'_list:=vfl'|}.
unfold abstract in abs.
inversion abs.
unfold vsl', vfl'.
rewrite <- staffPerson.
rewrite <- facultyPerson.
assumption.
Defined.

Lemma staff'Person: forall sl': list staff',
(staff'_toPersonList sl') = (staff_toPersonList (staff'_toSaffList sl')).
Proof.
induction sl' as [| s' sl'].
reflexivity.
simpl.
f_equal.
- destruct s' as [sid sname jobTitle']. simpl. reflexivity.
- assumption.
Qed.

Lemma faculty'Person: forall fl': list faculty',
(faculty'_toPersonList fl') = (faculty_toPersonList (faculty'_toFacultyList fl')).
Proof.
induction fl' as [| f' fl'].
reflexivity.
simpl.
f_equal.
- destruct f' as [fid fname rank']. simpl. reflexivity.
- assumption.
Qed.

Lemma toCDConst: forall sl' fl',
disjoint (staff'_toPersonList sl')
  (faculty'_toPersonList fl') -> abstract (staff'_toPersonList sl' ++
       faculty'_toPersonList fl') (staff'_toSaffList sl')
   (faculty'_toFacultyList fl').
Proof.
intros.
unfold abstract.
split.
- rewrite <- staff'List.
  rewrite <- faculty'List.
  reflexivity.
- rewrite <- staff'Person.
  rewrite <- faculty'Person.
  assumption.
Qed.

Definition toCD (cd':class_diagram') : class_diagram :=
  match cd' with
  | mkCD' sl' fl' disj' vsl vfl vpl => mkCD vpl vsl vfl (toCDConst sl' fl' disj')
end.

Definition toCD_Def (cd': class_diagram') : class_diagram.
Proof.
destruct cd' as [sl' fl' disj' vsl vfl vpl].
refine{|person_list:= vpl; staff_list:= vsl; faculty_list:= vfl |}.
unfold abstract.
split.
- unfold vpl, vsl, vfl.
  rewrite <- staff'List.
  rewrite <- faculty'List.
  reflexivity.
- unfold vsl, vfl.
  rewrite <- staff'Person.
  rewrite <- faculty'Person.
  assumption.
Defined.

(** Th1: CD -> CD' -> CD **)

Definition transportAbstract (fn : list person -> list staff -> list faculty -> Type)
  {p1 p2: list person} {s1 s2 : list staff} {f1 f2: list faculty} :
  p1 = p2 -> s1 = s2 -> f1 = f2 -> fn p1 s1 f1-> fn p2 s2 f2.
Proof.
  intros H1 H2 H3.
  rewrite <- H1; rewrite <- H2; rewrite <- H3.
  firstorder.
Defined.

Lemma eqConst (cd1 cd2 : class_diagram)
      (p: person_list cd1 = person_list cd2)
      (q : staff_list cd1 = staff_list cd2)
      (r : faculty_list cd1 = faculty_list cd2) :
  transportAbstract abstract p q r  (abstract_inh cd1) = abstract_inh cd2 ->
  cd1 = cd2.
Proof.
  destruct cd1; destruct cd2.
  simpl in * |- *.
  destruct p.
  destruct q.
  destruct r.
  intros [].
  reflexivity.
Qed.

Lemma eqPersonList: forall cd,
person_list cd = person_list (toCD (toCD' cd)).
Proof.
intros.
unfold toCD, toCD'.
destruct cd as [pl sl fl abs].
unfold person_list.
unfold abstract in abs.
inversion abs.
rewrite <- staffPerson.
rewrite <- facultyPerson.
assumption.
Qed.

Lemma eqStaffList: forall cd,
  staff_list cd = staff_list (toCD (toCD' cd)).
Proof.
intros.
unfold toCD, toCD'.
destruct cd as [pl sl fl abs].
unfold staff_list.
apply reconstructStaffList.
Qed.

Lemma eqFacultyList: forall cd,
 faculty_list cd = faculty_list (toCD (toCD' cd)).
Proof.
intros.
unfold toCD, toCD'.
destruct cd as [pl sl fl abs].
unfold faculty_list.
apply reconstructFacultyList.
Qed.

Theorem th1: forall cd:class_diagram,
  cd = toCD (toCD' cd).
Proof.
intros cd.
pose proof (eqConst cd (toCD (toCD' cd))).
apply (H (eqPersonList cd) (eqStaffList cd) (eqFacultyList cd) ).
apply proof_irrelevance.
Qed.

(** Th2: CD' -> CD -> CD' **)

Definition disjointCast (sl': list staff') (fl': list faculty'):=
disjoint (staff'_toPersonList sl') (faculty'_toPersonList fl').

Definition transportDisjoint (fn : list staff' -> list faculty' -> Type)
  {s1 s2 : list staff'} {f1 f2: list faculty'} :
   s1 = s2 -> f1 = f2 -> fn s1 f1-> fn s2 f2.
Proof.
  intros H1 H2.
  rewrite <- H1; rewrite <- H2.
  firstorder.
Defined.

Lemma eqConst' (cd1 cd2 : class_diagram')
      (p : staff'_list cd1 = staff'_list cd2)
      (q : faculty'_list cd1 = faculty'_list cd2) :
  transportDisjoint disjointCast p q (constraint' cd1) = constraint' cd2 ->
  cd1 = cd2.
Proof.
  destruct cd1; destruct cd2.
  simpl in * |- *.
  destruct p.
  destruct q.
  intros [].
  reflexivity.
Qed.

Lemma reconstructStaffList' : forall sl': list staff',
sl' = staff_toStaff'List (staff'_toSaffList sl').
Proof.
induction sl' as [|s' sl'].
-reflexivity.
- rewrite IHsl'. simpl. replace (staff_toStaff' (staff'_toStaff s')) with s'.
  + f_equal. rewrite <- IHsl'. assumption.
  + destruct s' as [i n j]. reflexivity.
Qed.

Lemma reconstructFacultyList' : forall fl': list faculty',
fl' = faculty_toFaculty'List (faculty'_toFacultyList fl').
Proof.
induction fl' as [|f' fl'].
-reflexivity.
- rewrite IHfl'. simpl. replace (faculty_toFaculty' (faculty'_toFaculty f')) with f'.
  + f_equal. rewrite <- IHfl'. assumption.
  + destruct f' as [i n r]. reflexivity.
Qed.

Lemma eqStaffList': forall cd',
  staff'_list cd' = staff'_list (toCD' (toCD cd')).
Proof.
intros.
unfold toCD, toCD'.
destruct cd' as [sl' fl' disj'].
unfold staff'_list.
apply reconstructStaffList'.
Qed.

Lemma eqFacultyList': forall cd',
 faculty'_list cd' = faculty'_list (toCD' (toCD cd')).
Proof.
intros.
unfold toCD, toCD'.
destruct cd' as [sl' fl' disj'].
unfold faculty'_list.
apply reconstructFacultyList'.
Qed.

Theorem th2: forall cd':class_diagram',
  cd' = toCD' (toCD cd').
Proof.
intros cd'.
pose proof (eqConst' cd' (toCD' (toCD cd'))).
apply (H (eqStaffList' cd') (eqFacultyList' cd') ).
apply proof_irrelevance.
Qed.


(** * Hare and tortoise. *)

From Coq Require Import Basics QArith Lia Lqa String Qabs.
Open Scope string_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From zar Require Import compile cpGCL gaussian itree Q tree.

Local Open Scope cpGCL_scope.

(* Definition hare_tortoise : cpGCL := *)
(*   "t" <-- 5%nat; *)
(*   "h" <-- 0%nat; *)
(*   "time" <-- 0%nat; *)
(*   while (fun s => Nat.ltb (as_nat (s "h")) (as_nat (s "t"))) do *)
(*     "t" <-- (fun s => incr (s "t")); *)
(*     CChoice (const (1#4)) *)
(*       (fun b => if b then *)
(*                gaussian "g" 2; *)
(*                "h" <-- (fun s => (as_nat (s "h") + as_nat (s "g") + 5)%nat) *)
(*              else *)
(*                skip); *)
(*     "time" <-- (fun s => incr (s "time")) *)
(*   end. *)

Definition gauss (x : string) (mu : Z) (sigma : Q) : cpGCL :=
  gaussian x sigma;
  x <-- (fun s => (as_int (s x) + mu)%Z).

Definition gauss' (x : string) (mu : St -> Z) (sigma : Q) : cpGCL :=
  gaussian x sigma;
  x <-- (fun s => (as_int (s x) + mu s)%Z).

(* Definition hare_tortoise : cpGCL := *)
(*   gauss "T0" 5 2; *)
(*   "T" <-- (fun s => s "T0"); *)
(*   "h" <-- 0%Z; *)
(*   "t" <-- 0%Z; *)
(*   while (fun s => Z.ltb (as_int (s "h")) (as_int (s "T"))) do *)
(*     "T" <-- (fun s => (as_int (s "T") + 1)%Z); *)
(*     CChoice (const (1#4)) *)
(*       (fun b => if b then *)
(*                gaussian "g" 2; *)
(*                "h" <-- (fun s => (as_int (s "h") + as_int (s "g") + 5)%Z) *)
(*              else *)
(*                skip); *)
(*     "t" <-- (fun s => (as_int (s "t") + 1)%Z) *)
(*   end; *)
(* (* obs (fun s => Z.leb 20 (as_int (s "T")) && Z.leb (as_int (s "T")) 40) *) *)
(* obs (fun s => Z.leb 200 (as_int (s "T"))) *)
(*   (* obs (fun s => true) *) *)
(* . *)

(* Definition hare_tortoise : cpGCL := *)
(*   gauss "mu" 0 5; *)
(*   gauss' "t0" (fun s => as_int (s "mu")) 2; *)
(*   "T" <-- 0%Z; *)
(*   "h" <-- 0%Z; *)
(*   "t" <-- (fun s => s "t0"); *)
(*   while (fun s => Z.ltb (as_int (s "h")) (as_int (s "T"))) do *)
(*     "T" <-- (fun s => (as_int (s "T") + 1)%Z); *)
(*     CChoice (const (1#4)) *)
(*       (fun b => if b then *)
(*                gaussian "g" 2; *)
(*                "h" <-- (fun s => (as_int (s "h") + as_int (s "g") + 5)%Z) *)
(*              else *)
(*                skip); *)
(*     "t" <-- (fun s => (as_int (s "t") + 1)%Z) *)
(*   end; *)
(* (* obs (fun s => Z.leb 20 (as_int (s "T")) && Z.leb (as_int (s "T")) 40) *) *)
(*   obs (fun s => Z.leb 40 (as_int (s "T"))) *)
(*   (* obs (fun s => true) *) *)
(* . *)

Definition unif (x : string) (e : St -> nat) : cpGCL :=
  CUniform e (fun n => x <-- Z.of_nat n).

Definition hare_tortoise : cpGCL :=
  unif "t0" (const 10%nat);
  "t" <-- (fun s => s "t0");
  "h" <-- 0%Z;
  "time" <-- 0%Z;
  while (fun s => Z.ltb (as_int (s "h")) (as_int (s "t"))) do
    "t" <-- (fun s => (as_int (s "t") + 1)%Z);
    CChoice (const (2#5))
      (fun b => if b then
               gauss' "g" (const 4%Z) 2;
               "h" <-- (fun s => (as_int (s "h") + as_int (s "g"))%Z)
             else
               skip);
    "time" <-- (fun s => (as_int (s "time") + 1)%Z)
  end;
  obs (fun s => true).
  (* obs (fun s => Z.leb 20 (as_int (s "time"))). *)
  (* obs (fun s => Z.leb (as_int (s "time")) 10). *)

From Coq Require Import ExtrOcamlBasic ExtrOcamlString.

Definition sampler : itree boolE Z :=
  ITree.map (fun s => as_int (s "t0"))
    (cpGCL_to_itree hare_tortoise empty).
Extraction "extract/hare/sampler.ml" sampler.


(* This example, submitted by A. Appel, checks the efficiency of
   injection (see bug #1173) *)
(* Expected time < 1.50s *)

Set Implicit Arguments.

Record joinable (t: Type) : Type := Joinable {
   is_empty: t -> Prop;
   join: t -> t -> t -> Prop;
   join_com: forall a b c, join a b c -> join b a c;
   join_empty: forall e a b, is_empty e -> join e a b -> a=b;
   exists_empty: forall a, exists e, is_empty e /\ join e a a;
   join_empty2: forall a b c, join a b c ->  is_empty c -> is_empty a;
   join_empty3: forall e a, join e a a -> is_empty e;
   join_assoc: forall a b c d e, join a b d -> join d c e ->
                    exists f, join b c f /\ join a f e;
   join_eq: forall x y z z', join x y z -> join x y z' -> z = z';
   cancellation: forall a1 a2 b c, join a1 b c -> join a2 b c -> a1=a2
}.

Record joinmap (key: Type) (t: Type) (j : joinable t) : Type
 := Joinmap {
    jm_t : Type;
    jm_j : joinable jm_t;
    lookup: jm_t -> key -> t;
    prim : forall (f: key -> t) (e: t),
                  (forall k, j.(join) e (f k) (f k)) ->
                  jm_t;
    join_rule: forall s1 s2 s,
                jm_j.(join) s1 s2 s <->
                forall x, j.(join) (lookup s1 x) (lookup s2 x) (lookup s x);
    empty_rule: forall e x, jm_j.(is_empty) e -> j.(is_empty) (lookup e x);
    prim_rule: forall f e pf k, lookup (prim f e pf) k = f k;
    ext: forall s1 s2,
        (forall x, lookup s1 x = lookup s2 x) <-> s1 = s2;
    can_join: forall s1 s2,
            (forall x, exists v,
                j.(join) (lookup s1 x) (lookup s2 x) v) ->
            exists s3, jm_j.(join) s1 s2 s3;
    can_split: forall s1 s3,
            (forall x, exists v,
                j.(join) (lookup s1 x) v (lookup s3 x)) ->
            exists s2, jm_j.(join) s1 s2 s3
}.

Parameter mkJoinmap :   forall (key: Type) (t: Type) (j: joinable t),
joinmap key j.

Parameter ADMIT: forall p: Prop, p.
Implicit Arguments ADMIT [p].

Module Share.
Parameter jb : joinable bool.
Definition jm: joinmap nat jb := mkJoinmap nat jb.
Definition t := jm.(jm_t).
Definition j := jm.(jm_j).
Parameter nonempty: t -> Prop.
End Share.

Section Own.

Variable inv : Type.

Inductive own : Type :=
  | NO
  | VAL' : forall sh, Share.nonempty sh -> own
  | LK : forall sh, Share.nonempty sh -> Share.t -> inv -> own
  | CT : forall sh, Share.nonempty sh -> own
  | FUN: forall sh, Share.nonempty sh -> inv -> own.

Definition own_join (a b c: own) : Prop :=
 match a , b , c with
  | NO , _ , _ =>  b=c
  | _ , NO , _ =>  a=c
  | VAL' sa _ , VAL' sb _, VAL' sc _ => Share.j.(join) sa sb sc
  | LK sa pa ha fa, LK sb pb hb fb, LK sc pc hc fc =>
      Share.j.(join) sa sb sc /\
      Share.j.(join) ha hb hc /\
      fa=fc /\
      fb=fc
  | CT sa pa , CT sb pb, CT sc pc => Share.j.(join) sa sb sc
  | FUN sa pa fa, FUN sb pb fb, FUN sc pc fc =>
        Share.j.(join) sa sb sc /\ fa=fc /\ fb=fc
  | _ , _ , _ => False
 end.

Definition own_is_empty (a: own) := a=NO.

Definition jown : joinable own :=
  Joinable own_is_empty own_join
     ADMIT ADMIT  ADMIT  ADMIT  ADMIT  ADMIT  ADMIT  ADMIT .
End Own.

Fixpoint sinv (n: nat) : Type :=
  match n with
   | O => unit
   | S n => prodT (sinv n) (own (sinv n) -> unit -> Prop)
 end.

Parameter address: Set.

Definition jm (n: nat) := mkJoinmap address (jown (sinv n)).

Definition worldfun (n: nat) := (jm n).(jm_t).

Inductive world : Type :=
  mk_world: forall n, worldfun n -> world.

Lemma test: forall n1 w1 n2 w2, mk_world n1 w1 = mk_world n2 w2 ->
         n1 = n2.
Proof.
intros.
Timeout 10 Time injection H.


Require Import
  Coq.setoid_ring.Ring Coq.Arith.Factorial MathClasses.misc.workaround_tactics
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.additional_operations MathClasses.interfaces.orders
  MathClasses.interfaces.naturals MathClasses.interfaces.integers
  MathClasses.theory.nat_pow MathClasses.theory.int_pow MathClasses.theory.streams.

Local Existing Instance srorder_semiring.

Section series.
Context `{SemiRingOrder A}.

Add Ring A : (rings.stdlib_semiring_theory A).
Add Ring nat : (rings.stdlib_semiring_theory nat).

Class DecreasingNonNegative (s : ∞A) : Prop :=
  decreasing_nonneg : ForAll (λ t, 0 ≤ hd (tl t) ≤ hd t) s.

(* An equivalent definition is to say that given a point [s] in the stream,
  then every further point in that stream is in [[0,s]]. *)
Lemma dnn_alt (s : ∞A) :
  DecreasingNonNegative s ↔ ForAll (λ s, ForAll (λ t, 0 ≤ hd t ≤ hd s) s) s.
Proof.
  split; revert s; cofix FIX; intros s E.
   constructor.
    cut (hd s ≤ hd s); [|reflexivity].
    set (x:=hd s). unfold x at 1.
    generalize s E x. clear s E x.
    cofix FIX2. intros s E.
    constructor.
     split; trivial. destruct E.
     now transitivity (hd (tl s)).
    destruct E.
    apply FIX2; trivial.
    now transitivity (hd s).
   destruct E. now apply FIX.
  constructor.
   now destruct E as [[? [? ?]] ?].
  apply FIX. now destruct E.
Qed.

Definition dnn_Str_nth (s : ∞A) :
  DecreasingNonNegative s ↔ ∀ n, 0 ≤ Str_nth (S n) s ≤ Str_nth n s.
Proof.
  split.
   intros dnn n. revert s dnn.
   induction n; intros s E; unfold Str_nth in *; simpl.
    apply E.
   apply IHn. now destruct E.
  revert s. cofix FIX. intros s E.
  constructor; unfold Str_nth in *; simpl in *.
   apply (E O).
  apply FIX. intros n.
  apply (E (S n)).
Qed.

Global Instance dnn_tl `(dnn : DecreasingNonNegative s) : DecreasingNonNegative (tl s).
Proof. now destruct dnn. Qed.

Global Instance dnn_Str_nth_tl `(dnn : DecreasingNonNegative s) : ∀ n, DecreasingNonNegative (Str_nth_tl n s).
Proof.
  intros n. revert s dnn.
  induction n; [easy|]. intros s E.
  now apply IHn, _.
Qed.

Lemma dnn_hd_nonneg `(dnn : DecreasingNonNegative s) : 0 ≤ hd  s.
Proof. destruct dnn. now transitivity (hd (tl s)). Qed.

Lemma dnn_Str_nth_nonneg `(dnn : DecreasingNonNegative s) n : 0 ≤ Str_nth n s.
Proof. destruct n; apply (dnn_hd_nonneg _). Qed.

Class IncreasingNonNegative (s : ∞A) : Prop :=
  increasing_nonneg : ForAll (λ s, 0 ≤ hd s ≤ hd (tl s)) s.

Lemma inn_Str_nth (s : ∞A) :
  IncreasingNonNegative s ↔ ∀ n, 0 ≤ Str_nth n s ≤ Str_nth (S n) s.
Proof.
  split.
   intros E n. revert s E.
   induction n; intros s E; unfold Str_nth in *; simpl.
    apply E.
   apply IHn. now destruct E.
  revert s. cofix FIX. intros s E.
  constructor; unfold Str_nth in *; simpl in *.
   apply (E O).
  apply FIX. intros n.
  apply (E (S n)).
Qed.

Global Instance inn_tl `(inn : IncreasingNonNegative s) : IncreasingNonNegative (tl s).
Proof. now destruct inn. Qed.

Global Instance inn_Str_nth_tl `(inn : IncreasingNonNegative s) : ∀ n, IncreasingNonNegative (Str_nth_tl n s).
Proof.
  intros n. revert s inn.
  induction n; trivial. intros s E.
  now apply IHn, _.
Qed.

Section every_other.
  CoFixpoint everyOther (s : ∞A) : ∞A := Cons (hd s) (everyOther (tl (tl s))).

  Lemma Str_nth_tl_everyOther (n : nat) (s : ∞A) : Str_nth_tl n (everyOther s) ≡ everyOther (Str_nth_tl (2 * n) s).
  Proof.
    revert s.
    induction n; intros s; simpl; trivial.
    rewrite IHn.
    replace (n + S (n + 0))%nat with (S (2*n))%nat.
     easy.
    change (1 + (1 + 1) * n = n + (1 + (n + 0))). ring.
  Qed.

  Lemma Str_nth_everyOther (n : nat) (s : ∞A) : Str_nth n (everyOther s) = Str_nth (2 * n) s.
  Proof.
    unfold Str_nth.
    rewrite Str_nth_tl_everyOther.
    reflexivity.
  Qed.

  Global Instance everyOther_dnn `(dnn : !DecreasingNonNegative s) : DecreasingNonNegative (everyOther s).
  Proof.
    revert s dnn.
    cofix FIX. intros s dnn.
    constructor; simpl.
     destruct dnn as [? [? ?]]. split. easy. now transitivity (hd (tl s)).
    now apply FIX, _.
  Qed.

  Global Instance everyOther_inc `(inn : !IncreasingNonNegative s) : IncreasingNonNegative (everyOther s).
  Proof.
    revert s inn.
    cofix FIX. intros s [? [? ?]].
    constructor; simpl.
     split. easy. now transitivity (hd (tl s)).
    now apply FIX.
  Qed.
End every_other.

Section mult.
  Definition mult_Streams := zipWith (.*.).

  Global Instance mult_Streams_dnn `(dnn1 : !DecreasingNonNegative s1) `(dnn2 : !DecreasingNonNegative s2) :
    DecreasingNonNegative (mult_Streams s1 s2).
  Proof.
    revert s1 s2 dnn1 dnn2.
    cofix FIX. intros s1 s2 [[? ?] ?] [[? ?] ?].
    constructor; simpl.
     split.
      now apply nonneg_mult_compat.
     now apply semirings.mult_le_compat.
    now apply FIX.
  Qed.

  Global Instance mult_Streams_inc `(inn1 : !IncreasingNonNegative s1) `(inn2 : !IncreasingNonNegative s2) :
    IncreasingNonNegative (mult_Streams s1 s2).
  Proof .
    revert s1 s2 inn1 inn2.
    cofix FIX. intros s1 s2 [? ?] [? ?].
    constructor; simpl.
     split.
      now apply nonneg_mult_compat.
     now apply semirings.mult_le_compat.
    now apply FIX.
  Qed.

  Global Instance: Proper ((=) ==> (=) ==> (=)) mult_Streams.
  Proof. apply _. Qed.
End mult.

Section powers.
  Context (a : A).

  Definition powers_help : A → ∞A := iterate (.*a).

  Definition powers : ∞A := powers_help 1.

  Section with_nat_pow.
  Context `{Naturals N} `{!NatPowSpec A N pw} (f : nat → N) `{!SemiRing_Morphism f}.

  Lemma Str_nth_powers_help (n : nat) (c : A) : Str_nth n (powers_help c) = c * a ^ (f n).
  Proof.
    revert c.
    induction n using peano_naturals.nat_induction; intros c; unfold Str_nth in *; simpl.
     rewrite rings.preserves_0, nat_pow_0. ring.
    rewrite rings.preserves_plus, rings.preserves_1.
    rewrite nat_pow_S, IHn. ring.
  Qed.

  Lemma Str_nth_powers (n : nat) : Str_nth n powers = a ^ (f n).
  Proof. unfold powers. rewrite Str_nth_powers_help. ring. Qed.
  End with_nat_pow.

  Section with_int_pow.
  Context `{!Negate A} `{!DecRecip A} `{!DecField A} `{∀ x y : A, Decision (x = y)}
     `{Integers Z} `{!IntPowSpec A Z pw} (f : nat → Z) `{!SemiRing_Morphism f}.

  Lemma Str_nth_powers_help_int_pow (n : nat) (c : A) : Str_nth n (powers_help c) = c * a ^ (f n).
  Proof. rewrite (Str_nth_powers_help id). unfold id. now rewrite int_pow_nat_pow. Qed.

  Lemma Str_nth_powers_int_pow (n : nat) : Str_nth n powers = a ^ (f n).
  Proof. unfold powers. rewrite Str_nth_powers_help_int_pow. ring. Qed.
  End with_int_pow.
End powers.

Global Instance powers_help_proper: Proper ((=) ==> (=) ==> (=)) powers_help.
Proof.
  intros ? ? E1 ? ? E2. apply stream_eq_Str_nth. intros n.
  now rewrite 2!(Str_nth_powers_help _ id), E1, E2.
Qed.

Global Instance powers_proper: Proper ((=) ==> (=)) powers.
Proof.
  intros ? ? E. apply stream_eq_Str_nth. intros n.
  now rewrite 2!(Str_nth_powers _ id), E.
Qed.

Section increments.
  Context (d:A).

  Definition increments (x : A) : ∞A := iterate (+d) x.

  Lemma Str_nth_increments (n : nat) (x : A) :
    Str_nth n (increments x) = x + d * naturals_to_semiring nat A n.
  Proof.
    unfold increments. revert x.
    induction n using peano_naturals.nat_induction; intros c; unfold Str_nth in *; simpl.
     rewrite rings.preserves_0. now ring.
    rewrite IHn, rings.preserves_plus, rings.preserves_1. now ring.
  Qed.
End increments.

Section positives.
  Definition positives_help : A → ∞A := increments 1.

  Lemma Str_nth_positives_help (n : nat) (x : A) :
    Str_nth n (positives_help x) = x + naturals_to_semiring nat A n.
  Proof. unfold positives_help. rewrite Str_nth_increments. ring. Qed.

  Definition positives : ∞A := positives_help 1.

  Lemma Str_nth_positives (n : nat) :
    Str_nth n positives = 1 + naturals_to_semiring nat A n.
  Proof. unfold positives. now rewrite Str_nth_positives_help. Qed.
End positives.

Section factorials.
  CoFixpoint factorials_help (n c : A) : ∞A := c ::: factorials_help (1 + n) (n * c).

  Fixpoint fac_help (n : nat) (m c : A) : A :=
    match n with
    | O => c
    | S n => (m + naturals_to_semiring nat A n) * fac_help n m c
    end.

  Lemma Str_nth_factorials_help (n : nat) (m c : A) :
    Str_nth n (factorials_help m c) = fac_help n m c.
  Proof.
    revert m c.
    induction n using peano_naturals.nat_induction; intros m c; unfold Str_nth in *; simpl.
     ring.
    rewrite IHn. clear IHn.
    induction n using peano_naturals.nat_induction; simpl.
     rewrite rings.preserves_0. now ring.
    rewrite IHn, rings.preserves_plus, rings.preserves_1. now ring.
  Qed.

  Definition factorials := factorials_help 1 1.

  Lemma Str_nth_factorials (n : nat) :
    Str_nth n factorials = naturals_to_semiring nat A (fact n).
  Proof.
    unfold factorials.
    rewrite Str_nth_factorials_help.
    induction n using peano_naturals.nat_induction; simpl.
     change (1 = naturals_to_semiring nat A 1).
     now rewrite rings.preserves_1.
    rewrite IHn.
    setoid_rewrite rings.preserves_plus.
    setoid_rewrite rings.preserves_mult. now ring.
  Qed.
End factorials.
End series.

Section preservation.
  Context `{SemiRingOrder A} `{SemiRingOrder B} `{!SemiRing_Morphism (f : A → B)}.

  Lemma preserves_powers_help (a c : A) (n : nat) :
    f (Str_nth n (powers_help a c)) = Str_nth n (powers_help (f a) (f c)).
  Proof.
    rewrite 2!(Str_nth_powers_help _ id).
    rewrite rings.preserves_mult.
    now rewrite preserves_nat_pow.
  Qed.

  Lemma preserves_powers (a : A) (n : nat) :
    f (Str_nth n (powers a)) = Str_nth n (powers (f a)).
  Proof.
    rewrite 2!(Str_nth_powers _ id).
    apply preserves_nat_pow.
  Qed.

  Lemma preserves_positives (n : nat) :
    f (Str_nth n positives) = Str_nth n positives.
  Proof.
    rewrite 2!Str_nth_positives.
    rewrite rings.preserves_plus, rings.preserves_1.
    now rewrite <-(naturals.to_semiring_unique (f ∘ naturals_to_semiring nat A)).
  Qed.

  Lemma preserves_factorials (n : nat) :
    f (Str_nth n factorials) = Str_nth n factorials.
  Proof.
    rewrite 2!Str_nth_factorials.
    now rewrite <-(naturals.to_semiring_unique (f ∘ naturals_to_semiring nat A)).
  Qed.
End preservation.


From CoqMTL Require Import Control.Functor.

From CoqAlgs Require Export Base.

Set Implicit Arguments.

(* Formulas without a fixed signature. *)
Definition Formula (F : Type -> Type) : Type :=
  forall X : Type, (F X -> X) -> X.

Inductive Var (E : Type) : Type :=
    | Var' : Prop -> Var E.

Arguments Var' [E] _.

Inductive And (E : Type) : Type :=
    | And' : E -> E -> And E.

Arguments And' [E] _ _.

Inductive Coproduct (F G : Type -> Type) (E : Type) :=
    | Inl : F E -> Coproduct F G E
    | Inr : G E -> Coproduct F G E.

Arguments Inl {F G E} _.
Arguments Inr {F G E} _.

Notation "F :+: G" := (Coproduct F G) (right associativity, at level 42).

#[refine]
#[export]
Instance Functor_Var : Functor Var :=
{
    fmap := fun A B f '(Var' P) => Var' P
}.
Proof.
  all: cbn; intros; ext x; destruct x; compute; reflexivity.
Defined.

#[refine]
#[export]
Instance Functor_And : Functor And :=
{
    fmap := fun A B f '(And' e1 e2) => And' (f e1) (f e2)
}.
Proof.
  all: intros; ext x; destruct x; compute; reflexivity.
Defined.

#[refine]
#[export]
Instance Functor_Coproduct
  (F G : Type -> Type) (instF : Functor F) (instG : Functor G)
  : Functor (F :+: G) :=
{
    fmap := fun (A B : Type) (f : A -> B) (x : Coproduct F G A) =>
    match x with
        | Inl e => Inl (fmap f e)
        | Inr e => Inr (fmap f e)
    end
}.
Proof.
  all: intros; ext x; destruct x; hs.
Defined.

Class Denote (F : Type -> Type) : Type :=
{
    denoteAlgebra : F Prop -> Prop;
}.

#[export]
Instance Denote_Var : Denote Var :=
{
    denoteAlgebra := fun '(Var' P) => P
}.

#[export]
Instance Denote_And : Denote And :=
{
    denoteAlgebra := fun '(And' P Q) => P /\ Q
}.

#[export]
Instance Denote_Coproduct
  (F G : Type -> Type) (instF : Denote F) (instG : Denote G)
  : Denote (F :+: G) :=
{
    denoteAlgebra := fun x =>
    match x with
        | Inl x => denoteAlgebra x
        | Inr x => denoteAlgebra x
    end
}.

Definition andExample : Formula (Var :+: And) :=
  fun X In => In (Inr (And' (In (Inl (Var' True))) (In (Inl (Var' False))))).

Definition foldExpr
  {F : Type -> Type} {A : Type} (f : F A -> A) (x : Formula F) : A :=
    x _ f.

Definition denote
  {F : Type -> Type} {instE : Denote F}
  (x : Formula F) : Prop := foldExpr denoteAlgebra x.

(*

Fixpoint formulaDenote (env : Env Prop) (f : formula) : Prop :=
match f with
    | fFalse => False
    | fTrue => True
    | fVar i => holds i env
    | fAnd f1 f2 => formulaDenote env f1 /\ formulaDenote env f2
    | fOr f1 f2 => formulaDenote env f1 \/ formulaDenote env f2
    | fImpl f1 f2 => formulaDenote env f1 -> formulaDenote env f2
end.

Function simplifyFormula (f : formula) : formula :=
match f with
    | fFalse => fFalse
    | fTrue => fTrue
    | fVar P => fVar P
    | fAnd f1 f2 =>
        match simplifyFormula f1, simplifyFormula f2 with
            | fOr f11 f12, f2' => fOr (fAnd f11 f2') (fAnd f12 f2')
            | f1', fOr f21 f22 => fOr (fAnd f1' f21) (fAnd f1' f22)
            | fFalse, _ => fFalse
            | _, fFalse => fFalse
            | fTrue, f2' => f2'
            | f1', fTrue => f1'
            | f1', f2' => fAnd f1' f2'
        end
    | fOr f1 f2 =>
        match simplifyFormula f1, simplifyFormula f2 with
            | fAnd f11 f12, f2' => fAnd (fOr f11 f2') (fOr f12 f2')
            | f1', fAnd f21 f22 => fAnd (fOr f1' f21) (fOr f1' f22)
            | fFalse, f2' => f2'
            | f1', fFalse => f1'
            | fTrue, _ => fTrue
            | _, fTrue => fTrue
            | f1', f2' => fOr f1' f2'
        end
    | fImpl f1 f2 =>
        match simplifyFormula f1 with
            | fFalse => fTrue
            | fTrue => f2
            | fAnd f11 f12 => fImpl f11 (fImpl f12 f2)
            | fOr f11 f12 => fAnd (fImpl f11 f2) (fImpl f12 f2)
            | f1' => fImpl f1' f2
        end
end.

Theorem simplifyFormula_correct :
  forall (f : formula) (env : Env Prop),
    formulaDenote env (simplifyFormula f) <-> formulaDenote env f.
Proof.
  intros. functional induction simplifyFormula f; cbn.
  all:
  repeat match goal with
      | e : simplifyFormula ?f = _,
        IH : formulaDenote _ (simplifyFormula ?f) <-> _ |- _ =>
        rewrite <- IH, e; cbn
  end; try (tauto; fail).
Qed.

Definition solveHypothesis (env : Env Prop) :
  forall (proofs : Proofs) (hyp f : formula)
    (cont : forall proofs : Proofs,
      solution (allTrue env proofs -> formulaDenote env f)),
        solution (allTrue env proofs -> formulaDenote env hyp ->
          formulaDenote env f).
Proof.
  refine (
  fix solve
    (proofs : Proofs) (hyp f : formula)
      (cont : forall proofs : Proofs,
        solution (allTrue env proofs -> formulaDenote env f)) :
          solution (allTrue env proofs -> formulaDenote env hyp ->
            formulaDenote env f) :=
  match hyp with
      | fFalse => Yes
      | fTrue => Reduce (cont proofs)
      | fVar i => Reduce (cont (i :: proofs))
      | fAnd f1 f2 =>
          Reduce (solve proofs f1 (fImpl f2 f)
                        (fun proofs' => Reduce (cont proofs')))
      | fOr f1 f2 =>
          solve proofs f1 f cont &&
          solve proofs f2 f cont
      | _ => No
  end).
  all: cbn in *; try tauto.
Defined.

Definition solveGoal (env : Env Prop)
  : forall (proofs : Proofs) (f : formula),
      solution (allTrue env proofs -> formulaDenote env f).
Proof.
  refine (
  fix solve
    (proofs : Proofs) (f : formula)
      : solution (allTrue env proofs -> formulaDenote env f) :=
  match f with
      | fFalse => No
      | fTrue => Yes
      | fVar i =>
          match in_dec Nat.eq_dec i proofs with
              | left _ => Yes
              | right _ => No
          end
      | fAnd f1 f2 => solve proofs f1 && solve proofs f2
      | fOr f1 f2 => solve proofs f1 || solve proofs f2
      | fImpl f1 f2 =>
          solveHypothesis env proofs f1 f2
            (fun proofs' => solve proofs' f2)
  end).
  all: cbn; try tauto.
    intro. apply find_spec with proofs; assumption.
Defined.

Definition solveFormula (env : Env Prop) (f : formula)
  : solution (formulaDenote env f).
Proof.
  refine (Reduce (solveGoal env [] f)). apply f0. cbn. trivial.
Defined.

Theorem solveFormula_correct :
  forall (env : Env Prop) (f : formula),
    (exists p : formulaDenote env f, solveFormula env f = Yes' p) ->
      formulaDenote env f.
Proof.
  intros. destruct H. assumption.
Qed.

Ltac allVarsFormula xs P :=
match P with
    | ~ ?P' => allVarsFormula xs P'
    | ?P1 /\ ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 \/ ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 -> ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 <-> ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | _ => addToList P xs
end.

Ltac reifyFormula xs P :=
match P with
    | False => constr:(fFalse)
    | True => constr:(fTrue)
    | ~ ?P' =>
        let e := reifyFormula xs P' in constr:(fImpl e fFalse)
    | ?P1 /\ ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fAnd e1 e2)
    | ?P1 \/ ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fOr e1 e2)
    | ?P1 -> ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fImpl e1 e2)
    | ?P1 <-> ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in
          constr:(fAnd (fImpl e1 e2) (fImpl e2 e1))
    | _ =>
        let i := lookup P xs in constr:(fVar i)
end.

Ltac reflectFormula :=
match goal with
    |- ?P =>
        let xs := allVarsFormula constr:(@nil Prop) P in
        let f := reifyFormula xs P in
          change (formulaDenote xs f);
          rewrite <- simplifyFormula_correct; cbn
end.

Ltac solveGoal' :=
match goal with
    |- ?P =>
        let xs := allVarsFormula constr:(@nil Prop) P in
        let f := reifyFormula xs P in change (formulaDenote xs f);
          rewrite <- simplifyFormula_correct; cbn;
          try apply (unwrap (solveFormula xs (simplifyFormula f)))
end.

Ltac solveGoal := solveGoal'; fail.*)


(* Software Foundations *)
(* Exerice 2 stars, baz_num_elts *)

Inductive baz : Type :=
|x : baz -> baz
|y : baz -> bool ->baz.

(* The inductive type baz has twi constructors, the catch is that those constructors needs an element of type baz as the
first argument in order to create an element of type baz, so we can't bootstrap an instanciation of type baz. *)


(* Copyright 2021 Joshua M. Cohen

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.
*)

(*We define polynomials as lists of field elements so that we can compute with them, unlike mathcomp's. However,
  to use the theorems in mathcomp, we relate lpolys to polys*)
From mathcomp Require Import all_ssreflect.
Require Import mathcomp.algebra.ssralg.
Require Import mathcomp.algebra.poly.
Require Import mathcomp.algebra.polydiv.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".
Require Import CommonSSR.

(*Stuff from helper, mathcomp versions*)
Section LPoly.

Local Open Scope ring_scope.

Variable F : fieldType.

Definition lpoly := polynomial F.

(*Transform an arbitrary list into a valid lpoly*)
Lemma lpoly_Poly_eq: forall (p q : lpoly),
  Poly p = Poly q -> p = q.
Proof.
  move => p q. by rewrite !polyseqK.
Qed.

Lemma lpolyP: forall (p q : lpoly), nth 0 p =1 nth 0 q <-> p = q.
Proof.
  move => p q. apply polyP.
Qed.

Definition seq_to_lpoly (s: seq F) : lpoly :=
  Polynomial (rem_trail_zero_wf s).

Definition lpoly_to_seq (l: lpoly) : seq F := l.

(*We want a computable Euclidean division algorithm, so we need computable polynomial operations. We start with
  addition*)
Section Add.

(*Can't define with [zip] and [map] because we need to handle case when 1 poly has ended with implicit zeroes.
  It is inefficient to add zeroes to the end of the list before summing*)
Fixpoint lpoly_add_aux (s1 s2: seq F) : seq F :=
  match (s1, s2) with
  | (x1 :: t1, x2 :: t2) => (x1 + x2) :: lpoly_add_aux t1 t2
  | (_, _ :: _) => s2
  | (_, _) => s1
  end.

Definition lpoly_add (l1 l2: lpoly) : lpoly :=
  seq_to_lpoly (lpoly_add_aux l1 l2).

Lemma lpoly_add_aux_nth: forall s1 s2 i,
  (lpoly_add_aux s1 s2)`_i = s1`_i + s2`_i.
Proof.
  move => s1. elim : s1 => [/= s2 i | h t /= IH s2 i].
  - case : s2 => [//=| h t /=].
    + by rewrite nth_nil GRing.addr0.
    + by rewrite nth_nil GRing.add0r.
  - case : s2 => [//= | h1 t1 /=].
    + by rewrite nth_nil GRing.addr0.
    + case : i => [//= | i /=]. apply IH.
Qed.

Lemma lpoly_add_nth: forall l1 l2 i,
  (lpoly_add l1 l2)`_i = l1`_i + l2`_i.
Proof.
  move => l1 l2 i. by rewrite /lpoly_add -rem_trail_zero_nth lpoly_add_aux_nth.
Qed.

Lemma lpoly_add_spec: forall l1 l2,
  Poly (lpoly_add l1 l2) = Poly l1 + Poly l2.
Proof.
  move => l1 l2. rewrite -polyP => i.
  by rewrite coef_add_poly !polyseqK lpoly_add_nth.
Qed.

End Add.

(*In Euclidean division, we only need to multiply a polynomial p by kx^n for some scalar k. We can do this
  more efficiently than general multiplication by just using a single append and map*)

Section Shift.

(*Scalar multiply*)
Definition lpoly_sc_mul_aux (s: seq F) (k: F) : seq F :=
  map (fun x => k * x) s.

Lemma lpoly_sc_mul_aux_nth: forall s k i,
  (lpoly_sc_mul_aux s k)`_i = k * s`_i.
Proof.
  move => s k i. case Hi : (i < size s).
  - by rewrite (nth_map 0).
  - rewrite !nth_default //. by rewrite GRing.mulr0. by rewrite leqNgt Hi.
    by rewrite size_map leqNgt Hi.
Qed.

Lemma lpoly_sc_mul_aux_wf: forall (l: lpoly) k,
  k != 0 ->
  last 1 (lpoly_sc_mul_aux l k) != 0.
Proof.
  move => l k Hk0. rewrite /lpoly_sc_mul_aux.
  have->: 1 = k * k^-1 by rewrite GRing.mulfV. rewrite last_map.
  case : l => [s Hlast]. rewrite /= GRing.mulf_neq0 //.
  move : Hlast. case : s => [/= H10|//]. by apply GRing.invr_neq0.
Qed.

Definition lpoly_sc_mul_aux_full (s: seq F) (k: F) : seq F :=
  if k == 0 then nil else lpoly_sc_mul_aux s k.

Lemma lpoly_sc_mul_aux_full_nth: forall s k i,
  (lpoly_sc_mul_aux_full s k)`_i = k * s`_i.
Proof.
  move => s k i. rewrite /lpoly_sc_mul_aux_full. case Hk : (k == 0) => [/= | /=].
  - apply (elimT eqP) in Hk. subst. by rewrite nth_nil GRing.mul0r.
  - apply lpoly_sc_mul_aux_nth.
Qed.

Lemma lpoly_sc_mul_aux_full_wf: forall (l: lpoly) k,
  last 1 (lpoly_sc_mul_aux_full l k) != 0.
Proof.
  move => l k. rewrite /lpoly_sc_mul_aux_full. case Hk : (k == 0) => [/= | /=].
  - apply GRing.oner_neq0.
  - apply lpoly_sc_mul_aux_wf. by rewrite Hk.
Qed.

Definition lpoly_sc_mul (l: lpoly) k : lpoly :=
  Polynomial (lpoly_sc_mul_aux_full_wf l k).

Lemma lpoly_sc_mul_spec: forall (l: lpoly) k,
  Poly (lpoly_sc_mul l k) = k%:P * (Poly l).
Proof.
  move => l k. rewrite /= -polyP => i.
  rewrite !polyseqK /=. rewrite (@PolyK _ 1). 2: apply lpoly_sc_mul_aux_full_wf.
  by rewrite coefCM lpoly_sc_mul_aux_full_nth.
Qed.

Lemma lpoly_sc_mul_1: forall (l: lpoly),
  lpoly_sc_mul l 1 = l.
Proof.
  move => l. apply lpoly_Poly_eq. by rewrite lpoly_sc_mul_spec GRing.mul1r.
Qed.

(*Now similarly, multiply by x^n*)
Definition lpoly_shift_aux (s: seq F) (n: nat) :=
  nseq n 0 ++ s.

Lemma lpoly_shift_aux_nth: forall s n i,
  (lpoly_shift_aux s n)`_i = if i < n then 0 else s`_(i - n).
Proof.
  move => s n i. rewrite /lpoly_shift_aux nth_cat size_nseq nth_nseq.
  by case : (i < n).
Qed.

Lemma lpoly_shift_aux_wf: forall (l: lpoly) n,
  ~~ nilp l ->
  last 1 (lpoly_shift_aux l n) != 0.
Proof.
  move => l n. rewrite /lpoly_shift_aux last_cat. case : l => [s Hlast].
  rewrite /=. move: Hlast. by case : s.
Qed.

Definition lpoly_shift_aux_full (s: seq F) (n: nat) :=
  if nilp s then nil else (lpoly_shift_aux s n).

Lemma lpoly_shift_aux_full_nth: forall s n i,
  (lpoly_shift_aux_full s n)`_i = if i < n then 0 else s`_(i - n).
Proof.
  move => s n i. rewrite /lpoly_shift_aux_full. case : s => [/= | h t /=].
  - rewrite !nth_nil. by case : (i < n).
  - apply lpoly_shift_aux_nth.
Qed.

Lemma lpoly_shift_aux_full_wf: forall (l: lpoly) n,
  last 1 (lpoly_shift_aux_full l n) != 0.
Proof.
  move => l n. rewrite /lpoly_shift_aux_full.
  case Hs: (nilp l) => [//= | //=].
  - apply GRing.oner_neq0.
  - apply lpoly_shift_aux_wf. by rewrite Hs.
Qed.

Definition lpoly_shift (l: lpoly) (n: nat) : lpoly :=
  Polynomial (lpoly_shift_aux_full_wf l n).

Lemma lpoly_shift_spec: forall l n,
  Poly (lpoly_shift l n) = 'X^n * Poly l.
Proof.
  move => l n. rewrite -polyP => i. rewrite /= coefXnM polyseqK (@PolyK _ 1).
  by rewrite lpoly_shift_aux_full_nth. apply lpoly_shift_aux_full_wf.
Qed.

(*For our purposes, we would like to multiply by kx^n. We can make this more efficient by only mapping
  over the extra part*)
Definition lpoly_sc_mul_shift_aux (s: seq F) (k: F) (n: nat) :=
  nseq n 0 ++ map (fun x => k * x) s.

Lemma lpoly_sc_mul_shift_aux_equiv: forall s k n,
  lpoly_sc_mul_shift_aux s k n = lpoly_sc_mul_aux (lpoly_shift_aux s n) k.
Proof.
  move => s k n. rewrite /lpoly_sc_mul_shift_aux /lpoly_sc_mul_aux /lpoly_shift_aux.
  rewrite map_cat. f_equal. apply (@eq_from_nth _ 0). by rewrite size_map.
  move => i. rewrite size_nseq => Hi. rewrite (nth_map 0). by rewrite !nth_nseq Hi GRing.mulr0.
  by rewrite size_nseq.
Qed.

Definition lpoly_sc_mul_shift_aux_full s k n :=
  if (nilp s) || (k == 0) then nil else lpoly_sc_mul_shift_aux s k n.

Lemma lpoly_sc_mul_shift_aux_full_wf: forall (l: lpoly) k n,
  last 1 (lpoly_sc_mul_shift_aux_full l k n) != 0.
Proof.
  move => l k n. rewrite /lpoly_sc_mul_shift_aux_full.
  case Hl: (nilp l) => [/= | /=].
  - apply GRing.oner_neq0.
  - case Hk: (k == 0) => [/= | /=].
    + apply GRing.oner_neq0.
    + rewrite lpoly_sc_mul_shift_aux_equiv.
      have: last 1 (lpoly_sc_mul_aux (lpoly_shift l n) k) != 0.
        apply lpoly_sc_mul_aux_wf. by rewrite Hk. by rewrite /= /lpoly_shift_aux_full Hl.
Qed.

Definition lpoly_sc_mul_shift (l: lpoly) k n :=
  Polynomial (lpoly_sc_mul_shift_aux_full_wf l k n).

Lemma lpoly_sc_mul_shift_spec: forall (l: lpoly) k n,
  Poly (lpoly_sc_mul_shift l k n) = k%:P * ('X^n * Poly l).
Proof.
  move => l k n; rewrite /= /lpoly_sc_mul_shift_aux_full.
  case Hl: (nilp l) => [/= | /=].
  - apply (elimT nilP) in Hl. rewrite Hl /=. by rewrite !GRing.mulr0.
  - case Hk: (k == 0).
    + apply (elimT eqP) in Hk. subst. by rewrite GRing.mul0r.
    + rewrite lpoly_sc_mul_shift_aux_equiv.
      have->: Poly (lpoly_sc_mul_aux (lpoly_shift_aux l n) k) =
              k %:P * Poly (lpoly_shift_aux l n). {
      have Hnil: ~~(nilp l) by rewrite Hl.
      pose proof lpoly_sc_mul_spec as Hmul; move : Hmul => /(_ (Polynomial (lpoly_shift_aux_wf n Hnil)) k) /=.
      by rewrite /lpoly_sc_mul_aux_full Hk. }
      f_equal. pose proof lpoly_shift_spec as Hspec; move: Hspec. by rewrite /lpoly_shift /= /lpoly_shift_aux_full =>
      /( _ l n); rewrite Hl.
Qed.

Lemma lpoly_sc_mul_shift_1: forall (l: lpoly) n,
  lpoly_sc_mul_shift l 1 n = lpoly_shift l n.
Proof.
  move => l n. apply lpoly_Poly_eq. by rewrite lpoly_sc_mul_shift_spec lpoly_shift_spec GRing.mul1r.
Qed.

End Shift.

Section Monomial.

Definition lpoly_mono_aux (n: nat) : seq F := rcons (nseq n 0) 1.

Lemma lpoly_mono_aux_wf: forall n,
  last 1 (lpoly_mono_aux n) != 0.
Proof.
  move => n. rewrite /lpoly_mono_aux. rewrite last_rcons. apply GRing.oner_neq0.
Qed.

Definition lpoly_mono (n: nat) : lpoly := Polynomial (lpoly_mono_aux_wf n).

Lemma lpoly_mono_spec: forall n,
  Poly (lpoly_mono n) = 'X^n.
Proof.
  move => n. by rewrite /= /lpoly_mono_aux /= -polyseqXn polyseqK.
Qed.

End Monomial.

(*Euclidean Division*)
Section Div.

(*Lots of definitions to unfold*)
Definition lpoly_redivp_rec (l: lpoly) :=
  let sq := size l in
  let cq := last 0 l in
  fix loop (k: nat) (qq r : lpoly) (n: nat) {struct n} : nat * lpoly * lpoly :=
    if size r < sq then (k, qq, r)
    else
      let lc := last 0 r in
      let qq1 := lpoly_add (lpoly_sc_mul qq cq) (lpoly_sc_mul (lpoly_mono (size r - sq)) lc) in
      let r1 := lpoly_add (lpoly_sc_mul r cq) (lpoly_sc_mul_shift l (- lc) (size r - sq)) in
      match n with
      | 0 => (k.+1, qq1, r1)
      | n1.+1 => loop k.+1 qq1 r1 n1
      end.

Definition tuple_to_poly (x: (nat * lpoly * lpoly)) : nat * {poly F} * {poly F} :=
  match x with
  | (n, p1, p2) => (n, Poly p1, Poly p2)
  end.

Lemma size_Poly_lpoly: forall (l: lpoly),
  size (Poly l) = size l.
Proof.
  move => l. f_equal. by rewrite polyseqK.
Qed.

Lemma lead_coef_Poly: forall (l: lpoly),
  (lead_coef (Poly l)) = last 0 l.
Proof.
  move => l. by rewrite /lead_coef nth_last /= polyseqK.
Qed.

Lemma lpoly_redivp_rec_spec: forall l k qq r n,
  tuple_to_poly (lpoly_redivp_rec l k qq r n) = Pdiv.Ring.redivp_rec (Poly l) k (Poly qq) (Poly r) n.
Proof.
  move => l k qq r n. move: l k qq r. elim : n => [/= l k qq r | n /= IH l k qq r].
  - rewrite !size_Poly_lpoly. case Hsz: (size r < size l).
    + by [].
    + rewrite /tuple_to_poly !lpoly_add_spec !lpoly_sc_mul_spec !lead_coef_Poly !lpoly_mono_spec
      lpoly_sc_mul_shift_spec /=. f_equal.
      * f_equal. rewrite GRing.mulrC. f_equal. by rewrite mul_polyC.
      * rewrite GRing.mulrC. f_equal. by rewrite -!mul_polyC polyCN !GRing.mulrA !GRing.mulNr.
  - rewrite !size_Poly_lpoly. case Hsz: (size r < size l).
    + by [].
    + rewrite !lead_coef_Poly IH. f_equal.
      * by rewrite !lpoly_add_spec !lpoly_sc_mul_spec !lpoly_mono_spec -!mul_polyC GRing.mulrC.
      * rewrite !lpoly_add_spec !lpoly_sc_mul_spec !lpoly_sc_mul_shift_spec -!mul_polyC GRing.mulrC. f_equal.
        by rewrite polyCN GRing.mulNr GRing.mulrA.
Qed.

Lemma zero_nil : 0%R = seq_to_lpoly nil.
Proof.
  apply /eqP. rewrite eq_sym.
  by rewrite -nil_poly /=.
Qed.

Definition lpoly_redivp (p q: lpoly) : nat * lpoly * lpoly :=
  if nilp q then (0%N, 0, p) else lpoly_redivp_rec q 0 (seq_to_lpoly nil) p (size p).

Lemma lpoly_zero: forall (l: lpoly),
  (Poly l == 0) = nilp l.
Proof.
  move => l. by rewrite nil_poly polyseqK.
Qed.

Lemma lpoly_redivp_spec: forall p q,
  tuple_to_poly (lpoly_redivp p q) = Pdiv.Ring.redivp (Poly p) (Poly q).
Proof.
  move => p q. rewrite /lpoly_redivp locked_withE /Pdiv.Ring.redivp_expanded_def lpoly_zero.
  case Hq: (nilp q).
  - move: Hq; case : (polyseq q) => [//= Htriv | //=]. rewrite /=. f_equal. f_equal. by rewrite polyseqK.
  - move : Hq; case : q => [l Hl]. move: Hl; case : l => [// | h t Hl Hq].
    have->: polyseq (Polynomial Hl) = h :: t by [].
    rewrite lpoly_redivp_rec_spec. f_equal. by rewrite polyseqK.
Qed.

(*For computability reasons, we don't want to use "==". Luckily we are in a field, so testing
  for a unit is easily computable*)
Lemma f_eq_dec : forall (x y : F), { x = y } + { x <> y}.
Proof.
  move => x y. apply (decP eqP).
Defined.

Definition lpoly_edivp (p q: lpoly) : nat * lpoly * lpoly :=
  let '(k, d, r) := lpoly_redivp p q in
  let lc := last 0 q in
  if (f_eq_dec lc 0) then (k, d, r) else (0%N, (lpoly_sc_mul d (lc ^- k)), lpoly_sc_mul r (lc ^-k)).

Lemma lpoly_edivp_spec: forall p q,
  tuple_to_poly (lpoly_edivp p q) = Pdiv.Field.edivp (Poly p) (Poly q).
Proof.
  move => p q. rewrite /lpoly_edivp /Pdiv.Field.edivp locked_withE /Pdiv.Field.edivp_expanded_def !lead_coef_Poly.
  rewrite -lpoly_redivp_spec /= /tuple_to_poly.
  case Hdiv: (lpoly_redivp p q) => [[k d] r] .
  rewrite GRing.unitfE. case: (f_eq_dec (last 0 q) 0) => [Hlast /= | Hlast].
  - by rewrite Hlast eq_refl /=.
  - rewrite /=. apply (introF eqP) in Hlast. rewrite Hlast !polyseqK /=. f_equal. f_equal.
    by rewrite lpoly_sc_mul_spec /= mul_polyC polyseqK.
    by rewrite lpoly_sc_mul_spec /= mul_polyC polyseqK.
Qed.

End Div.

End LPoly.

(*We will be working over GF(2), so we can give simpler functions because all leading coefficients are 1. The
  code will be more efficient, which is important because this will be run many times in a loop*)
Require Import BoolField.
Require Import PolyField.

Section BoolPolyDiv.

Local Open Scope ring_scope.

Definition F := bool_fieldType.

(*Some facts about the field of booleans*)
Lemma bool_1_0: forall (f: F),
  (f != 0) = (f == 1).
Proof.
  move => f. by case : f.
Qed.

Lemma bool_lc: forall (l: lpoly F),
  ~~(nilp l) ->
  last 0 l = 1.
Proof.
  move => l. case : l => [l /=]. case : l => [// | h t /= Hlast Htriv]. apply /eqP. by rewrite -bool_1_0.
Qed.

Lemma neg_one: GRing.one F = - 1.
Proof.
  by [].
Qed.

Definition bool_redivp_rec (l: lpoly F) :=
  let sq := size l in
  fix loop (qq r : lpoly F) (n: nat) {struct n} : lpoly F * lpoly F :=
    if size r < sq then (qq, r)
    else
      let qq1 := lpoly_add qq (lpoly_mono F (size r - sq)%N) in
      let r1 := lpoly_add r (lpoly_shift l (size r - sq)) in
      match n with
      | 0 => (qq1, r1)
      | n1.+1 => loop qq1 r1 n1
      end.

(*Last two elts of a tuple*)
Definition last_two {A B C : Type} (x: A * B * C) : B * C :=
  match x with
  | (a, b, c) => (b, c)
  end.

Lemma bool_redivp_rec_spec: forall (l: lpoly F) q r n k,
  ~~(nilp l) ->
  (bool_redivp_rec l q r n) = last_two (lpoly_redivp_rec l k q r n).
Proof.
  move => l q r n. move: l q r. elim : n => [/= l q r k Hl | n /= IH l q r k Hl].
  - case Hsz: (size r < size l).
    + by [].
    + rewrite /= !bool_lc //. by rewrite !lpoly_sc_mul_1 -neg_one lpoly_sc_mul_shift_1. by apply (larger_not_nil Hl).
  - case Hsz: (size r < size l).
    + by [].
    + rewrite /= !bool_lc //. by rewrite !lpoly_sc_mul_1 /= -neg_one lpoly_sc_mul_shift_1 -IH.
      by apply (larger_not_nil Hl).
Qed.

Definition bool_edivp (p q : lpoly F) : lpoly F * lpoly F :=
  if nilp q then (0, p) else bool_redivp_rec q (seq_to_lpoly nil) p (size p).

Lemma bool_edivp_spec: forall p q,
  bool_edivp p q = last_two (lpoly_edivp p q).
Proof.
  move => p q. rewrite /bool_edivp /lpoly_edivp /lpoly_redivp /=.
  case Hq: (nilp q) => [/= | /=].
  - case: (f_eq_dec (last 0 q) 0) => [Hz //= | Hz /=].
    move : Hz Hq. case : q => q. by case : q.
  - rewrite (bool_redivp_rec_spec _ _ _ 0); last first. by rewrite Hq.
    case Hr: (lpoly_redivp_rec q 0 (seq_to_lpoly [::]) p (size p)) => [ [k d] r].
    case : (f_eq_dec (last 0 q) 0) => [Hz //= | Hz /=].
    rewrite !bool_lc; last first. by rewrite Hq. by rewrite !GRing.expr1n !GRing.invr1 !lpoly_sc_mul_1.
Qed.

(*We need to enumerate all polynomials up to a certain length. This takes a bit of work due to the dependent types*)
Fixpoint seq_of_polyseqs (n: nat) : (seq (seq F)) * (seq (seq F)) :=
  match n with
  | 0 => ([:: [:: true]], [:: [:: true]])
  | n'.+1 => let (leq_seq, eq_seq) := (seq_of_polyseqs n') in
             let new_eq_seq := (map (cons true) eq_seq) ++ (map (cons false) eq_seq) in
             (leq_seq ++ new_eq_seq, new_eq_seq)
  end.

Lemma nil_notin_seq: forall n,
  (nil \notin (seq_of_polyseqs n).1) && (nil \notin (seq_of_polyseqs n).2).
Proof.
  move => n. elim : n => [//= | n /=].
  case Hseq : (seq_of_polyseqs n) => [leq_seq eq_seq]. rewrite /= => /andP[Hle Heq].
  rewrite !mem_cat !negb_or Hle /= {1}andbC andbA -(andbA ([::] \notin [seq false :: i | i <- eq_seq]))
  andbb andbC andbA andbb. apply /andP. split; apply /mapP => [[x Hx] //].
Qed.

Lemma zero_notin_seq: forall n,
  ([:: 0] \notin (seq_of_polyseqs n).1) && ([:: 0] \notin (seq_of_polyseqs n).2).
Proof.
  move => n. elim : n => [//= | n /=].
  case Hseq : (seq_of_polyseqs n) => [leq_seq eq_seq]. rewrite /= => /andP[Hle Heq].
  rewrite !mem_cat !negb_or Hle /= {1}andbC andbA -(andbA ([:: 0] \notin [seq false :: i | i <- eq_seq]))
  andbb andbC andbA andbb. apply /andP.
  pose proof (nil_notin_seq n) as Hnil. move: Hnil; rewrite Hseq /= => /andP[Hnileq Hnilleq].
  split. apply /mapP => [[x Hin [Hx]]]. subst. by rewrite Hin in Hnilleq.
  by apply /mapP => [[x Hin [Hx]]].
Qed.

Lemma seq_of_polyseqs_last: forall n s,
  (s \in (seq_of_polyseqs n).1) || (s \in (seq_of_polyseqs n).2) ->
  last 1 s != 0.
Proof.
  move => n. elim : n => [//= s | n /=].
  - rewrite !in_cons in_nil orbF orbb => /eqP Hs. rewrite Hs. by [].
  - case Hseq: (seq_of_polyseqs n) => [leq_seq eq_seq]. rewrite /=. move => IH s.
    rewrite !mem_cat -orbA -orbA orbC -orbA (orbC (s \in [seq false :: i | i <- eq_seq])) -!orbA
    (orbA (s \in [seq false :: i | i <- eq_seq])) !orbb orbA orbb =>
    /orP[/mapP [x Hx Hs] | /orP[/mapP [x Hx Hs] | Hleq]].
    + rewrite Hs /=. apply IH. by rewrite Hx orbT.
    + rewrite Hs /=. have->: (last false x) = (last 1 x). move: Hx Hs. case : x => [//= Hnil | //=].
      pose proof (nil_notin_seq n) as Hnil'; move: Hnil'. by rewrite Hseq Hnil /= andbF.
      apply IH. by rewrite Hx orbT.
    + apply IH. by rewrite Hleq.
Qed.

Lemma size1P: forall {T: Type} (s: seq T),
  reflect (exists (x: T), s = [:: x]) (size s == 1%N) .
Proof.
  move => T s. case : s => [/= | h t /=].
  - apply ReflectF. by move =>[x Hx].
  - case : t => [|h' t' /=].
    + apply ReflectT. by exists h.
    + apply ReflectF. by move => [x Hx].
Qed.

Lemma in_seq_of_polyseqs_snd: forall n s,
  s \in (seq_of_polyseqs n).2 = ((last 1 s != 0) && (size s == n.+1)).
Proof.
  move => n. elim : n => [//= s | n /=].
  - rewrite !in_cons in_nil orbF.
    case Hs: (s == [:: true]). apply (elimT eqP) in Hs. by rewrite Hs.
    case  Hsz: ((size s) == 1%N).
    + apply (elimT (size1P s)) in Hsz. case : Hsz => [x Hsx]. move: Hsx; case : x =>[ //=|->//=].
      move => /eqP Hst. by rewrite Hst in Hs.
    +  by rewrite andbF.
  - case Hseq: (seq_of_polyseqs n) => [leq_seq eq_seq]. rewrite /= => IH s. rewrite !mem_cat.
    case Hfst: (s \in [seq true :: i | i <- eq_seq]) =>[/= | /=].
    + move: Hfst => /mapP [x Hx Hs]. subst. by rewrite /= eqSS -IH Hx.
    + case Hsnd: (s \in [seq false :: i | i <- eq_seq]).
      * move : Hsnd => /mapP [x Hx Hs]. subst. rewrite /= eqSS.
        have->: (last false x = last 1 x). move : {Hfst} Hx. case : x =>[/= Hnil|//].
        by pose proof (nil_notin_seq n) as Hnils; move : Hnils; rewrite Hseq /= Hnil andbF.
        by rewrite -IH Hx.
      * case Hin: (((last 1 s) != 0) && ((size s) == (n.+2))) =>[|//].
        move: Hin Hsnd Hfst. case : s => [//= | h].
        case : h => [  t /= /andP[Hlast Hsz] Hsnd Hfst |  t /= /andP[Hlast Hsz] Hsnd Hfst];
        rewrite eqSS in Hsz.
        -- have Htin: (t \in eq_seq) by rewrite IH Hlast Hsz. by rewrite map_f in Hfst.
        -- have Hlast': (last false t = last 1 t). move {Hsnd Hfst Hsz}. move: Hlast.
           by case : t. rewrite Hlast' in Hlast. have Htin: (t \in eq_seq) by rewrite IH Hlast Hsz.
           by rewrite map_f in Hsnd.
Qed.

Lemma in_seq_of_polyseqs_fst: forall n s,
  s \in (seq_of_polyseqs n).1 = (last 1 s != 0) && (0 < size s <= n.+1).
Proof.
  move => n. elim : n => [//= s | n /=].
  - pose proof (in_seq_of_polyseqs_snd 0 s) as Hsnd. move: Hsnd; rewrite /=; move ->.
    f_equal. by rewrite eq_sym eqn_leq.
  - case Hseq: (seq_of_polyseqs n) => [leq_seq eq_seq]. rewrite /= => IH s. rewrite mem_cat.
    pose proof (in_seq_of_polyseqs_snd (n.+1) s) as Hsnd. move: Hsnd; rewrite /= Hseq /=.
    move ->. rewrite IH /=. rewrite -(andb_orr). f_equal. rewrite (leq_eqVlt _ (n.+2)).
    rewrite andb_orr orbC. rewrite (@andb_idl _ (size s == n.+2)) //.
    move => /eqP Hsz. by rewrite Hsz.
Qed.

Lemma seq_of_polyseqs_all_last: forall n,
  all (fun x => last 1 x != 0) (seq_of_polyseqs n).1.
Proof.
  move => n. rewrite all_in => x Hin. apply (@seq_of_polyseqs_last n).
  by rewrite Hin.
Qed.

Definition seq_of_lpoly (n: nat) : (seq (lpoly F)) :=
  sub_seq (polynomial_subType F) (seq_of_polyseqs_all_last n).

(*Finally we have what we want: an lpoly is in the list iff it is a nonzero polynomial of degree at most n*)
Lemma seq_of_lpoly_in: forall n (l: lpoly F),
  (l \in seq_of_lpoly n) = (0 < size l <= n.+1).
Proof.
  move => n l. rewrite sub_seq_in /= in_seq_of_polyseqs_fst /=.
  case : l => [s Hs /=]. by rewrite Hs.
Qed.

(*Test for irreducibility*)

Lemma size_one: forall (p: {poly F}),
  (size p == 1%N) = (p == 1).
Proof.
  move => p. rewrite -val_eqE /= polyseq1. case : p => [l /=].
  case : l => [//= Htriv | h t /=].
  case : t => [//= | h' t' /= Hlast]. by case : h.
  have->: ((size t').+2 == 1%N) = false by [].
  case Hseq : ([:: h, h' & t'] == [:: 1]) =>[|//].
  apply (elimT eqP) in Hseq. by case: Hseq.
Qed.

(*In boolean field, %= is the same as =*)
Lemma eqp_eq: forall (p q: {poly F}),
  (p %= q) = (p == q).
Proof.
  move => p q. case Hq0: (q == 0).
  - apply (elimT eqP) in Hq0. subst. by rewrite eqp0.
  - case Hdiv: (p %= q).
    + move: Hdiv; rewrite /eqp /dvdp => /andP[/eqP Hdivqp /eqP Hdivpq].
      pose proof (divp_eq p q) as Hp.
      pose proof (divp_eq q p) as Hq.
      move: Hp Hq. rewrite Hdivqp Hdivpq !GRing.addr0 => Hp. rewrite {2} Hp GRing.mulrA.
      rewrite GRing.mulrC -{1}(GRing.mulr1 q) => Hq. apply GRing.mulfI in Hq.
      have: 1%N = size (q %/ p * (p %/ q)) by rewrite -(size_poly1 F) Hq.
      move => /eqP Hsz1. move: Hsz1. rewrite eq_sym size_mul_eq1 => /andP[Hqp1 Hpq1].
      move: Hpq1; rewrite size_one => /eqP Hpq1. move: Hp. rewrite Hpq1 GRing.mul1r. move ->.
      by rewrite eq_refl. by rewrite Hq0.
    + case Heq: (p == q) =>[|//].
      apply (elimT eqP) in Heq. rewrite Heq in Hdiv. by rewrite eqpxx in Hdiv.
Qed.

Lemma propTp: forall (P: Prop),
  true * P <-> P.
Proof.
  move => P. split. by move => [Htriv p].
  move => Hp. by split.
Qed.

Lemma irreducible_poly_factor: forall (p: {poly F}),
  1 < size p ->
  irreducible_poly p <-> (forall (f: {poly F}), size f < size p -> (f == 1) || ~~ (f %| p)).
Proof.
  move => p Hsz. rewrite /irreducible_poly Hsz /= propTp.
  split.
  - move => Hirred f Hszf.
    case Hf1: (f == 1) =>[//|/=]. rewrite -size_one in Hf1.
    case Hdiv: (f %| p) =>[|//].
    apply Hirred in Hdiv. move: Hdiv; rewrite eqp_eq => /eqP Hfp. subst.
    by rewrite ltnn in Hszf. by rewrite Hf1.
  - move => Halt q Hszq Hqp. case Hq0: (q == 0).
    + apply (elimT eqP) in Hq0. subst. move: Hqp => /dvd0pP Hp. subst.
      by rewrite eqpxx.
    + have: (size q <= size p). apply dvdp_leq. rewrite -size_poly_eq0.
      case Hszp: (size p == 0%N) => [|//]. apply (elimT eqP) in Hszp. by rewrite Hszp in Hsz.
      by []. rewrite leq_eqVlt => /orP[Hszpq | Hszlt].
      * by rewrite -dvdp_size_eqp.
      * apply Halt in Hszlt. move: Hszlt => /orP[Hq1 | Hdiv].
        move: Hq1; rewrite -size_one => /eqP Hq1. by rewrite Hq1 in Hszq.
        by rewrite Hqp in Hdiv.
Qed.

Lemma pred_sum: forall (n m : nat),
  n != 0%N ->
  m != 0%N ->
  (n.-1 + m.-1)%N = (n+m).-2.
Proof.
  move => n m Hn Hm. rewrite -matrix.mx'_cast. rewrite (addnC n (m.-1)) -matrix.mx'_cast //.
  by rewrite addnC. all: apply pred_ord; by rewrite lt0n.
Qed.

(*We can make the search more efficient by only considering polynomials up to degree (deg p) /2*)
Lemma irreducible_poly_factor_small: forall (p : {poly F}) n,
  1 < size p ->
  n < (size p).-1 <= n.*2 ->
  irreducible_poly p <-> (forall (f: {poly F}), (size f) <= n.+1 -> (f == 1) || ~~ (f %| p)).
Proof.
  move => p n Hp /andP[Hnle Hngt]. rewrite (irreducible_poly_factor Hp).
  split; move => Hirred f Hsz.
  - apply Hirred. apply (leq_ltn_trans Hsz). by rewrite -ltn_predRL.
  - case (orP (ltn_leq_total n.+1 (size f))) => [Hge | Hlt]; last first.
    + by apply Hirred.
    + case Hdiv : (f %| p) =>[//= | /=]; last first. by apply orbT.
      have: (f %| p) by []. apply divp_dvd in Hdiv.
      rewrite /dvdp => /eqP Hmod.
      pose proof (divp_eq p f) as Hpf. move: Hpf; rewrite Hmod GRing.addr0 => Hpf.
      have Hf0: (f == 0) = false. { case Hf0: (f == 0) => [|//].
        apply (elimT eqP) in Hf0. move: Hpf. rewrite Hf0 GRing.mulr0 => Hp0.
        subst. by rewrite size_poly0 in Hsz. }
      have Hpf0: (p %/ f == 0) = false. {  case Hpf0: (p %/ f == 0)=>[|//].
        apply (elimT eqP) in Hpf0. move: Hpf. rewrite Hpf0 GRing.mul0r => Hp0.
        subst. by rewrite size_poly0 in Hsz. }
      have Hszsum: size p = (size (p %/f) + size f).-1
        by rewrite {1}Hpf size_proper_mul // GRing.mulf_eq0 !lead_coef_eq0 Hf0 Hpf0.
     case: (orP (ltn_leq_total n.+1 (size (p %/ f)))) => [Hge' | Hlt']; last first.
      * apply Hirred in Hlt'. move: Hlt' => /orP [/eqP Hpf1 | Hpfdiv].
        -- move: Hpf; rewrite Hpf1 GRing.mul1r => Hpf. subst. by rewrite ltnn in Hsz.
        -- by rewrite Hdiv in Hpfdiv.
      * rewrite -ltn_predRL in Hge. rewrite -ltn_predRL in Hge'.
        have Hn2big: n.*2 < (size f).-1 + (size (p %/ f)).-1. rewrite -addnn. by apply ltn_add2rl.
        have: (size p).-1 < (size f).-1 + (size (p %/ f)).-1 by apply (leq_ltn_trans Hngt).
        rewrite Hszsum pred_sum. by rewrite addnC ltnn. by rewrite size_poly_eq0 Hf0.
        by rewrite size_poly_eq0 Hpf0.
Qed.

Definition isOne (l: lpoly F) :=
  match (polyseq l) with
  | true :: nil => true
  | _ => false
  end.

Lemma isOne_spec: forall l,
  (isOne l) = (l == 1).
Proof.
  move => l. rewrite -size_one /= /isOne.
  case : l => [l Hl /=]. move: Hl. case : l => [//= | h t /=]. case : h => [/=|//=].
  case : t =>[//= | //=]. by case : t.
Qed.

Definition bool_modp (p q: lpoly F) : lpoly F :=
  (bool_edivp p q).2.

Lemma bool_modp_spec: forall p q,
  Poly (bool_modp p q) = modp (Poly p) (Poly q).
Proof.
  move => p q. rewrite /modp /bool_modp. rewrite bool_edivp_spec /last_two /=.
  case Hdiv: (lpoly_edivp p q) => [[k' q'] r' /=].
  by rewrite -lpoly_edivp_spec Hdiv /=.
Qed.

Definition bool_dvdp (p q: lpoly F) : bool :=
  nilp (bool_modp q p).

Lemma bool_dvdp_spec: forall p q,
  (bool_dvdp p q) = ((Poly p) %| (Poly q)).
Proof.
  move => p q. rewrite /dvdp /bool_dvdp.
  by rewrite -bool_modp_spec /= lpoly_zero.
Qed.

(*Finally, a (computable) function to find irreducible polynomials of lpolys*)
Definition find_irred (l: lpoly F) (n: nat) : option (lpoly F) :=
  find_val_option (fun q => ~~ (isOne q) && (bool_dvdp q l)) (seq_of_lpoly n).

Lemma find_irredP: forall (l: lpoly F) n,
  1 < size l ->
  n < (size l).-1 <= n.*2 ->
  reflect (irreducible_poly (Poly l)) ((find_irred l n == None)).
Proof.
  move => l n Hl Hn. case Hfind: (find_irred l n) => [p /= | /=].
  - move: Hfind; rewrite /find_irred => Hfind.
    have Hin: p \in (seq_of_lpoly n) by apply (find_val_option_some_in Hfind).
    apply find_val_option_some in Hfind.
    apply ReflectF. rewrite (@irreducible_poly_factor_small _ n); last first.
    by rewrite size_Poly_lpoly. by rewrite size_Poly_lpoly.
    move => Hall; move: Hfind => /andP[Hone Hdiv].
    rewrite seq_of_lpoly_in in Hin. move: Hin => /andP[Hp0 Hpn].
    apply Hall in Hpn. move: Hpn => /orP [Hp1 | Hpdiv].
    + rewrite isOne_spec in Hone. by rewrite Hp1 in Hone.
    + rewrite bool_dvdp_spec in Hdiv. rewrite polyseqK in Hdiv. by rewrite Hdiv in Hpdiv.
  - apply ReflectT. rewrite (@irreducible_poly_factor_small _ n); last first.
    by rewrite size_Poly_lpoly. by rewrite size_Poly_lpoly.
    have: (find_irred l n) == None. by apply /eqP. rewrite -isSome_none /find_irred -find_val_option_none
    all_in => Hall f Hszf.
    case Hf: (f == 0). apply (elimT eqP) in Hf. subst. rewrite dvd0p.
    case Hl0 : (Poly l == 0) => [//= | //=]. rewrite lpoly_zero in Hl0. apply (elimT nilP) in Hl0.
    move: Hl. by rewrite Hl0 /=. by rewrite orbT.
    have Hinf: (f \in (seq_of_lpoly n)). by rewrite seq_of_lpoly_in Hszf size_poly_gt0 Hf.
    apply Hall in Hinf. move: Hinf. rewrite negb_and negbK => /orP[Hone | Hdiv].
    + by rewrite -isOne_spec Hone.
    + move: Hdiv; rewrite bool_dvdp_spec polyseqK. move ->. by rewrite orbT.
Qed.

(** Testing for Primitive lpolys*)

(*Similarly, we want a computable method for determining if a polynomial over GF(2) is primitive. We want to
  enumerate 'X^n - 1 = 'X^n + 1 for all 0 < n < b for some bound. Because this will be quite large, we
  want to do this as efficiently as possible*)

Definition xn1_seq (n: nat) : seq F := true :: rcons (nseq (n.-1) false) true.

Lemma xn1_seq_wf: forall n,
  last 1 (xn1_seq n) != 0.
Proof.
  move => n. by rewrite /xn1_seq /= last_rcons.
Qed.

Definition xn1_lpoly (n: nat) : lpoly F := Polynomial (xn1_seq_wf n).

Lemma xn1_lpoly_spec: forall n,
  n != 0%N ->
  Poly (xn1_lpoly n) = 'X^n - 1.
Proof.
  move => n Hn. rewrite -polyP => i.
  rewrite coef_Poly /= /xn1_seq /= coefB coef1 coefXn.
  case Hi0: (i == 0%N).
  - apply (elimT eqP) in Hi0. subst. have->: (0%N == n) = false. rewrite eq_sym. by apply negbTE.
    by [].
  - have Hi: i = i.-1.+1 by rewrite prednK // lt0n Hi0. rewrite {1}Hi /= nth_rcons size_nseq nth_nseq.
    case Hin: (i == n) => [/= | /=].
    + apply (elimT eqP) in Hin. subst. by rewrite ltnn eq_refl.
    + case : (i.-1 < n.-1)=>[//|/=].
      case Hin': (i.-1 == n.-1) =>[|//]. apply (elimT eqP) in Hin'. apply PeanoNat.Nat.pred_inj in Hin'.
      subst. by rewrite eq_refl in Hin. apply /eqP. by rewrite Hi0. by apply /eqP.
Qed.

Definition all_xn1 (n: nat) : seq (lpoly F) :=
  map xn1_lpoly (iota 1 (n.-1)).

Lemma all_xn1_in: forall n l,
  reflect (exists2 i: nat, (0 < i < n) & (l = xn1_lpoly i)) (l \in (all_xn1 n)).
Proof.
  move => n l.
  rewrite /all_xn1. case Hn0: (n == 0%N).
  - move: Hn0 => /eqP Hn0. subst. rewrite /=. apply ReflectF. move => [x].
    by rewrite ltn0 andbF.
  - case Hin: (l \in [seq xn1_lpoly i | i <- iota 1 n.-1]).
    + apply ReflectT. move: Hin => /mapP [x Hin Hlx]. subst. exists x. move: Hin.
      by rewrite mem_iota addnC addn1 prednK // lt0n Hn0. by [].
    + apply ReflectF. move: Hin => /mapP Hin [x] Hx Hl.
      subst. apply Hin. exists x. by rewrite mem_iota addnC addn1 prednK // lt0n Hn0. by [].
Qed.

Definition prim_div_check (l: lpoly F) : option (lpoly F) :=
  find_val_option (bool_dvdp l) (all_xn1 (2%N ^ ((size l).-1)).-1).

Lemma prim_div_check_spec: forall (l: lpoly F),
  reflect (forall n, (Poly l) %| 'X^n - 1 -> (n == 0%N) || (((#|F|^((size (Poly l)).-1)).-1) <= n))
    (prim_div_check l == None).
Proof.
  move => l. case Hcheck : (prim_div_check l ) => [q /= | /=].
  - apply ReflectF. move: Hcheck; rewrite /prim_div_check => Hcheck.
    have Hinq: q \in (all_xn1 (2 ^ (size l).-1).-1) by apply (find_val_option_some_in Hcheck).
    apply find_val_option_some in Hcheck. rewrite card_bool. move => Hall.
    apply (elimT (all_xn1_in ((2 ^ (size l).-1).-1) _)) in Hinq.
    case : Hinq => [i /andP[Hi0 Hisz] Hqi]. subst.
    have Hi0f: (i == 0%N) = false by rewrite eqn0Ngt Hi0.
    move : Hcheck; rewrite bool_dvdp_spec xn1_lpoly_spec; last first. by rewrite Hi0f.
    move => Hdiv. apply Hall in Hdiv. move: Hdiv => /orP [Hi0t | Hiszbig].
    + by rewrite Hi0t in Hi0f.
    + move: Hiszbig. by rewrite size_Poly_lpoly leqNgt Hisz.
  - apply ReflectT. move => n Hdiv.
    move: Hcheck; rewrite /prim_div_check => /eqP Hcheck.
    move: Hcheck; rewrite -isSome_none -find_val_option_none all_in => Hall.
    have: 0 <= n by []. rewrite leq_eqVlt => /orP[Hn0 | Hn0]. by rewrite eq_sym Hn0.
    have->/=: (n == 0%N) = false by rewrite eqn0Ngt Hn0. rewrite card_bool size_Poly_lpoly.
    case (orP (ltn_leq_total n ((2 ^ (size l).-1).-1))) => [Hin | //].
    move: Hall => /(_ (xn1_lpoly n)) /=.
    have-> : (xn1_lpoly n \in all_xn1 (2 ^ (size l).-1).-1). apply /all_xn1_in.
    exists n. by rewrite Hn0 Hin. by []. move => Hnodiv. apply rem_impl in Hnodiv.
    move: Hnodiv. rewrite bool_dvdp_spec xn1_lpoly_spec. by rewrite Hdiv. by apply lt0n_neq0.
Qed.

Definition find_prim (l: lpoly F) (n: nat) : bool :=
  ((find_irred l n) == None) && (bool_dvdp l (xn1_lpoly ((2^((size l).-1)).-1))) &&
  ((prim_div_check l) == None).

Lemma find_primP: forall (l: lpoly F) n,
  1 < size l ->
  n < (size l).-1 <= n.*2 ->
  reflect (primitive_poly l) (find_prim l n).
Proof.
  move => l n Hszl Hn.
  have Hpow0: (2 ^ (size l).-1).-1 != 0%N. { have: 2^ 1 <= 2 ^((size l).-1) by rewrite leq_exp2l // ltn_predRL.
    have->: 2 ^ 1 = 2%N by []. move => Hbound. by rewrite -lt0n ltn_predRL. }
  case Hprim: (find_prim l n).
  - apply ReflectT. move: Hprim; rewrite /find_prim /primitive_poly =>
    /andP[/andP [/(find_irredP Hszl Hn) Hirred Hdiv] / prim_div_check_spec Hdivcheck].
    split. by rewrite polyseqK in Hirred.
    split. rewrite /= card_bool. move: Hdiv. rewrite bool_dvdp_spec polyseqK xn1_lpoly_spec //.
    rewrite /=. move: Hdivcheck. by rewrite polyseqK card_bool.
  - apply ReflectF. move: Hprim; rewrite /find_prim /primitive_poly => Hfalse [Hirred [Hdiv Halldiv]].
    have: (irreducible_poly (Poly l)) by rewrite polyseqK. move => /(find_irredP Hszl Hn) Hirrb.
    have Hprimb: (prim_div_check l == None). apply /prim_div_check_spec. rewrite /= polyseqK. apply Halldiv.
    move: Hfalse; rewrite Hprimb Hirrb /= andbT bool_dvdp_spec polyseqK xn1_lpoly_spec.
    move: Hdiv. by rewrite /= card_bool; move ->. by [].
Qed.

(** Concrete Polynomials*)

(*The following are the polynomials that appear in the FEC code. Only p256 is used, but the
  others could be in theory if some flags are changed*)

(*1011*)
Definition p8 := seq_to_lpoly [:: true; true; false; true].
(*10011*)
Definition p16 := seq_to_lpoly [:: true; true; false; false; true].
(*100101*)
Definition p32 := seq_to_lpoly [:: true; false; true; false; false; true].
(*1000011*)
Definition p64 := seq_to_lpoly [:: true; true; false; false; false; false; true].
(*10001001*)
Definition p128:= seq_to_lpoly [:: true; false; false; true; false; false; false; true].
(*100011101*)
Definition p256 := seq_to_lpoly [:: true; false; true; true; true; false; false; false; true].

Lemma p8_primitive : primitive_poly p8.
Proof.
  have Hsz: 1 < size p8 by [].
  have Hn: 2 < (size p8).-1 <= 2.*2 by [].
  apply (elimT (find_primP Hsz Hn)). by vm_compute.
Qed.

Lemma p16_primitive: primitive_poly p16.
Proof.
  have Hsz: 1 < size p16 by [].
  have Hn: 2 < (size p16).-1 <= 2.*2 by [].
  apply (elimT (find_primP Hsz Hn)). by vm_compute.
Qed.

Lemma p32_primitive: primitive_poly p32.
Proof.
  have Hsz: 1 < size p32 by [].
  have Hn: 3 < (size p32).-1 <= 3.*2 by [].
  apply (elimT (find_primP Hsz Hn)). by vm_compute.
Qed.

Lemma p64_primitive: primitive_poly p64.
Proof.
  have Hsz: 1 < size p64 by [].
  have Hn: 3 < (size p64).-1 <= 3.*2 by [].
  apply (elimT (find_primP Hsz Hn)). by vm_compute.
Qed.

Lemma p128_primitive: primitive_poly p128.
Proof.
  have Hsz: 1 < size p128 by [].
  have Hn: 4 < (size p128).-1 <= 4.*2 by [].
  apply (elimT (find_primP Hsz Hn)). by vm_compute.
Qed.

Lemma p256_primitive: primitive_poly p256.
Proof.
  have Hsz: 1 < size p256 by [].
  have Hn: 4 < (size p256).-1 <= 4.*2 by [].
  apply (elimT (find_primP Hsz Hn)). by vm_compute.
Qed.

End BoolPolyDiv.