(** * Addendum for Vectors ([Vector.t]) *)
(* Author: Maximilian Wuttke *)

Require Import Shared.Prelim Shared.Tactics.Tactics Shared.EqDec.
Require Import Coq.Vectors.Fin Coq.Vectors.Vector.
Require Import Shared.Vectors.FinNotation.
Require Export Shared.Vectors.Fin.

(* Vector.nth should not reduce with simpl, except the index is given with a constructor *)
Arguments Vector.nth {A} {m} (v') !p.
Arguments Vector.map {A B} f {n} !v /.
Arguments Vector.map2 {A B C} g {n} !v1 !v2 /.

Tactic Notation "dependent" "destruct" constr(V) :=
  match type of V with
  | Vector.t ?Z (S ?n) =>
    revert all except V;
    pattern V; revert n V;
    eapply caseS; intros
  | Vector.t ?Z 0 =>
    revert all except V;
    pattern V; revert V;
    eapply case0; intros
  | Fin.t 0 => inv V
  | Fin.t (S ?n) =>
    let pos := V in
    revert all except pos;
    pattern pos; revert n pos;
    eapply Fin.caseS; intros
  | _ => fail "Wrong type"
  end.

Delimit Scope vector_scope with vector.
Local Open Scope vector.

Notation "[||]" := (nil _) : vector_scope.
Notation "h ':::' t" := (cons _ h _ t) (at level 60, right associativity) : vector_scope.

Notation " [| x |] " := (x ::: [||]) : vector_scope.
Notation " [| x ; y ; .. ; z |] " := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..)) : vector_scope.
Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope.

Ltac existT_eq :=
  match goal with
  | [ H: existT ?X1 ?Y1 ?Z1 = existT ?X2 ?Y2 ?Z2 |- _] =>
    apply EqdepFacts.eq_sigT_iff_eq_dep in H; inv H
  end.

Ltac existT_eq' :=
  match goal with
  | [ H: existT ?X1 ?Y1 ?Z1 = existT ?X2 ?Y2 ?Z2 |- _] =>
    apply EqdepFacts.eq_sigT_iff_eq_dep in H; induction H
  end.

Lemma vect_map_injective X Y n (f : X -> Y) (v1 v2 : Vector.t X n) :
  (forall x y, f x = f y -> x = y) ->
  map f v1 = map f v2 -> v1 = v2.
Proof.
  intros Inj Eq.
  induction n; cbn in *.
  - dependent destruct v1. dependent destruct v2; reflexivity.
  - dependent destruct v1. dependent destruct v2. cbn in *.
    eapply cons_inj in Eq as (-> % Inj &?). f_equal. now apply IHn.
Qed.

Lemma replace_nth X n (v : Vector.t X n) i (x : X) :
  (Vector.replace v i x) [@i] = x.
Proof.
  induction i; dependent destruct v; cbn; auto.
Qed.

Lemma replace_nth2 X n (v : Vector.t X n) i j (x : X) :
  i <> j -> (Vector.replace v i x) [@j] = v[@j].
Proof.
  revert v. pattern i, j. revert n i j.
  eapply Fin.rect2; intros; try congruence.
  - revert f H. pattern v. revert n v.
    eapply Vector.caseS.
    cbn. reflexivity.
  - revert f H. pattern v. revert n v.
    eapply Vector.caseS.
    cbn. reflexivity.
  - revert g f H H0. pattern v. revert n v.
    eapply Vector.caseS. firstorder congruence.
Qed.

Lemma destruct_vector_nil (X : Type) :
  forall v : Vector.t X 0, v = [||].
Proof.
  now apply case0.
Qed.

Lemma destruct_vector_cons (X : Type) (n : nat) :
  forall v : Vector.t X (S n), { h : X & { v' : Vector.t X n | v = h ::: v' }}.
Proof.
  revert n. apply caseS. eauto.
Qed.

Lemma In_nil (X : Type) (x : X) :
  ~ In x [||].
Proof. intros H. inv H. Qed.

Lemma In_cons (X : Type) (n : nat) (x y : X) (xs : Vector.t X n) :
  In y (x ::: xs) -> x = y \/ In y xs.
Proof.
  intros H. inv H; existT_eq'; tauto.
Qed.

Search Vector.map Vector.In.

Ltac destruct_vector_in :=
  match goal with
  | [ H: Vector.In _ [||] |- _ ] => now apply In_nil in H
  | [ H: Vector.In _ (_ ::: _) |- _ ] => apply In_cons in H as [-> | H] (* Try replacing it first *)
  | [ H: Vector.In _ (_ ::: _) |- _ ] => apply In_cons in H as [H | H]
  end.

(*
Goal ~ Vector.In 10 [|1;2;4|].
Proof.
  intros H. repeat destruct_vector_in; congruence.
Qed.
*)

Section In_Dec.
  Variable X : Type.
  Hypothesis X_dec : eq_dec X.

  Fixpoint in_dec (n : nat) (x : X) (xs : Vector.t X n) { struct xs } : bool :=
    match xs with
    | [||] => false
    | y ::: xs' => if Dec (x = y) then true else in_dec x xs'
    end.

  Lemma in_dec_correct (n : nat) (x : X) (xs : Vector.t X n) :
    in_dec x xs = true <-> In x xs.
  Proof.
    split; intros.
    {
      induction xs; cbn in *.
      - congruence.
      - decide (x = h) as [ -> | D].
        + constructor.
        + constructor. now apply IHxs.
    }
    {
      induction H; cbn.
      - have (x = x).
      - decide (x = x0).
        + reflexivity.
        + apply IHIn.
    }
  Qed.

  Global Instance In_dec (n : nat) (x : X) (xs : Vector.t X n) : dec (In x xs).
  Proof. eapply dec_transfer. eapply in_dec_correct. auto. Defined.

End In_Dec.

(* Destruct a vector of known size *)
Ltac destruct_vector :=
  repeat match goal with
         | [ v : Vector.t ?X 0 |- _ ] =>
           let H  := fresh "Hvect" in
           pose proof (@destruct_vector_nil X v) as H;
           subst v
         | [ v : Vector.t ?X (S ?n) |- _ ] =>
           let h  := fresh "h" in
           let v' := fresh "v'" in
           let H  := fresh "Hvect" in
           pose proof (@destruct_vector_cons X n v) as (h&v'&H);
           subst v; rename v' into v
         end.

Section In_nth.
  Variable (A : Type) (n : nat).

  Lemma vect_nth_In (v : Vector.t A n) (i : Fin.t n) (x : A) :
    Vector.nth v i = x -> Vector.In x v.
  Proof.
    induction n; cbn in *.
    - inv i.
    - dependent destruct v. dependent destruct i; cbn in *; subst; econstructor; eauto.
  Qed.

  Lemma vect_nth_In' (v : Vector.t A n) (x : A) :
    Vector.In x v -> exists i : Fin.t n, Vector.nth v i = x.
  Proof.
    induction n; cbn in *.
    - inversion 1.
    - dependent destruct v. destruct_vector_in.
      + exists Fin.F1. auto.
      + specialize (IHn0 _ H) as (i&<-). exists (Fin.FS i). auto.
  Qed.

End In_nth.

Section tabulate_vec.
  Variable X : Type.

  Fixpoint tabulate (n : nat) (f : Fin.t n -> X) {struct n} : Vector.t X n.
  Proof.
    destruct n.
    - apply Vector.nil.
    - apply Vector.cons.
      + apply f, Fin.F1.
      + apply tabulate. intros m. apply f, Fin.FS, m.
  Defined.

  Lemma nth_tabulate n (f : Fin.t n -> X) (m : Fin.t n) :
    Vector.nth (tabulate f) m = f m.
  Proof.
    induction m.
    - cbn. reflexivity.
    - cbn. rewrite IHm. reflexivity.
  Qed.

  Lemma in_tabulate n (f : Fin.t n -> X) (x : X) :
    In x (tabulate (n := n) f) <-> exists i : Fin.t n, x = f i.
  Proof.
    split.
    {
      revert f x. induction n; intros f x H.
      - cbn in *. inv H.
      - cbn in *. apply In_cons in H as [ <- | H ].
        + eauto.
        + specialize (IHn (fun m => f (Fin.FS m)) _ H) as (i&IH). eauto.
    }
    {
      intros (i&Hi). induction i; cbn in *; subst; econstructor; eauto.
    }
  Qed.

End tabulate_vec.

(*
Lemma vec_replace_nth X x n (t : Vector.t X n) (i : Fin.t n) :
  x = Vector.nth (Vector.replace t i x) i.
Proof.
  induction i; dependent destruct t; simpl; auto.
Qed.

Lemma vec_replace_nth_nochange X x n (t : Vector.t X n) (i j : Fin.t n) :
  Fin.to_nat i <> Fin.to_nat j -> Vector.nth t i = Vector.nth (Vector.replace t j x) i.
Proof.
  revert j. induction i; dependent destruct t; dependent destruct j; simpl; try tauto.
  apply IHi. contradict H. cbn. now rewrite !H.
Qed.
 *)

Instance Fin_eq_dec n : eq_dec (Fin.t n).
Proof.
  intros; hnf.
  destruct (Fin.eqb x y) eqn:E.
  - left. now eapply Fin.eqb_eq.
  - right. intros H. eapply Fin.eqb_eq in H. congruence.
Defined.

Lemma vect_in_map (X Y : Type) (n : nat) (f : X -> Y) (V : Vector.t X n) (x : X) :
  In x V -> In (f x) (map f V).
Proof. induction 1; cbn; constructor; auto. Qed.

Lemma vect_in_map_iff (X Y : Type) (n : nat) (f : X -> Y) (V : Vector.t X n) (y : Y) :
  In y (map f V) <-> (exists x : X, f x = y /\ In x V).
Proof.
  split.
  - intros H. induction V; cbn in *.
    + inv H.
    + apply In_cons in H as [ <- | H].
      * exists h. split; auto. now constructor 1.
      * specialize (IHV H) as (x&Hx1&Hx2). exists x. split; auto. now constructor 2.
  - intros (x&<-&H). now apply vect_in_map.
Qed.

Lemma In_replace (X : Type) (n : nat) (xs : Vector.t X n) (i : Fin.t n) (x y : X) :
  In y (replace xs i x) -> (x = y \/ In y xs).
Proof.
  revert i x y. induction xs; intros; cbn in *.
  - inv i.
  - dependent destruct i; cbn in *; apply In_cons in H as [-> | H]; auto; try now (right; constructor).
    specialize (IHxs _ _ _ H) as [-> | IH]; [ now left | right; now constructor ].
Qed.

Lemma In_replace' (X : Type) (n : nat) (xs : Vector.t X n) (i : Fin.t n) (x y : X) :
  In y (replace xs i x) -> x = y \/ exists j, i <> j /\ xs[@j] = y.
Proof.
  revert i x y. induction xs; intros; cbn -[nth] in *.
  - inv i.
  - dependent destruct i; cbn -[nth] in *.
    + apply In_cons in H as [->|H].
      * tauto.
      * apply vect_nth_In' in H as (j&H). right. exists (Fin.FS j). split. discriminate. cbn. assumption.
    + apply In_cons in H as [->|H].
      * right. exists Fin.F1. split. discriminate. cbn. reflexivity.
      * specialize (IHxs _ _ _ H) as [-> | (j&IH1&IH2)]; [ tauto | ].
        right. exists (Fin.FS j). split. now intros -> % Fin.FS_inj. cbn. assumption.
Qed.

(** Tactic for simplifying a hypothesis of the form [In x v] *)

Ltac simpl_vector_inv :=
  repeat match goal with
         | [ H : [||] = (_ ::: _) |- _ ] => now inv H
         | [ H : (_ ::: _) = [||]  |- _ ] => now inv H
         | [ H : Fin.F1 = Fin.FS _ |- _] => now inv H
         | [ H : Fin.FS _ = Fin.F1 |- _] => now inv H
         | [ H : Fin.FS _ = Fin.FS _ |- _] =>
           first
             [ apply Fin.FS_inj in H as ->
             | apply Fin.FS_inj in H as <-
             | apply Fin.FS_inj in H
             ]
         end.

Ltac simpl_vector_in :=
  repeat
    match goal with
    | _ => first
            [ progress destruct_vector_in
            | progress simpl_vector_inv
            | progress auto
            | congruence
            ]
    | [ H : Vector.In _ (Vector.map _ _) |- _] =>
      let x := fresh "x" in
      eapply vect_in_map_iff in H as (x&<-&H)
    | [ H : Vector.In _ (Vector.map _ _) |- _] =>
      let x := fresh "x" in
      let H' := fresh H in
      eapply vect_in_map_iff in H as (x&H&H')
    | [ H : Vector.In _ (tabulate _) |- _ ] =>
      let i := fresh "i" in
      apply in_tabulate in H as (i&->)
    | [ H : Vector.In _ (tabulate _) |- _ ] =>
      let i := fresh "i" in
      let H := fresh "H" in
      apply in_tabulate in H as (i&H)
    end.

Ltac vector_not_in :=
  let H := fresh "H" in
  intros H; simpl_vector_in.

Goal Vector.In (Fin.F1 (n := 10)) [|Fin1; Fin2; Fin3 |] -> False.
Proof. intros H. simpl_vector_in. Qed.

Goal Vector.In (Fin.F1 (n := 10)) (map (Fin.FS) [|Fin0; Fin1; Fin2|]) -> False.
Proof. intros H. simpl_vector_in. Qed.

(** Conversion between vectors and lists *)

Coercion Vector.to_list : Vector.t >-> list.

Lemma tolist_In (X : Type) (n : nat) (xs : Vector.t X n) (x : X) :
  Vector.In x xs <-> List.In x xs.
Proof.
  split; intros H.
  - induction H; cbn; auto.
  - induction xs; cbn in *; auto. destruct H as [-> | H]; econstructor; eauto.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Datatypes.List.
Require Import bedrock2.Syntax.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Common.Arrays.MakeAccessSizes.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Local Open Scope Z_scope.
Import ListNotations.

Section MaxBounds.
  Context {p : Types.parameters} {ok : Types.ok}.
  Context (n : nat).

  Existing Instance semantics_ok.

  (* TODO: make Expr.v import this *)
  Definition max_range : ZRange.zrange :=
    {|ZRange.lower:=0; ZRange.upper:=2^Semantics.width-1|}.
  Definition max_bounds : list (option ZRange.zrange) :=
    repeat (Some max_range) n.

  Lemma max_bounds_range_iff x :
    let bytes := (Memory.bytes_per
                    (width:=Semantics.width) access_size.word) in
    list_Z_bounded_by max_bounds x <->
    (length x = n /\
     Forall
       (fun z : Z =>
          0 <= z < 2 ^ (Z.of_nat bytes * 8)) x).
  Proof.
    cbv [max_bounds max_range list_Z_bounded_by].
    rewrite bits_per_word_eq_width by auto using width_0mod_8.
    generalize n as m.
    induction x; destruct m; split;
      cbn [FoldBool.fold_andb_map repeat]; try congruence; intros;
        repeat match goal with
               | _ => progress cleanup
               | _ => progress cbn [length ZRange.lower ZRange.upper] in *
               | |- Forall _ [] => solve [constructor]
               | |- Forall _ (_ :: _) => constructor
               | H: Forall _ (_ :: _) |- _ =>
                 inversion H; clear H; subst
               | |- (_ && _)%bool = true =>
                 apply Bool.andb_true_iff; split
               | H: (_ && _)%bool = true |- _ =>
                 apply Bool.andb_true_iff in H; destruct H
               | H : context [iff] |- _ => eapply H; solve [eauto]
               | H : context [iff] |- _ =>
                 rewrite H; auto; congruence
               | |- _ /\ _ => split
               | |- S _ = S _ => f_equal
               | _ => progress Z.ltb_to_lt
               | _ => congruence
               | _ => lia
               end.
  Qed.

  Lemma map_word_wrap_bounded' r x m :
    ZRange.is_tighter_than_bool r max_range = true ->
    list_Z_bounded_by (repeat (Some r) m) x ->
    map word.wrap x = x.
  Proof.
    intros.
    pose proof length_list_Z_bounded_by _ x ltac:(eassumption).
    cbv [max_bounds max_range list_Z_bounded_by
                    ZRange.is_tighter_than_bool] in *.
    rewrite repeat_length in *.
    generalize dependent m.
    generalize dependent x; induction x; destruct m;
      repeat match goal with
             | _ => progress intros
             | _ => progress cleanup
             | _ => progress
                      cbn [length FoldBool.fold_andb_map
                                  ZRange.upper ZRange.lower
                                  repeat map] in *
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H
             | IH : context [map word.wrap ?x = ?x] |- _ =>
               rewrite IH with (m:=m) by (try eassumption; lia)
             | _ => progress Z.ltb_to_lt
             | |- word.wrap ?x :: ?y = ?x :: ?y =>
               cbv [word.wrap]; Z.rewrite_mod_small;
                 reflexivity
             | _ => congruence
             end.
  Qed.

  Lemma map_word_wrap_bounded x :
    list_Z_bounded_by max_bounds x ->
    map word.wrap x = x.
  Proof.
    intros. eapply map_word_wrap_bounded'; [ | eassumption ].
    apply ZRange.is_tighter_than_bool_Reflexive.
  Qed.

  Lemma byte_unsigned_within_max_bounds x :
    length x = n ->
    list_Z_bounded_by max_bounds (map Byte.byte.unsigned x).
  Proof.
    intros; apply max_bounds_range_iff; split;
      [ rewrite ?map_length; solve [auto] | ].
    eapply Forall_impl;
      [ | apply Forall_map_byte_unsigned ].
    cbv beta; intros.
    pose proof Z.pow_le_mono_r 2 8 Semantics.width ltac:(lia) width_ge_8.
    rewrite bits_per_word_eq_width by auto using width_0mod_8.
    lia.
  Qed.

  Lemma partition_max_range :
    forall x,
      let bytes := (Memory.bytes_per
                      (width:=Semantics.width) access_size.word) in
      Forall (fun z => 0 <= z < 2^(Z.of_nat bytes * 8))
             (Partition.partition
                (UniformWeight.uweight Semantics.width) n x).
  Proof.
    pose proof word.width_pos. cbv zeta.
    induction n; intros; [ solve [constructor] | ].
    rewrite partition_step. apply Forall_snoc; auto; [ ].
    rewrite UniformWeight.uweight_S by lia.
    rewrite <-Z.mod_pull_div by auto with zarith.
    rewrite bits_per_word_eq_width by auto using width_0mod_8.
    apply Z.mod_pos_bound; auto with zarith.
  Qed.

  Lemma partition_bounded_by x :
    list_Z_bounded_by
      max_bounds
      (Partition.partition (UniformWeight.uweight Semantics.width) n x).
  Proof.
    apply max_bounds_range_iff; split;
      auto using partition_max_range, length_partition.
  Qed.
End MaxBounds.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Strings.String
        Coq.ZArith.ZArith
        Coq.Lists.List
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Coq.Bool.Bool
        Fiat.Common.ilist2
        Fiat.Computation
        Fiat.ADT
        Fiat.ADTRefinement
        Fiat.ADTNotation
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema
        Fiat.QueryStructure.Specification.Operations.Query
        Fiat.QueryStructure.Specification.Operations.Insert
        Fiat.QueryStructure.Specification.Representation.QueryStructure
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.Common.DecideableEnsembles
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.Common.Ensembles.EnsembleListEquivalence
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.QueryStructure.Implementation.Operations.General.InsertRefinements
        Fiat.QueryStructure.Implementation.Operations.General.QueryStructureRefinements
        Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksRefinements.

Fixpoint Check_List_Prop {A}
         (cond : A -> bool)
         (l : list A)
: bool :=
  match l with
    | [] => true
    | a :: l' => if (cond a) then
                   Check_List_Prop cond l'
                 else false
  end.

Lemma Check_List_Prop_dec {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Prop cond l = true <->
        forall a', List.In a' l -> P a').
Proof.
  split; induction l; simpl; intros; intuition; subst.
  generalize (H a'); find_if_inside; intuition; eauto.
  generalize (H a'); find_if_inside; intuition; eauto.
  generalize (H a); find_if_inside; intuition; eauto.
Qed.

Lemma Check_List_Prop_dec' {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Prop cond l = false <->
        (exists a', List.In a' l /\ ~ P a')).
Proof.
  split; induction l; simpl; intros; intuition; subst.
  generalize (H a); find_if_inside; intuition; eauto.
  destruct_ex; intuition; intuition; eauto.
  eexists; intuition.
  destruct_ex; intuition.
  generalize (H a); find_if_inside; intuition; eauto.
  destruct_ex; subst; intuition; eauto.
  subst; intuition.
Qed.

Definition Check_Attr_Depend
           {h}
           (attrlist attrlist' : list (Attributes h))
           (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
           (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
           (tup : RawTuple)
           (l : list RawTuple) :=
  Check_List_Prop (fun tup' => orb (negb (Tuple_Agree_eq _ attr_eq_dec' tup tup'))
                                   (Tuple_Agree_eq _ attr_eq_dec tup tup')) l.

Lemma Check_Attr_Depend_dec
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (l : list RawTuple),
    Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l = true ->
    (forall tup', List.In tup' l
                          -> tupleAgree tup tup' attrlist'
                          -> tupleAgree tup tup' attrlist).
Proof.
  unfold Check_Attr_Depend; intros.
  eapply Check_List_Prop_dec  with
  (P := fun tup' => tupleAgree tup tup' attrlist'
                            -> tupleAgree tup tup' attrlist) in H; eauto.
  intuition.
  let H := match goal with H : tupleAgree _ _ _ |- _ => constr:(H) end in
  apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in H;
    rewrite H in * ; simpl in *; eapply Tuple_Agree_eq_dec; eauto.
  destruct (Tuple_Agree_dec _ _ attr_eq_dec tup a); auto;
  [ apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in t; rewrite t, orb_true_r
  | apply (proj1 (Tuple_Agree_eq_dec' _ _ _ _ _ )) in n; rewrite n, orb_false_r]; auto.
  destruct (Tuple_Agree_dec _ _ attr_eq_dec' tup a); auto;
  [ apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in t; rewrite t
  | apply (proj1 (Tuple_Agree_eq_dec' _ _ _ _ _ )) in n0; rewrite n0]; auto.
  exfalso; eapply (Tuple_Agree_eq_dec' _ _ attr_eq_dec); eauto.
  match goal with
    | [ H : _ |- _ ]
      => apply H; eapply Tuple_Agree_eq_dec; solve [ eauto ]
  end.
Qed.

Lemma Check_Attr_Depend_dec'
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (l : list RawTuple),
    Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l = false ->
    ~ (forall tup' : RawTuple, List.In tup' l
                            -> tupleAgree tup tup' attrlist'
                            -> tupleAgree tup tup' attrlist).
Proof.
  unfold Check_Attr_Depend; intros.
  eapply Check_List_Prop_dec' with
  (P := fun tup' : RawTuple =>
          ~ tupleAgree tup tup' attrlist' \/
          tupleAgree tup tup' attrlist) in H; eauto.
  destruct_ex; intuition; eauto.
  intros; destruct (Tuple_Agree_dec _ _ attr_eq_dec' tup a); auto;
  [ apply (proj1 (Tuple_Agree_eq_dec _ _ _ _ _ )) in t; rewrite t |
    apply (proj1 (Tuple_Agree_eq_dec' _ _ _ _ _ )) in n; rewrite n];
  simpl; intuition.
  right;   eapply Tuple_Agree_eq_dec; eauto.
  exfalso;
    match goal with
      | [ H : _ |- _ ] => apply H; eapply Tuple_Agree_eq_dec; eauto
    end.
  eapply Tuple_Agree_eq_dec; eauto.
  left; eapply Tuple_Agree_eq_dec'; eauto.
Qed.

Lemma refine_unused_key_check
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (rel : Ensemble IndexedRawTuple)
         (l : list RawTuple),
    EnsembleIndexedListEquivalence  rel l
    -> refine {b | decides b
                           (forall tup' : IndexedRawTuple,
                              rel tup' ->
                              tupleAgree tup (indexedElement tup') attrlist' ->
                              tupleAgree tup (indexedElement tup') attrlist)}
              (ret (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l)).
Proof.
  intros.
  unfold refine; intros;  computes_to_inv;
  subst; computes_to_econstructor.
  case_eq (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l); simpl; intros.
  eapply Check_Attr_Depend_dec; try apply H; eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  eapply in_map; eapply equiv_l_l'; eapply H1.
  unfold not; intros.
  eapply (Check_Attr_Depend_dec' attr_eq_dec attr_eq_dec'); eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  intros.
  apply (in_map_iff indexedRawTuple) in H; destruct_ex;
  intuition; subst.
  intros; eapply H1; eauto.
  eapply equiv_l_l'; eauto.
Qed.

Lemma refine_unused_key_check'
: forall (h : RawHeading)
         (attrlist attrlist' : list (Attributes h))
         (attr_eq_dec : List_Query_eq (map (Domain h) attrlist))
         (attr_eq_dec' : List_Query_eq (map (Domain h) attrlist'))
         (tup : RawTuple)
         (rel : Ensemble IndexedRawTuple)
         (l : list RawTuple),
    EnsembleIndexedListEquivalence  rel l
    -> refine {b | decides b
                           (forall tup' : IndexedRawTuple,
                              rel tup' ->
                              tupleAgree (indexedElement tup') tup attrlist' ->
                              tupleAgree (indexedElement tup') tup attrlist)}
              (ret (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l)).
Proof.
  intros.
  unfold refine; intros;  computes_to_inv;
  subst; computes_to_econstructor.
  case_eq (Check_Attr_Depend _ _ attr_eq_dec attr_eq_dec' tup l); simpl; intros.
  unfold tupleAgree in *; intros; apply sym_eq.
  eapply (Check_Attr_Depend_dec _ attr_eq_dec attr_eq_dec'); unfold tupleAgree;
  intros; try apply H; try rewrite H2; eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  eapply in_map; eapply equiv_l_l'; eapply H1.
  unfold not; intros.
  eapply (Check_Attr_Depend_dec' attr_eq_dec attr_eq_dec'); eauto.
  unfold tupleAgree in *; intros.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  apply (in_map_iff indexedRawTuple) in H2; destruct_ex; intuition;
  subst.
  apply sym_eq; apply H1; try eapply H; eauto.
  eapply equiv_l_l'; eauto.
  intros; rewrite H3; eauto.
Qed.

Fixpoint Check_List_Ex_Prop {A}
         (cond : A -> bool)
         (l : list A)
: bool :=
  match l with
    | [] => false
    | a :: l' => if (cond a) then
                   true else
                   Check_List_Ex_Prop cond l'
  end.

Lemma Check_List_Ex_Prop_dec {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Ex_Prop cond l = true ->
        exists a', List.In a' l /\ P a').
Proof.
  induction l; simpl; intros; intuition; subst.
  generalize (H a); find_if_inside; intuition; eauto.
  destruct_ex; intuition; eauto.
Qed.

Lemma Check_List_Ex_Prop_dec' {A} :
  forall (cond : A -> bool)
         (P : Ensemble A)
         (l : list A),
    (forall a, cond a = true <-> P a)
    -> (Check_List_Ex_Prop cond l = false ->
        ~ exists a', List.In a' l /\ P a').
Proof.
  induction l; simpl; intros; intuition; subst.
  destruct_ex; intuition.
  destruct_ex; intuition; subst; eauto;
  generalize (H x); find_if_inside; intuition; eauto.
Qed.

Lemma refine_foreign_key_check
      (h : RawHeading)
      (rel : Ensemble IndexedRawTuple)
      (l : list RawTuple)
      (P : Ensemble RawTuple)
      (P_dec : DecideableEnsemble P)
: EnsembleIndexedListEquivalence rel l
    -> refine {b  |
               decides b
                       (exists tup' : @IndexedRawTuple h,
                          rel tup' /\
                          P (indexedElement tup'))}
              (ret (Check_List_Ex_Prop (DecideableEnsembles.dec) l)).
Proof.
  intros.
  unfold refine; intros;  computes_to_inv;
  subst; computes_to_econstructor.
  case_eq (Check_List_Ex_Prop DecideableEnsembles.dec l); simpl; intros.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  destruct (Check_List_Ex_Prop_dec DecideableEnsembles.dec P _ dec_decides_P H0);
    intuition.
  apply in_map_iff in H1; destruct_ex; intuition; subst.
  eexists; intuition; eauto; eapply equiv_l_l'; eauto.
  unfold not; intros; eapply Check_List_Ex_Prop_dec';
  eauto using dec_decides_P.
  destruct_ex; intuition; eexists; intuition; try apply H; eauto.
  destruct H as [l' [fresh_l' [l'_eq [equiv_l_l' _] ] ] ]; subst.
  eapply in_map; eapply equiv_l_l'; unfold In; eauto.
Qed.

Add Parametric Morphism {A: Type} (b : bool):
  (If_Then_Else b)
    with signature (
      @refine A ==> @refine A ==> refine)
      as refine_refine_if.
Proof.
  unfold refine, If_Then_Else; intros.
  destruct b; eauto.
Qed.

Lemma refine_list_insert_in_other_table :
  forall (db_schema : QueryStructureSchema) (qs : UnConstrQueryStructure db_schema)
         index1 index2 (store : list RawTuple),
    EnsembleIndexedListEquivalence (GetUnConstrRelation qs index2) store ->
    index1 <> index2 ->
    forall inserted : @IndexedRawTuple _,
      EnsembleIndexedListEquivalence
        (GetUnConstrRelation
           (UpdateUnConstrRelation qs index1
                                   (EnsembleInsert inserted (GetUnConstrRelation qs index1))) index2)
        (store).
Proof.
  intros; rewrite get_update_unconstr_neq; eauto.
Qed.

Ltac refine_list_insert_in_other_table :=
  match goal with
    | [ |- context [
               EnsembleIndexedListEquivalence
                 (GetUnConstrRelation
                    (UpdateUnConstrRelation ?qs ?index1
                                            (EnsembleInsert ?inserted
                                                            (GetUnConstrRelation ?qs ?index1)))
                    ?index2) ] ] => apply (@refine_list_insert_in_other_table _ qs index1 index2);
                                   [ eauto | intuition discriminate ]
  end.

Lemma ImplementListInsert_eq qsSchema Ridx
      (tup : RawTuple)
      (or : UnConstrQueryStructure qsSchema)
      (nr : list (RawTuple))
      (bound : nat)
:
  EnsembleIndexedListEquivalence (GetUnConstrRelation or Ridx) nr
  -> (UnConstrFreshIdx (GetUnConstrRelation or Ridx) bound)
  -> refine
       {a |
        EnsembleIndexedListEquivalence
          (GetUnConstrRelation
             (@UpdateUnConstrRelation qsSchema or Ridx
                                     (EnsembleInsert {| elementIndex := bound;
                                                        indexedElement := tup|}
                                                     (GetUnConstrRelation or Ridx))) Ridx) a}
       (ret (tup :: nr)).
Proof.
  unfold refine; intros;  computes_to_inv; subst; computes_to_constructor.
  unfold GetUnConstrRelation, UpdateUnConstrRelation in *.
  rewrite ith_replace2_Index_eq.
  unfold EnsembleInsert, In, EnsembleIndexedListEquivalence, UnConstrFreshIdx in *;
    intuition.
  exists (S bound); unfold In in *; destruct_ex; subst; simpl.
  intros; intuition; subst.
  simpl. omega.
  destruct H2 as [l' [l'_eq [equiv_l' NoDup_l'] ] ].
    econstructor 1 with ({| elementIndex := bound;
                            indexedElement := tup|} :: l'); split; eauto.
  simpl; subst; reflexivity.
  unfold EnsembleListEquivalence in *; intuition.
  unfold In in *; subst; intuition.
  subst; simpl; eauto.
  simpl; right; eapply equiv_l'; eauto.
  simpl in *; unfold In; intuition.
  eapply equiv_l' in H2; eauto.
  simpl; econstructor; eauto.
  unfold not; intros.
  rewrite in_map_iff in H; destruct_ex; intuition.
  apply equiv_l' in H3; apply H0 in H3.
  simpl in *; omega.
Qed.

Lemma ImplementListInsert_neq qsSchema Ridx Ridx'
      (tup : RawTuple)
      (or : UnConstrQueryStructure qsSchema)
      (nr : list (RawTuple))
      m
:
  Ridx <> Ridx'
  -> EnsembleIndexedListEquivalence (GetUnConstrRelation or Ridx) nr
  -> refine
       {a |
        EnsembleIndexedListEquivalence
          (GetUnConstrRelation
             (@UpdateUnConstrRelation qsSchema or Ridx'
                                     (EnsembleInsert {| elementIndex := m;
                                                        indexedElement := tup|}
 (GetUnConstrRelation or Ridx'))) Ridx) a}
       (ret nr).
Proof.
  unfold refine; intros;  computes_to_inv; subst; computes_to_constructor.
  unfold GetUnConstrRelation, UpdateUnConstrRelation in *.
  rewrite ith_replace2_Index_neq; eauto using string_dec.
Qed.

Tactic Notation "implement" "insert" "for" "lists" :=
  repeat (progress
            (try (setoid_rewrite ImplementListInsert_eq; eauto;
                  try simplify with monad laws);
             try (match goal with
                      |- context
                           [{a | EnsembleIndexedListEquivalence
                                   ((UpdateUnConstrRelation ?QSSchema ?c ?Ridx
                                                            (EnsembleInsert ?n (?c!?R)))!?R')%QueryImpl a}%comp] =>
                      setoid_rewrite ((@ImplementListInsert_neq QSSchema
                                                                {| bindex := R' |}
                                                                {| bindex := R |} n c))
                  end;
                    eauto; try simplify with monad laws);
             try (match goal with
                    | |- context [ (GetUnConstrRelation _ ?Ridx) ] =>
                      setoid_rewrite (@ImplementListInsert_neq _ Ridx)
                  end; eauto; try simplify with monad laws)));
  try reflexivity.

Ltac implement_foreign_key_check_w_lists H :=
  repeat (match goal with
              |- context [
                     forall tup' : @RawTuple ?h,
                       (?qs ! ?R )%QueryImpl tup' ->
                       tupleAgree ?n tup' ?attrlist2%SchemaConstraints ->
                       tupleAgree ?n tup' ?attrlist1%SchemaConstraints ]
              =>
              setoid_rewrite (@refine_unused_key_check h attrlist1 attrlist2 _ _ n (qs ! R )%QueryImpl);
              [ simplify with monad laws |
                unfold H in *; split_and; eauto ]
              | |- context [
                       forall tup' : @RawTuple ?h,
                         (?qs ! ?R )%QueryImpl tup' ->
                         tupleAgree tup' ?n ?attrlist2%SchemaConstraints ->
                         tupleAgree tup' ?n  ?attrlist1%SchemaConstraints]
                =>
                setoid_rewrite (@refine_unused_key_check' h attrlist1 attrlist2 _ _ n (qs ! R )%QueryImpl);
              [ simplify with monad laws |
                unfold H in *; split_and; eauto ]
          end).


From Equations Require Import Equations.
From Coq Require Import Arith Lia List Program.Equality.
From FOL Require Import FullSyntax.
From FOL Require Import Semantics.Heyting.Heyting Completeness.HeytingMacNeille.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
Import ListNotations.
From Coq Require Import Vector List.
Import ListAutomationNotations ListAutomationHints ListAutomationInstances ListAutomationFacts.

Section Lindenbaum.
Context {Σ_funcs : funcs_signature}.
Context {Σ_preds : preds_signature}.
Context {eq_dec_Funcs : EqDec Σ_funcs}.
Context {eq_dec_Preds : EqDec Σ_preds}.

(** ** Lindenbaum Algebra *)

Section Completeness.

  (*Context { b : peirce }.*)

  Notation "A ⊢E phi" := (A ⊢I phi) (at level 30).

  Instance lb_alg : HeytingAlgebra.
  Proof.
    unshelve eapply (@Build_HeytingAlgebra (@form _ _ _ falsity_on)).
    - intros phi psi. exact ([phi] ⊢E psi).
    - exact ⊥.
    - intros phi psi. exact (phi ∧ psi).
    - intros phi psi. exact (phi ∨ psi).
    - intros phi psi. exact (phi → psi).
    - intros phi. apply Ctx. now left.
    - intros phi psi theta H1 H2. apply IE with (phi:=psi); trivial.
      apply Weak with (A:=[]); auto. econstructor. apply H2.
    - intros phi. cbn. apply Exp, Ctx. now left.
    - intros phi psi theta. cbn. split.
      + intros [H1 H2]. now apply CI.
      + intros H. split; [apply (CE1 H) | apply (CE2 H)].
    - intros phi psi theta. cbn. split.
      + intros [H1 H2]. eapply DE. apply Ctx; auto.
        eapply Weak. exact H1. firstorder.
        eapply Weak. exact H2. firstorder.
      + intros H; split.
        * apply (IE (phi := phi ∨ psi)). 2: try apply DI1, Ctx. 2: now left.
          apply II. eapply Weak; eauto.
        * apply (IE (phi := phi ∨ psi)); try apply DI2, Ctx; try now left.
          apply II. eapply Weak; eauto.
    - intros phi psi theta. cbn. split.
      + intros H. apply II. apply (IE (phi := theta ∧ phi)).
        * apply II. eapply Weak. 1: apply H. firstorder.
        * apply CI; apply Ctx; firstorder.
      + intros H. eapply IE. 2: eapply CE2, Ctx; now left.
        eapply IE. 1: eapply II, Weak. 1: apply H. 2: eapply CE1, Ctx; now left. firstorder.
  Defined.

  Lemma lb_alg_iff phi :
    Top <= phi <-> [] ⊢E phi.
  Proof.
    cbn. split; intros H.
    - apply (IE (phi := ¬ ⊥)); apply II; eauto using Ctx.
    - eapply Weak; eauto; firstorder.
  Qed.

  Instance lb_calg : CompleteHeytingAlgebra :=
    @completion_calgebra lb_alg.

  Definition lb_Pr P v : lb_calg :=
    embed (atom P v).

  (** ** Heyting Completeness *)

  Lemma lindenbaum_hsat phi :
    down phi ≡ proj1_sig (hsat lb_Pr phi).
  Proof.
    induction phi  as [| |[]|[]] using form_ind_subst; simp hsat in *.
    - rewrite down_bot. reflexivity.
    - cbn. reflexivity.
    - rewrite (@down_meet lb_alg f1 f2), IHphi, IHphi0. now destruct hsat, hsat.
    - rewrite (@down_join lb_alg f1 f2), IHphi, IHphi0. now destruct hsat, hsat.
    - rewrite (@down_impl lb_alg f1 f2), IHphi, IHphi0. now destruct hsat, hsat.
    - cbn. split; intros psi H'.
      + intros X [HX [t Ht]]. change (psi ∈ proj1_sig (exist normal X HX)).
        eapply Ht. rewrite <- H. apply AllE, H'.
      + apply AllI. destruct (@nameless_equiv_all _ _ _ intu ([psi]) f2) as [t Ht]. apply Ht.
        apply H, H'. exists (proj2_sig (hsat lb_Pr f2[t..])), t. now destruct hsat.
    - cbn. split; intros psi H'.
      + intros X [XD HX]. apply XD. intros theta HT. apply (ExE H').
        destruct (@nameless_equiv_ex _ _ _ intu ([psi]) f2 theta) as [t Ht]. apply Ht.
        assert (exists i : term, equiv_HA (hsat lb_Pr f2[t..]) (hsat lb_Pr f2[i..])) by now eexists.
        specialize (HX (hsat lb_Pr f2[t..]) H0).
        apply Weak with (A:=[f2[t..]]); auto.
        apply HT, HX. rewrite <- H. apply Ctx. now left.
      + specialize (H' (down (∃ f2))). apply H'.
        exists (@down_normal lb_alg (∃ f2)). intros X [t ?].
        intros ? ?. eapply H0 in H1.
        revert x H1. fold (hset_sub (proj1_sig (hsat lb_Pr f2[t..])) (down (∃ f2))).
        rewrite <- H. apply down_mono. eapply ExI, Ctx; eauto.
  Qed.

  Lemma lindenbaum_eqH phi :
    eqH (embed phi) (hsat lb_Pr phi).
  Proof.
    unfold eqH. cbn. now rewrite <- lindenbaum_hsat.
  Qed.

  Lemma lb_calg_iff phi :
    Top <= hsat lb_Pr phi <-> nil ⊢E phi.
  Proof.
    cbn. rewrite <- lindenbaum_hsat.
    rewrite <- down_top, <- lb_alg_iff. split.
    - apply down_inj.
    - apply down_mono.
  Qed.

End Completeness.

(* ** Intuitionistic ND *)

Definition hvalid phi :=
  forall (HA : CompleteHeytingAlgebra) HP, Top <= hsat HP phi.

Theorem hcompleteness phi :
  hvalid phi -> nil ⊢I phi.
Proof.
  intros H.
  specialize (H lb_calg lb_Pr).
  now eapply lb_calg_iff.
  Unshelve.
Qed.

(* ** Generalised Lindenbaum Algebras *)

Section Completeness.

  Variable gprv : list form -> form -> Prop.

  Notation "A ⊢ phi" := (gprv A phi) (at level 55).

  Hypothesis gCtx : forall A phi, In phi A -> A ⊢ phi.
  Hypothesis gIE : forall A phi psi, A ⊢ (phi → psi) -> A ⊢ phi -> A ⊢ psi.
  Hypothesis gII : forall A phi psi, (phi::A) ⊢ psi -> A ⊢ (phi → psi).
  Hypothesis gExp : forall A phi, A ⊢ ⊥ -> A ⊢ phi.
  Hypothesis gCI : forall A phi psi, A ⊢ phi -> A ⊢ psi -> A ⊢ (phi ∧ psi).
  Hypothesis gCE1 : forall A phi psi, A ⊢ (phi ∧ psi) -> A ⊢ phi.
  Hypothesis gCE2 : forall A phi psi, A ⊢ (phi ∧ psi) -> A ⊢ psi.
  Hypothesis gDI1 : forall A phi psi, A ⊢ phi -> A ⊢ (phi ∨ psi).
  Hypothesis gDI2 : forall A phi psi, A ⊢ psi -> A ⊢ (phi ∨ psi).
  Hypothesis gDE : forall A phi psi theta, A ⊢ (phi ∨ psi) -> (phi :: A) ⊢ theta -> (psi :: A) ⊢ theta -> A ⊢ theta.
  Hypothesis gWeak : forall A B phi, A ⊢ phi -> incl A B -> B ⊢ phi.

  Instance glb_alg : HeytingAlgebra.
  Proof.
    unshelve eapply (@Build_HeytingAlgebra (form)).
    - intros phi psi. exact ([phi] ⊢ psi).
    - exact ⊥.
    - intros phi psi. exact (phi ∧ psi).
    - intros phi psi. exact (phi ∨ psi).
    - intros phi psi. exact (phi → psi).
    - intros phi. apply gCtx. now left.
    - intros phi psi theta H1 H2. apply gIE with (phi:=psi); trivial.
      apply gWeak with (A:=[]); auto.
    - intros phi. cbn. apply gExp, gCtx. now left.
    - intros phi psi theta. cbn. split.
      + intros [H1 H2]. now apply gCI.
      + intros H. split; [apply (gCE1 H) | apply (gCE2 H)].
    - intros phi psi theta. cbn. split.
      + intros [H1 H2]. eapply gDE. apply gCtx; auto.
        eapply gWeak. exact H1. firstorder.
        eapply gWeak. exact H2. firstorder.
      + intros H; split.
        * apply (gIE (phi := phi ∨ psi)); try apply gDI1, gCtx.
          apply gII. eapply gWeak; eauto. 1: firstorder.
        * apply (gIE (phi := phi ∨ psi)); try apply gDI2, gCtx.
          apply gII. eapply gWeak; eauto. 1: firstorder.
    - intros phi psi theta. cbn. split.
      + intros H. apply gII. apply (gIE (phi := theta ∧ phi)).
        * apply gII. eapply gWeak; eauto.
        * apply gCI; apply gCtx; auto.
      + intros H. apply (gIE (phi:=phi)). 2: eapply gCE2, gCtx; now left.
        eapply gIE. 1: eapply gII, gWeak. 1: apply H. 2: eapply gCE1, gCtx; now left.
        firstorder.
  Defined.

  Lemma glb_alg_iff phi :
    Top <= phi <-> [] ⊢ phi.
  Proof.
    cbn. split; intros H.
    - apply (gIE (phi := ¬ ⊥)); apply gII. 2: apply gCtx; now left. apply H.
    - eapply gWeak; eauto.
  Qed.

  Instance glb_calg : CompleteHeytingAlgebra :=
    @completion_calgebra glb_alg.

  Definition glb_Pr P v : glb_calg :=
    embed (atom P v).

  Hypothesis gAllI : forall A phi, map (subst_form ↑) A ⊢ phi -> A ⊢ (∀ phi).
  Hypothesis gAllE : forall A t phi, A ⊢ (∀ phi) -> A ⊢ phi[t..].
  Hypothesis gExI : forall A t phi, A ⊢ phi[t..] -> A ⊢ (∃ phi).
  Hypothesis gExE : forall A phi psi, A ⊢ (∃ phi) -> (phi :: map (subst_form ↑) A) ⊢ psi[↑] -> A ⊢ psi.
  Hypothesis gnameless_equiv_all' : forall A phi, exists t, A ⊢ phi[t..] <-> map (subst_form ↑) A ⊢ phi.
  Hypothesis gnameless_equiv_ex' : forall A phi psi, exists t, (psi[t..] :: A) ⊢ phi <-> (psi :: map (subst_form ↑) A) ⊢ phi[↑].

  Lemma glindenbaum_hsat phi :
    down phi ≡ proj1_sig (hsat glb_Pr phi).
  Proof.
    induction phi as [| |[]phi ? psi ?|[] phi ?] using form_ind_subst; simp hsat in *.
    - rewrite down_bot. reflexivity.
    - cbn. reflexivity.
    - rewrite (@down_meet glb_alg phi psi), IHphi, IHphi0. now destruct hsat, hsat.
    - rewrite (@down_join glb_alg phi psi), IHphi, IHphi0. now destruct hsat, hsat.
    - rewrite (@down_impl glb_alg phi psi), IHphi, IHphi0. now destruct hsat, hsat.
    - cbn. split; intros psi H'.
      + intros X [HX [t Ht]]. change (psi ∈ proj1_sig (exist normal X HX)).
        eapply Ht. rewrite <- H. apply gAllE, H'.
      + apply gAllI. destruct (@gnameless_equiv_all' ([psi]) phi) as [t <-].
        apply H, H'. exists (proj2_sig (hsat glb_Pr phi[t..])), t. now destruct hsat.
    - cbn. split; intros psi H'.
      + intros X [XD HX]. apply XD. intros theta HT. apply (gExE H').
        destruct (@gnameless_equiv_ex' ([psi]) theta phi) as [t <-].
        assert (exists i : term, equiv_HA (hsat glb_Pr phi[t..]) (hsat glb_Pr phi[i..])) by now eexists.
        specialize (HX (hsat glb_Pr phi[t..]) H0).
        apply gWeak with (A:=[phi[t..]]); auto.
        apply HT, HX. rewrite <- H. apply gCtx. now left.
      + specialize (H' (down (∃ phi))). apply H'.
        exists (@down_normal glb_alg (∃ phi)). intros X [t ?].
        intros ? ?. eapply H0 in H1.
        revert x H1. fold (hset_sub (proj1_sig (hsat glb_Pr phi[t..])) (down (∃ phi))).
        rewrite <- H. apply down_mono. eapply gExI, gCtx; eauto.
  Qed.

  Lemma glindenbaum_eqH phi :
    eqH (embed phi) (hsat glb_Pr phi).
  Proof.
    unfold eqH. cbn. now rewrite <- glindenbaum_hsat.
  Qed.

  Lemma glb_calg_iff phi :
    Top <= hsat glb_Pr phi <-> nil ⊢ phi.
  Proof.
    cbn. rewrite <- glindenbaum_hsat.
    rewrite <- down_top, <- glb_alg_iff. split.
    - apply down_inj.
    - apply down_mono.
  Qed.

End Completeness.

(** ** Boolean Completeness *)
#[local] Hint Constructors prv : core.
Instance clb_alg : HeytingAlgebra.
Proof.
  apply (@glb_alg (@prv _ _ _ class)); eauto 2.
  apply Weak.
Defined.

Instance clb_calg : CompleteHeytingAlgebra.
Proof.
  apply (@glb_calg (@prv _ _ _ class)); eauto 2. apply Weak.
Defined.

Definition clb_Pr P (v : Vector.t term (ar_preds P)) : clb_calg.
Proof.
  apply glb_Pr with P. exact v.
Defined.

Lemma clb_alg_boolean :
  boolean clb_alg.
Proof.
  intros phi psi. cbn. eapply IE; try apply Pc. apply Ctx. now left.
Qed.

Lemma boolean_completion HA :
  boolean HA -> boolean (@completion_calgebra HA).
Proof.
  intros H. intros [X HX] [Y HY]; cbn. intros a Ha.
  unfold hset_impl in Ha. apply HX.
  intros b Hb. specialize (Ha (Impl b Bot)).
  eapply Rtra; try apply H. apply Impl1, Hb, Ha.
  intros c Hc. apply HY. intros d Hd. apply Rtra with Bot; try apply Bot1.
  assert (H' : Meet (Impl b Bot) c <= Impl b Bot) by apply Meet2.
  apply Impl1 in H'. eapply Rtra; try eassumption. repeat rewrite <- Meet1.
  repeat split; auto. eapply Rtra; try apply Meet3. now apply Hb.
Qed.

Definition bvalid phi :=
  forall (HA : CompleteHeytingAlgebra) HP, boolean HA -> Top <= hsat HP phi.

Theorem bcompleteness phi :
  bvalid phi -> nil ⊢C phi.
Proof.
  intros H.
  specialize (H clb_calg clb_Pr (boolean_completion clb_alg_boolean)).
  apply glb_calg_iff in H; eauto 2; clear H0.
  - intros A psi. edestruct (nameless_equiv_all (p:=class) A psi) as (x & Hx).
    exists x. now rewrite Hx.
  - intros A psi chi. edestruct (nameless_equiv_ex (p:=class) A chi psi) as (x & Hx).
    exists x. now rewrite Hx.
Qed.

End Lindenbaum.


Require Import XR_Rabs.
Require Import XR_Rmax.
Require Import XR_Rcase_abs.
Require Import XR_Rle_dec.
Require Import XR_Rle_trans.
Require Import XR_Rle_lt_trans.
Require Import XR_Rlt_le_trans.
Require Import XR_Ropp_le_contravar.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma RmaxAbs :
  forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
Proof.
  intros x y z.
  intros hxy hyz.
  unfold Rmax.
  destruct (Rle_dec (Rabs x) (Rabs z)) as [ hm | hm ].
  {
    unfold Rabs in hm ; unfold Rabs.
    destruct (Rcase_abs x) as [ hx | hx ] ;
    destruct (Rcase_abs y) as [ hy | hy ] ;
    destruct (Rcase_abs z) as [ hz | hz ].
    {
      apply Rle_trans with (-x).
      {
        apply Ropp_le_contravar.
        exact hxy.
      }
      { exact hm. }
    }
    {
      apply Rle_trans with (-x).
      {
        apply Ropp_le_contravar.
        exact hxy.
      }
      { exact hm. }
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      {
        apply Rle_lt_trans with z.
        {
          apply Rle_trans with y.
          { exact hy. }
          { exact hyz. }
        }
        { exact hz. }
      }
    }
    { exact hyz. }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with y.
      {
        apply Rle_trans with x.
        { exact hx. }
        { exact hxy. }
      }
      { exact hy. }
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with y.
      {
        apply Rle_trans with x.
        { exact hx. }
        { exact hxy. }
      }
      { exact hy. }
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with z.
      {
        apply Rle_trans with y.
        { exact hy. }
        { exact hyz. }
      }
      { exact hz. }
    }
    { exact hyz. }
  }
  {
    unfold Rabs in hm ; unfold Rabs.
    destruct (Rcase_abs x) as [ hx | hx ] ;
    destruct (Rcase_abs y) as [ hy | hy ] ;
    destruct (Rcase_abs z) as [ hz | hz ].
    {
      apply Ropp_le_contravar.
      exact hxy.
    }
    {
      apply Ropp_le_contravar.
      exact hxy.
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with z.
      {
        apply Rle_trans with y.
        { exact hy. }
        { exact hyz. }
      }
      { exact hz. }
    }
    {
      assert (hzx : z < -x).
      {
        apply Rnot_le_lt.
        exact hm.
      }
      apply Rle_trans with z.
      { exact hyz. }
      {
        left.
        exact hzx.
      }
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with y.
      {
        apply Rle_trans with x.
        { exact hx. }
        { exact hxy. }
      }
      { exact hy. }
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with y.
      {
        apply Rle_trans with x.
        { exact hx. }
        { exact hxy. }
      }
      { exact hy. }
    }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with z.
      {
        apply Rle_trans with y.
        { exact hy. }
        { exact hyz. }
      }
      { exact hz. }
    }
    {
      assert (hzx : z < x).
      {
        apply Rnot_le_lt.
        exact hm.
      }
      exfalso.
      apply Rlt_irrefl with z.
      apply Rlt_le_trans with x.
      { exact hzx. }
      {
        apply Rle_trans with y.
        { exact hxy. }
        { exact hyz. }
      }
    }
  }
Qed.


Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Setoids.Setoid
        Coq.Arith.PeanoNat
        Coq.omega.Omega
        Coq.setoid_ring.Ring
        Coq.setoid_ring.Ring_theory
        Matrix
        SparseMatrix
        DenseMatrix
        FiatHelpers
        MyHelpers
        MatrixLemmas
        optimize_ADT.

Section Perceptron.
  Variable n : nat.
  Context {ME : MatrixElem}.
  Definition eqq : MEt -> MEt -> bool := fun x y => MEeqdec x y.

  Parameter pos: 0 < n.

  Hint Resolve pos.

  Record THETA :=
    { theta : Vt n;
      theta0: MEt }.

  Definition PerceptronSig : ADTSig :=
    ADTsignature {
      Constructor "Init" : THETA -> rep,
      Method "Predict"   : rep * (Vt n)  -> rep * MEt,
      Method "Update"    : rep * (Vt n) * (MEt) -> rep * unit
    }.

  Definition PerceptronSpec : ADT PerceptronSig :=
    Def ADT {
      rep := THETA,

      Def Constructor1 "Init" (init_state: THETA): rep := ret init_state,,

      Def Method1 "Predict" (r : THETA) (x: Vt n) : rep * (MEt) :=
        ans <<- (Mget ((transpose (r.(theta))) @* x) 0 0) +e r.(theta0);
        ret (r, ans),

      Def Method2 "Update" (r : THETA) (x: Vt n) (y: MEt): rep * unit :=
        tr <<- transpose r.(theta);
        prod <<- tr @* x;
        ans <<- Mget prod 0 0 +e r.(theta0);
        neq <<- if eqq ans y then 0 else 1;
        theta' <<- if neq =? 1 then r.(theta) @+ x else r.(theta);
        theta0' <<- if neq =? 1 then r.(theta0) +e y else r.(theta0);
        ret ({|theta := theta'; theta0 := theta0'|}, tt)
        }%methDefParsing.

  Record THETA_ :=
    { theta_ : Vt n;
      theta0_ : MEt }.

  Definition use_same (or : THETA) (nr : THETA_) :=
    or.(theta) @= nr.(theta_) /\ or.(theta0) = nr.(theta0_).

  Definition SharpenedPerceptron :
    FullySharpened PerceptronSpec.
  Proof.
    Optimize_ADT THETA THETA_ use_same.
  Defined.

  Definition PerceptronImpl : ComputationalADT.cADT PerceptronSig :=
    Eval simpl in projT1 SharpenedPerceptron.

  Print PerceptronImpl.

End Perceptron.


Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.BinNat.
Require Import Coq.Arith.Arith.
Require Import Bedrock.Word.
Require Import Crypto.Util.FixedWordSizes.
Require Import Crypto.Util.WordUtil.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.

Definition wordT_beq_hetero {logsz1 logsz2} : wordT logsz1 -> wordT logsz2 -> bool
  := match logsz1 return wordT logsz1 -> wordT logsz2 -> bool with
     | 5 as logsz1' | 6 as logsz1' | 7 as logsz1'
     | _ as logsz1'
       => match logsz2 return wordT logsz1' -> wordT logsz2 -> bool with
          | 5 as logsz2' | 6 as logsz2' | 7 as logsz2'
          | _ as logsz2'
            => @Word.weqb_hetero (2^logsz1') (2^logsz2')
          end
     end.

(* transparent so the equality proof can compute away *)
Lemma pow2_inj_helper x y : 2^x = 2^y -> x = y.
Proof.
  destruct (NatUtil.nat_eq_dec x y) as [pf|pf]; [ intros; assumption | ].
  intro H; exfalso.
  abstract (apply pf; eapply NPeano.Nat.pow_inj_r; [ | eassumption ]; omega).
Defined.
Lemma pow2_inj_helper_refl x p : pow2_inj_helper x x p = eq_refl.
Proof.
  induction x; simpl; [ reflexivity | ].
  etransitivity; [ | exact (f_equal (fun p => f_equal S p) (IHx eq_refl)) ]; clear IHx.
  unfold pow2_inj_helper in *; simpl.
  pose proof (NatUtil.nat_eq_dec_S x x).
  do 2 edestruct NatUtil.nat_eq_dec; try assumption; try (exfalso; assumption).
  match goal with
  | [ H : ?x <> ?x |- _ ] => exfalso; clear -H; exact (H eq_refl)
  end.
Defined.
Lemma pow2_inj_helper_eq_rect x y P v v'
  : (exists pf : 2^x = 2^y, eq_rect _ P v _ pf = v')
    -> (exists pf : x = y, eq_rect _ (fun e => P (2^e)) v _ pf = v').
Proof.
  intros [pf H]; exists (pow2_inj_helper x y pf); subst v'.
  destruct (NatUtil.nat_eq_dec x y) as [H|H];
    [ | exfalso; clear -pf H;
        abstract (apply pow2_inj_helper in pf; omega) ].
  subst; rewrite pow2_inj_helper_refl; simpl.
  pose proof (NatUtil.UIP_nat_transparent _ _ pf eq_refl); subst pf.
  reflexivity.
Defined.

Definition wordT_beq_lb logsz1
  : forall x y : wordT logsz1, x = y -> wordT_beq_hetero x y = true
  := match logsz1 return forall x y : wordT logsz1, x = y -> wordT_beq_hetero x y = true with
     | 5 as logsz1' | 6 as logsz1' | 7 as logsz1'
     | _ as logsz1'
       => fun x y pf => proj2 (@Word.weqb_hetero_true_iff (2^logsz1') x (2^logsz1') y) (ex_intro _ eq_refl pf)
     end.
Definition wordT_beq_hetero_lb {logsz1 logsz2}
  : forall x y, (exists pf : logsz1 = logsz2, eq_rect _ wordT x _ pf = y) -> wordT_beq_hetero x y = true.
Proof.
  intros x y [pf H]; subst logsz2; revert x y H; simpl.
  apply wordT_beq_lb.
Defined.

Definition wordT_beq_bl logsz
  : forall x y : wordT logsz, wordT_beq_hetero x y = true -> x = y
  := match logsz return forall x y : wordT logsz, wordT_beq_hetero x y = true -> x = y with
     | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7
     | _
       => fun x y pf => proj1 (Word.weqb_hetero_homo_true_iff _ x y) pf
     end.

Lemma wordT_beq_hetero_type_lb_false logsz1 logsz2 x y : logsz1 <> logsz2 -> @wordT_beq_hetero logsz1 logsz2 x y = false.
Proof.
  destruct (wordT_beq_hetero x y) eqn:H; [ | reflexivity ].
  revert H.
  repeat (try destruct logsz1 as [|logsz1];
          try destruct logsz2 as [|logsz2];
          try (intros; omega);
          try (intro H'; apply Word.weqb_hetero_true_iff in H'; destruct H' as [pf H']; pose proof (pow2_inj_helper _ _ pf); try omega)).
Qed.

Definition wordT_beq_hetero_bl {logsz1 logsz2}
  : forall x y, wordT_beq_hetero x y = true -> (exists pf : logsz1 = logsz2, eq_rect _ wordT x _ pf = y).
Proof.
  refine match logsz1, logsz2 return forall x y, wordT_beq_hetero x y = true -> (exists pf : logsz1 = logsz2, eq_rect _ wordT x _ pf = y) with
         | 0, 0 | 1, 1 | 2, 2 | 3, 3 | 4, 4 | 5, 5 | 6, 6
         | 7, 7
           => fun x y pf => ex_intro _ eq_refl (@wordT_beq_bl _ x y pf)
         | S (S (S (S (S (S (S (S a))))))), S (S (S (S (S (S (S (S b)))))))
           => match NatUtil.nat_eq_dec a b with
              | left pf
                => match pf with
                   | eq_refl => fun x y pf => ex_intro _ eq_refl (@wordT_beq_bl _ x y pf)
                   end
              | right n => fun x y pf => match _ : False with end
              end
         | _, _
           => fun x y pf => match _ : False with end
         end;
    try abstract (rewrite wordT_beq_hetero_type_lb_false in pf by omega; clear -pf; congruence).
Defined.

Lemma ZToWord_gen_wordToZ_gen : forall {sz} v, ZToWord_gen (@wordToZ_gen sz v) = v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros.
  rewrite N2Z.id, NToWord_wordToN; reflexivity.
Qed.

Lemma wordToZ_gen_ZToWord_gen : forall {sz} v, (0 <= v < 2^(Z.of_nat sz))%Z -> @wordToZ_gen sz (ZToWord_gen v) = v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros ?? [H0 H1].
  rewrite wordToN_NToWord_idempotent, Z2N.id; try omega.
  rewrite Npow2_N.
  apply Z2N.inj_lt in H1; [ | omega.. ].
  rewrite Z2N.inj_pow, <- nat_N_Z, N2Z.id in H1 by omega.
  assumption.
Qed.

Lemma ZToWord_gen_wordToZ_gen_ZToWord_gen : forall {sz1 sz2} v,
    (sz2 <= sz1)%nat -> @ZToWord_gen sz2 (wordToZ_gen (@ZToWord_gen sz1 v)) = ZToWord_gen v.
Proof.
  unfold ZToWord_gen, wordToZ_gen.
  intros sz1 sz2 v H.
  rewrite N2Z.id, NToWord_wordToN_NToWord by omega.
  reflexivity.
Qed.

Lemma wordToZ_gen_ZToWord_gen_wordToZ_gen sz1 sz2 w
  : (sz1 <= sz2)%nat -> wordToZ_gen (@ZToWord_gen sz2 (@wordToZ_gen sz1 w)) = wordToZ_gen w.
Proof.
  unfold ZToWord_gen, wordToZ_gen; intro H.
  rewrite N2Z.id, wordToN_NToWord_wordToN by omega.
  reflexivity.
Qed.

Lemma ZToWord_wordToZ : forall {sz} v, ZToWord (@wordToZ sz v) = v.
Proof.
  unfold wordT, word_case in *.
  intro sz; break_match; simpl; apply ZToWord_gen_wordToZ_gen.
Qed.

Lemma wordToZ_ZToWord : forall {sz} v, (0 <= v < 2^(Z.of_nat (2^sz)))%Z -> @wordToZ sz (ZToWord v) = v.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros; break_match; apply wordToZ_gen_ZToWord_gen;
    assumption.
Qed.

Local Ltac handle_le :=
  repeat match goal with
         | [ |- (S ?a <= 2^?b)%nat ]
           => change (2^(Nat.log2 (S a)) <= 2^b)%nat
         | [ |- (2^_ <= 2^_)%nat ]
           => apply Nat.pow_le_mono_r
         | [ |- _ <> _ ] => intro; omega
         | _ => assumption
         | [ |- (_ <= S _)%nat ]
           => apply Nat.leb_le; vm_compute; reflexivity
         | _ => exfalso; omega
         end.

Lemma ZToWord_wordToZ_ZToWord : forall {sz1 sz2} v,
    (sz2 <= sz1)%nat -> @ZToWord sz2 (wordToZ (@ZToWord sz1 v)) = ZToWord v.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz1 sz2; break_match; intros; apply ZToWord_gen_wordToZ_gen_ZToWord_gen;
    handle_le.
Qed.

Lemma wordToZ_ZToWord_wordToZ : forall sz1 sz2 w, (sz1 <= sz2)%nat -> wordToZ (@ZToWord sz2 (@wordToZ sz1 w)) = wordToZ w.
Proof.
  unfold wordToZ, ZToWord, word_case_dep.
  intros sz1 sz2; break_match; intros; apply wordToZ_gen_ZToWord_gen_wordToZ_gen;
    handle_le.
Qed.

Local Ltac wordToZ_word_case_dep_t :=
  let H := fresh in
  intro H;
  intros; unfold wordToZ, word_case_dep, wordT, word_case, word32, word64, word128, word32ToZ, word64ToZ, word128ToZ in *;
  break_innermost_match;
  change 128%nat with (2^7)%nat in *;
  change 64%nat with (2^6)%nat in *;
  change 32%nat with (2^5)%nat in *;
  apply H.

Lemma wordToZ_word_case_dep_unop (wop : forall sz, word sz -> word sz)
      (P : nat -> Z -> Z -> Type)
  : (forall logsz (x : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen (wop (2^logsz) x)))
    -> forall logsz (x : wordT logsz), P logsz (wordToZ x) (wordToZ (word_case_dep (T:=fun _ W => W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) x)).
Proof. wordToZ_word_case_dep_t. Qed.

Lemma wordToZ_word_case_dep_11op {T} (wop : forall sz, T -> word sz -> word sz)
      (P : nat -> Z -> Z -> Type)
      {v}
  : (forall logsz (x : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen (wop (2^logsz) v x)))
    -> forall logsz (x : wordT logsz), P logsz (wordToZ x) (wordToZ (word_case_dep (T:=fun _ W => T -> W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) v x)).
Proof. wordToZ_word_case_dep_t. Qed.

Lemma wordToZ_word_case_dep_binop (wop : forall sz, word sz -> word sz -> word sz)
      (P : nat -> Z -> Z -> Z -> Type)
  : (forall logsz (x y : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen y) (wordToZ_gen (wop (2^logsz) x y)))
    -> forall logsz (x y : wordT logsz), P logsz (wordToZ x) (wordToZ y) (wordToZ (word_case_dep (T:=fun _ W => W -> W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) x y)).
Proof. wordToZ_word_case_dep_t. Qed.

Lemma wordToZ_word_case_dep_quadop (wop : forall sz, word sz -> word sz -> word sz -> word sz -> word sz)
      (P : nat -> Z -> Z -> Z -> Z -> Z -> Type)
  : (forall logsz (x y z w : word (2^logsz)), P logsz (wordToZ_gen x) (wordToZ_gen y) (wordToZ_gen z) (wordToZ_gen w) (wordToZ_gen (wop (2^logsz) x y z w)))
    -> forall logsz (x y z w : wordT logsz), P logsz (wordToZ x) (wordToZ y) (wordToZ z) (wordToZ w) (wordToZ (word_case_dep (T:=fun _ W => W -> W -> W -> W -> W) logsz (wop 32) (wop 64) (wop 128) (fun _ => wop _) x y z w)).
Proof. wordToZ_word_case_dep_t. Qed.

(** This converts goals involving (currently only binary) [wordT]
    operations to the corresponding goals involving [word]
    operations. *)
Ltac syntactic_fixed_size_op_to_word :=
  lazymatch goal with
  | [ |- context[wordToZ (word_case_dep (T:=?T) ?logsz (?wop 32) (?wop 64) (?wop 128) ?f ?x)] ]
    => move x at top;
       revert dependent logsz; intros logsz x;
       pattern (wordToZ x), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x));
       let P := lazymatch goal with |- ?P _ _ => P end in
       let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
       revert logsz x;
       refine (@wordToZ_word_case_dep_unop wop P _);
       intros logsz x; intros
  | [ |- context[wordToZ (word_case_dep (T:=?T) ?logsz (?wop 32) (?wop 64) (?wop 128) ?f ?x ?y)] ]
    => lazymatch type of x with
       | context[logsz]
         => move y at top; move x at top;
            revert dependent logsz; intros logsz x y;
            pattern (wordToZ x), (wordToZ y), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x y));
            let P := lazymatch goal with |- ?P _ _ _ => P end in
            let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
            revert logsz x y;
            refine (@wordToZ_word_case_dep_binop wop P _);
            intros logsz x y; intros
       | _
         => move y at top;
            revert dependent logsz; intros logsz y;
            pattern (wordToZ y), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x y));
            let P := lazymatch goal with |- ?P _ _ => P end in
            let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
            revert logsz y;
            refine (@wordToZ_word_case_dep_11op _ wop P x _);
            intros logsz y; intros
       end
  | [ |- context[wordToZ (word_case_dep (T:=?T) ?logsz (?wop 32) (?wop 64) (?wop 128) ?f ?x ?y ?z ?w)] ]
    => move w at top; move z at top; move y at top; move x at top;
       revert dependent logsz; intros logsz x y z w;
       pattern (wordToZ x), (wordToZ y), (wordToZ z), (wordToZ w), (wordToZ (word_case_dep (T:=T) logsz (wop 32) (wop 64) (wop 128) f x y z w));
       let P := lazymatch goal with |- ?P _ _ _ _ _ => P end in
       let P := lazymatch (eval pattern logsz in P) with ?P _ => P end in
       revert logsz x y z w;
       refine (@wordToZ_word_case_dep_quadop wop P _);
       intros logsz x y z w; intros
  end.
Ltac fixed_size_op_to_word :=
  repeat autounfold with fixed_size_constants in *;
  syntactic_fixed_size_op_to_word.

Lemma wordToZ_gen_range {sz} w : (0 <= @wordToZ_gen sz w < 2^Z.of_nat sz)%Z.
Proof. apply WordNZ_range; reflexivity. Qed.

Lemma wordToZ_range {logsz} w : (0 <= @wordToZ logsz w < 2^Z.of_nat (2^logsz))%Z.
Proof.
  generalize (@wordToZ_gen_range (2^logsz)); wordToZ_word_case_dep_t.
Qed.

Section log_Updates.
  Local Notation bound n lower value upper := (
       (0 <= lower)%Z
    /\ (lower <= @wordToZ n value)%Z
    /\ (@wordToZ n value <= upper)%Z
    /\ (Z.log2 upper < Z.of_nat (2^n))%Z).

  Definition valid_log_update n lowerF valueF upperF : Prop :=
    forall lower0 value0 upper0
          lower1 value1 upper1,

       bound n lower0 value0 upper0
    -> bound n lower1 value1 upper1
    -> (0 <= lowerF lower0 upper0 lower1 upper1)%Z
    -> (Z.log2 (upperF lower0 upper0 lower1 upper1) < Z.of_nat (2^n))%Z
    -> bound n (lowerF lower0 upper0 lower1 upper1)
                (valueF value0 value1)
                (upperF lower0 upper0 lower1 upper1).

  Lemma word_case_dep_valid_log_update f g wop
    : (forall n,
          WordUtil.valid_update
            n
            f
            (wop n)
            g)
      -> forall n,
          valid_log_update
            n
            f
            (word_case_dep
               (T:=fun _ W => W -> W -> W)
               n (wop 32) (wop 64) (wop 128)
               (fun k : nat => wop (2 ^ k)))
            g.
  Proof.
    intros H n; specialize (H (2^n)%nat).
    unfold valid_log_update; intros; fixed_size_op_to_word; unfold wordToZ_gen; auto.
  Qed.

  Lemma wadd_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => l0 + l1)%Z
        (@wadd n)
        (fun l0 u0 l1 u1 => u0 + u1)%Z.
  Proof. apply word_case_dep_valid_log_update, add_valid_update. Qed.

  Lemma wsub_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => l0 - u1)%Z
        (@wsub n)
        (fun l0 u0 l1 u1 => u0 - l1)%Z.
  Proof. apply word_case_dep_valid_log_update, sub_valid_update. Qed.

  Lemma wmul_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => l0 * l1)%Z
        (@wmul n)
        (fun l0 u0 l1 u1 => u0 * u1)%Z.
  Proof. apply word_case_dep_valid_log_update, mul_valid_update. Qed.

  Lemma wland_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => 0)%Z
        (@wland n)
        (fun l0 u0 l1 u1 => Z.min u0 u1)%Z.
  Proof. apply word_case_dep_valid_log_update, land_valid_update. Qed.

  Lemma wlor_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => Z.max l0 l1)%Z
        (@wlor n)
        (fun l0 u0 l1 u1 => 2^(Z.max (Z.log2_up (u0+1)) (Z.log2_up (u1+1))) - 1)%Z.
  Proof. apply word_case_dep_valid_log_update, lor_valid_update. Qed.

  Lemma wshr_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => Z.shiftr l0 u1)%Z
        (@wshr n)
        (fun l0 u0 l1 u1 => Z.shiftr u0 l1)%Z.
  Proof. apply word_case_dep_valid_log_update, shr_valid_update. Qed.

  Lemma wshl_valid_log_update: forall n,
    valid_log_update n
        (fun l0 u0 l1 u1 => Z.shiftl l0 l1)%Z
        (@wshl n)
        (fun l0 u0 l1 u1 => Z.shiftl u0 u1)%Z.
  Proof. apply word_case_dep_valid_log_update, shl_valid_update. Qed.
End log_Updates.

Lemma lt_log_helper (v : Z) (n : nat)
  : (v < 2^2^Z.of_nat n)%Z <-> (Z.log2 v < Z.of_nat (2^n))%Z.
Proof.
  rewrite Z.log2_lt_pow2_alt, Z.pow_Zpow by auto with zarith.
  reflexivity.
Qed.

Section Updates.
  Local Notation bound n lower value upper := (
       (0 <= lower)%Z
    /\ (lower <= @wordToZ n value)%Z
    /\ (@wordToZ n value <= upper)%Z
    /\ (upper < 2^2^Z.of_nat n)%Z).

  Definition valid_update n lowerF valueF upperF : Prop :=
    forall lower0 value0 upper0
           lower1 value1 upper1,
      bound n lower0 value0 upper0
      -> bound n lower1 value1 upper1
      -> (0 <= lowerF lower0 upper0 lower1 upper1)%Z
      -> (upperF lower0 upper0 lower1 upper1 < 2^2^Z.of_nat n)%Z
      -> bound n (lowerF lower0 upper0 lower1 upper1)
               (valueF value0 value1)
               (upperF lower0 upper0 lower1 upper1).

  Local Ltac t lem :=
    let H := fresh in
    pose proof lem as H;
    repeat (let x := fresh in intro x; specialize (H x));
    rewrite !lt_log_helper; assumption.

  Lemma word_case_dep_valid_update f g wop
    : (forall n,
          WordUtil.valid_update
            n
            f
            (wop n)
            g)
      -> forall n,
          valid_update
            n
            f
            (word_case_dep
               (T:=fun _ W => W -> W -> W)
               n (wop 32) (wop 64) (wop 128)
               (fun k : nat => wop (2 ^ k)))
            g.
  Proof. t (@word_case_dep_valid_log_update f g wop). Qed.

  Lemma wadd_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 + l1)%Z
        (@wadd n)
        (fun l0 u0 l1 u1 => u0 + u1)%Z.
  Proof. t (@wadd_valid_log_update). Qed.

  Lemma wsub_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 - u1)%Z
        (@wsub n)
        (fun l0 u0 l1 u1 => u0 - l1)%Z.
  Proof. t (@wsub_valid_log_update). Qed.

  Lemma wmul_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 * l1)%Z
        (@wmul n)
        (fun l0 u0 l1 u1 => u0 * u1)%Z.
  Proof. t (@wmul_valid_log_update). Qed.

  Lemma wland_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => 0)%Z
        (@wland n)
        (fun l0 u0 l1 u1 => Z.min u0 u1)%Z.
  Proof. t (@wland_valid_log_update). Qed.

  Lemma wlor_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.max l0 l1)%Z
        (@wlor n)
        (fun l0 u0 l1 u1 => 2^(Z.max (Z.log2_up (u0+1)) (Z.log2_up (u1+1))) - 1)%Z.
  Proof. t (@wlor_valid_log_update). Qed.

  Lemma wshr_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.shiftr l0 u1)%Z
        (@wshr n)
        (fun l0 u0 l1 u1 => Z.shiftr u0 l1)%Z.
  Proof. t (@wshr_valid_log_update). Qed.

  Lemma wshl_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.shiftl l0 l1)%Z
        (@wshl n)
        (fun l0 u0 l1 u1 => Z.shiftl u0 u1)%Z.
  Proof. t (@wshl_valid_log_update). Qed.
End Updates.

Section pull_ZToWord.
  Local Ltac t0 :=
    intros;
    etransitivity; [ symmetry; apply ZToWord_wordToZ | ]; fixed_size_op_to_word; unfold wordToZ_gen, wordBin;
    apply f_equal.
  Local Ltac t1 lem :=
    let solver := solve [ apply Npow2_Zlog2; autorewrite with push_Zof_N; assumption
                        | apply N2Z.inj_ge; unfold wordToZ_gen in *; omega
                        | apply N2Z.inj_lt; rewrite Npow2_N; autorewrite with push_Zof_N push_Zof_nat; assumption ] in
    first [ rewrite <- lem by solver | rewrite -> lem by solver ].
  Local Ltac t2 :=
    autorewrite with push_Zof_N; unfold wordToZ_gen in *;
    try first [ reflexivity
              | apply Z.max_case_strong; omega ].

  Local Ltac t lem :=
    t0; t1 lem; solve [ t2 ].

  Local Notation pull_ZToWordT_2op wop zop
    := (forall {logsz} (x y : wordT logsz),
           (zop (wordToZ x) (wordToZ y) < 2^2^Z.of_nat logsz)%Z
           -> wop logsz x y = ZToWord (zop (wordToZ x) (wordToZ y)))
         (only parsing).
  Local Notation pull_ZToWordT_2op' wop zop
    := (forall {logsz} (x y : wordT logsz),
           (0 <= zop (wordToZ x) (wordToZ y))%Z
           -> wop logsz x y = ZToWord (zop (wordToZ x) (wordToZ y)))
         (only parsing).

  Lemma wadd_def_ZToWord : pull_ZToWordT_2op (@wadd) (@Z.add).
  Proof. t (@wordize_plus). Qed.
  Lemma wsub_def_ZToWord : pull_ZToWordT_2op' (@wsub) (@Z.sub).
  Proof. t (@wordize_minus). Qed.
  Lemma wmul_def_ZToWord : pull_ZToWordT_2op (@wmul) (@Z.mul).
  Proof. t (@wordize_mult). Qed.
  Lemma wland_def_ZToWord : pull_ZToWordT_2op (@wland) (@Z.land).
  Proof. t (@wordize_and). Qed.
  Lemma wlor_def_ZToWord : pull_ZToWordT_2op (@wlor) (@Z.lor).
  Proof. t (@wordize_or). Qed.
  Lemma wshl_def_ZToWord : pull_ZToWordT_2op (@wshl) (@Z.shiftl).
  Proof. t (@wordToN_NToWord_idempotent). Qed.
  Lemma wshr_def_ZToWord : pull_ZToWordT_2op (@wshr) (@Z.shiftr).
  Proof. t (@wordToN_NToWord_idempotent). Qed.
End pull_ZToWord.
Section pull_ZToWord_log.
  Local Ltac t lem :=
    let H := fresh in
    pose proof lem as H;
    repeat (let x := fresh in intro x; specialize (H x));
    rewrite <- !lt_log_helper; assumption.

  Local Notation pull_ZToWordT_log_2op wop zop
    := (forall {logsz} (x y : wordT logsz),
           (Z.log2 (zop (wordToZ x) (wordToZ y)) < Z.of_nat (2^logsz))%Z
           -> wop logsz x y = ZToWord (zop (wordToZ x) (wordToZ y)))
         (only parsing).
  Lemma wadd_def_ZToWord_log : pull_ZToWordT_log_2op (@wadd) (@Z.add).
  Proof. t (@wadd_def_ZToWord). Qed.
  Lemma wmul_def_ZToWord_log : pull_ZToWordT_log_2op (@wmul) (@Z.mul).
  Proof. t (@wmul_def_ZToWord). Qed.
  Lemma wland_def_ZToWord_log : pull_ZToWordT_log_2op (@wland) (@Z.land).
  Proof. t (@wland_def_ZToWord). Qed.
  Lemma wlor_def_ZToWord_log : pull_ZToWordT_log_2op (@wlor) (@Z.lor).
  Proof. t (@wlor_def_ZToWord). Qed.
  Lemma wshl_def_ZToWord_log : pull_ZToWordT_log_2op (@wshl) (@Z.shiftl).
  Proof. t (@wshl_def_ZToWord). Qed.
  Lemma wshr_def_ZToWord_log : pull_ZToWordT_log_2op (@wshr) (@Z.shiftr).
  Proof. t (@wshr_def_ZToWord). Qed.
End pull_ZToWord_log.
Hint Rewrite wadd_def_ZToWord wsub_def_ZToWord wmul_def_ZToWord wland_def_ZToWord wlor_def_ZToWord wshl_def_ZToWord wshr_def_ZToWord : pull_ZToWord.
Hint Rewrite <- wadd_def_ZToWord wsub_def_ZToWord wmul_def_ZToWord wland_def_ZToWord wlor_def_ZToWord wshl_def_ZToWord wshr_def_ZToWord : push_ZToWord.
Hint Rewrite wadd_def_ZToWord_log wsub_def_ZToWord wmul_def_ZToWord_log wland_def_ZToWord_log wlor_def_ZToWord_log wshl_def_ZToWord_log wshr_def_ZToWord_log : pull_ZToWord_log.
Hint Rewrite <- wadd_def_ZToWord_log wsub_def_ZToWord wmul_def_ZToWord_log wland_def_ZToWord_log wlor_def_ZToWord_log wshl_def_ZToWord_log wshr_def_ZToWord_log : push_ZToWord_log.


Require Import ModelProperties.
Require Import AuxiliaryLemmas.

Section readIsSecure.

Lemma ReadPSS :
 forall (s t : SFSstate) (u : SUBJECT),
 SecureState s -> TransFunc u s Read t -> SecureState t.
OpDontChangeStPSS.
Qed.

Lemma ReadPSP :
 forall (s t : SFSstate) (u : SUBJECT),
 StarProperty s -> TransFunc u s Read t -> StarProperty t.
OpDontChangeStPSP.
Qed.

Lemma ReadPCP : forall s t : SFSstate, PreservesControlProp s Read t.
intros; unfold PreservesControlProp in |- *; intros Sub TF; inversion TF;
 unfold ControlProperty in |- *.
split.
intros.
split.
intro.
absurd (DACCtrlAttrHaveChanged t t o0); auto.

intro; absurd (MACObjCtrlAttrHaveChanged t t o0); auto.

intros; absurd (MACSubCtrlAttrHaveChanged t t u0); auto.

Qed.

End readIsSecure.

Hint Resolve ReadPSS ReadPSP ReadPCP.


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

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

Print Assumptions add.


(** printing × $\times$ #×# *)
(** printing :> $:$ #:># *)
(** printing ≡ $\equiv$ #≡# *)
(** printing [*] $*$ #*# *)
(** printing ∧ $\wedge$ #∧# *)
(** printing ∀ $\forall$ #∀# *)
(** printing → $\rightarrow$ #→# *)
(** printing ∃ $\exists$ #∃# *)
(** printing ≤ $\le$ #≤# *)
(** printing θ $\theta$ #θ# *)
(** printing eeev $\epsilon_v$ #∊ᵥ# *)
(** printing eeew $\epsilon_w$ #∊w# *)
(** printing tm $t_m$ #tm# *)
(** printing IR $\mathbb{R}$ #IR# *)
(** printing CR $\mathbb{R}$ #CR# *)
(** printing tr $t_r$ #tr# *)
(** remove printing * *)

(** printing ' $ $ #'# *)

Require Import Vector.
Require Export Coq.Program.Tactics.
Require Export LibTactics.
Require Import MathClasses.interfaces.canonical_names.
Require Import MCInstances.
Require Import ackermannSteering.
Require Import MCMisc.tactics.
Require Import CartIR.
Require Import ackermannSteering.
Require Import fastReals.interface.
Require Import fastReals.misc.
Require Import geometry2D.
Require Import geometry2DProps.
Require Import ackermannSteeringProp.
Require Import IRMisc.LegacyIRRing.
Require Import errorBounds.
Require Import MCMisc.rings.
Require Import atomicMoves.
Require Import MathClasses.interfaces.orders.
Require Import MathClasses.theory.setoids.
Set Implicit Arguments.

Set Suggest Proof Using.

    Ltac dimp H :=
    lapply H;[clear H; intro H|].

Local Opaque CSine.
Local Opaque CCos.
Local Opaque Sine.
Local Opaque Cosine.
Local Opaque Sin.
Local Opaque Cos.

Local Notation minxy := (lstart).
Local Notation maxxy := (lend).
Local Notation  "∫" := Cintegral.

Section AtomicMoveExec.

  Context  {maxTurnCurvature : Qpos}
   (acs : AckermannCar maxTurnCurvature).
  Variable am : AtomicMove IR.
  Variable tstart : Time.
  Variable tend : Time.

(* check that there we dont redefine the concepts in atomicMoves.v *)

  Set Implicit Arguments.

    Variable tcErr : IR.
    Variable distErr : IR.

  (** This defines what it means for the car's controls to
    realistically follow the atomic move [am] during time [tstart] to [tend] *)
    Record CarExecutesAtomicMoveDuring (p: tstart < tend) : Type :=
    {
      am_tdrive : Time;

      (**strict inequalities prevents impossilities like covering non-zero distance in 0 time.
        Note that [linVel] and [turnCurvature] evolve continuously.
       *)
      am_timeInc : (tstart < am_tdrive < tend);

    (** From time [tsteer] to [drive], the steerring wheel rotates to attain a configuration
      with turn curvature [tc]. The brakes are firmly placed pressed.*)
      am_steeringControls : forall (t:Time), (tstart ≤ t ≤ am_tdrive)
            -> {linVel acs} t = 0;

    (** From time [tdrive] to [tend], the steering wheel is held NEARLY fixed*)
      am_driveControls :  steeringAlmostFixed acs am_tdrive tend (am_tc am) tcErr;

      am_driveDistance :
        let driveIb := (@mkIntBnd _ tstart tend (timeLtWeaken p)) in
           AbsSmall distErr ((am_distance am) - (∫ driveIb (linVel acs)))
    }.

  Hypothesis pr : tstart < tend.

  (** Now, we assume that the car executes the atomic move [am] from [tstart] to [tend],
    and characterize the position and orientation at [tend], in terms of their values at [tstart]. *)
  Hypothesis amc : CarExecutesAtomicMoveDuring pr.

  Local Notation tc := (am_tc am).
  Local Notation distance := (am_distance am).
  Local Notation tdrive := (am_tdrive amc).

  Lemma am_timeIncWeaken : (tstart ≤ tdrive ≤ tend).
  Proof using Type.
    pose proof (am_timeInc amc).
    split; apply timeLtWeaken; tauto.
  Qed.

  Local Notation timeInc := am_timeIncWeaken.
  Ltac timeReasoning :=
    autounfold with IRMC; unfold Le_instance_Time;
      destruct timeInc; eauto 2 with CoRN; fail.

  Lemma am_timeStartEnd : (tstart  ≤ tend).
  Proof using All.
    pose proof (am_timeIncWeaken).
    repnd.  timeReasoning.
  Qed.

(*
   Lemma am_driveDistanceFull :
      let driveIb := (@mkIntBnd _ tstart tend am_timeStartEnd) in
          (am_distance am) = ∫ driveIb (linVel acs).
   Proof using Type.
    simpl.
    pose proof (am_steeringControls amc) as steeringControls.
    rewrite <- CintegralSplitTrivialL with (m:=tdrive) (pr:= proj2 am_timeIncWeaken);
    [ | apply am_timeIncWeaken | ].
    Focus 2.
      intros x Hb. simpl. destruct Hb as [Hbl Hbr].
      simpl in Hbl, Hbr. apply steeringControls.
      split; timeReasoning; fail.
    rewrite (am_driveDistance).
    apply Cintegral_wd;[| reflexivity].
    simpl. split;
    reflexivity.
  Qed.
*)

  Local Notation θs := ({theta acs} tstart).
  Local Notation Xs := ({X (position acs)} tstart).
  Local Notation Ys := ({Y (position acs)} tstart).
  Local Notation Ps := (posAtTime acs tstart).

  Lemma rigidStateNoChange : forall t:Time,
    tstart ≤ t ≤ tdrive
    -> (rigidStateAtTime acs t) = (rigidStateAtTime acs tstart).
  Proof using Type.
    apply LV0. destruct amc.
    simpl in *.
    tauto.
  Qed.

  Hypothesis nsc : noSignChangeDuring (linVel acs) tstart tend.
  (** 2 cases, based on whether the steering wheel is perfectly straight before driving.
    To avoid a  divide-by-0, the integration has to be done differently in these cases. *)
  Section TCNZ.
  Hypothesis (tcNZ : amTurn am).
    Let turnRadius  :IR  := (f_rcpcl tc tcNZ).

  Let adist := (|am_distance am|) + (|distErr|).

Require Import MathClasses.interfaces.functors.

(* finish and move *)
Global Instance proper_pnorm:
  Proper (equiv ==> equiv) (@pNorm IR _).
Proof.
  unfold pNorm.
  eapply sfmap_proper.
  intros ? ? H. setoid_rewrite H. reflexivity.
Print SFunctor.
Admitted.

  Lemma turnErrMono e d1 d2 r:
  (|d1|) ≤ (|d2|)
  -> turnErr e d1 r ≤ turnErr e d2 r.
  Proof.
    intro H1.
    split; [split|]; simpl;
    try rewrite (MultShuffle3r _ d1);
    try rewrite (MultShuffle3r _ d2);
    setoid_rewrite AbsIR_resp_mult; apply mult_resp_leEq_lft;
    eauto using AbsIR_nonneg.
  Qed.

  Lemma AtomicMoveTurn :
  let rs:= rigidStateAtTime acs in
    pNorm (rs tend -
            (turnRigidStateAtθ (rs tstart) turnRadius ({theta acs} tend)))
    ≤ turnErr tcErr adist turnRadius.
  Proof using pr nsc amc.
    simpl.
    setoid_rewrite <- (rigidStateNoChange tdrive);
      [ | split; eauto with relations; apply am_timeIncWeaken].
    eapply transitivity;
     [apply fixedSteeeringTurn with (tcErr0:=tcErr) (timeInc := proj2 am_timeIncWeaken);
      apply am_driveControls |].
    apply turnErrMono.
    eapply noSignChangeDuringWeaken with (a2:=tdrive) (b2:=tend)in nsc; auto;
    [| eauto with relations; apply am_timeIncWeaken].
    rewrite noChangeAbs by assumption.
    unfold norm, NormSpace_instance_IR.
    rewrite AbsIR_eq_x by apply AbsIR_nonneg.
    pose proof (am_driveDistance amc) as amd. simpl in amd.
    apply AbsSmall_imp_AbsIR in amd.
    subst adist.
    setoid_rewrite AbsIR_eq_x at 2;[| apply plus_resp_nonneg; apply AbsIR_nonneg].
    rewrite plus_comm.
    apply shift_leEq_plus.
    setoid_rewrite AbsIR_minus in amd.
    eapply transitivity; [| apply leEq_AbsIR].
    rewrite <- CintegralSplitTrivialL with (m:=tdrive) (pr:= proj2 am_timeIncWeaken) in amd;
    [ | apply am_timeIncWeaken | apply am_steeringControls].
    eapply transitivity; [| apply amd].
    apply triangle_IR_minus'.
  Qed.

  End TCNZ.

End AtomicMoveExec.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus (plus lv0 (mult lv1 lv0)) lv1)) (plus (mult lv1 (Succ lv0)) (Succ lv0))).
Admitted.
QuickChick conj20synthconj3.


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

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

Print Assumptions mul.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C P T : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ O C /\ (col_ A B O /\ (col_ A B C /\ (col_ O C T /\ col_ O T P))))))) -> col_ O C A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import CoqPropInLogicNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Sound_Flat_Corable.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {iffpL: IffLanguage L}
        {coq_prop_L: CoqPropLanguage L}
        {sepconL: SepconLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        (M: Kmodel)
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {dSA: DownwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {kminSM: KripkeMinimumSemantics L MD M SM}
        {andpSM: KripkeAndSemantics L MD M SM}
        {iffpSM: KripkeIffSemantics L MD M SM}
        {coq_prop_SM : CoqPropSemantics L MD M SM}
        {fsepconSM: FlatSemantics.SepconSemantics L MD M SM}.

Lemma sound_corable_preserved:
  forall x y: expr,
    (forall m, KRIPKE: M, m |= x <--> y) ->
    sem_corable (Kdenotation M x) ->
    sem_corable (Kdenotation M y).
Proof.
  unfold Kdenotation.
  intros.
  pose proof valid_iffp _ _ H; clear H.
  unfold satisfies in H1.
  constructor.
  + intros ? ? ?.
    rewrite <- !H1.
    apply (local2global _ H0).
  + intros ? ? ?.
    rewrite <- !H1.
    intros HA HB.
    destruct (global2local _ H0 _ _ _ HA HB) as [w1' [w2' ?H]].
    exists w1', w2'.
    rewrite <- !H1.
    auto.
Qed.

Lemma sound_corable_andp_sepcon1: forall x y z,
  sem_corable (Kdenotation M x) ->
  forall m, KRIPKE: M, m |= (x && y) * z <--> x && (y * z).
Proof.
  intros.
  rewrite sat_iffp.
  intros ? _; clear m; split.
  + intros.
    rewrite sat_andp, sat_sepcon.
    rewrite sat_sepcon in H0.
    destruct H0 as [m1 [m2 [? [? ?]]]].
    rewrite sat_andp in H1.
    destruct H1.
    pose proof local2global _ H _ _ _ H0 H1.
    split; auto.
    exists m1, m2; auto.
  + intros.
    rewrite sat_andp, sat_sepcon in H0.
    destruct H0 as [? [m1 [m2 [? [? ?]]]]].
    pose proof global2local _ H _ _ _ H1 H0 as [m1' [m2' [? [? [? ?]]]]].
    rewrite sat_sepcon; exists m1', m2'.
    split; auto.
    rewrite sat_andp.
    split; [split |]; eapply sat_mono; eauto.
Qed.

Lemma sound_corable_coq_prop: forall P,
  sem_corable (Kdenotation M (!! P)).
Proof.
  intros.
  unfold Kdenotation.
  constructor.
  + change
      (forall w1 w2 w3 : Kworlds M,
         join w1 w2 w3 -> KRIPKE: M, w1 |= !! P -> KRIPKE: M, w3 |= !! P).
    intros.
    rewrite sat_coq_prop in H0 |- *.
    auto.
  + change
      (forall w1 w2 w3 : Kworlds M,
         join w1 w2 w3 ->
         KRIPKE: M, w3 |= !! P ->
         exists w1' w2' : Kworlds M,
           join w1' w2' w3 /\ w1 <= w1' /\ w2 <= w2' /\ KRIPKE: M, w1 |= !! P).
    intros.
    exists w1, w2.
    split; auto.
    split; [reflexivity |].
    split; [reflexivity |].
    rewrite sat_coq_prop in H0 |- *.
    auto.
Qed.

End Sound_Flat_Corable.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * DecimalZ

    Proofs that conversions between decimal numbers and [Z]
    are bijections. *)

Require Import Decimal DecimalFacts DecimalPos DecimalN ZArith.

Lemma of_to (z:Z) : Z.of_int (Z.to_int z) = z.
Proof.
 destruct z; simpl.
 - trivial.
 - unfold Z.of_uint. rewrite DecimalPos.Unsigned.of_to. now destruct p.
 - unfold Z.of_uint. rewrite DecimalPos.Unsigned.of_to. destruct p; auto.
Qed.

Lemma to_of (d:int) : Z.to_int (Z.of_int d) = norm d.
Proof.
 destruct d; simpl; unfold Z.to_int, Z.of_uint.
 - rewrite <- (DecimalN.Unsigned.to_of d). unfold N.of_uint.
   now destruct (Pos.of_uint d).
 - destruct (Pos.of_uint d) eqn:Hd; simpl; f_equal.
   + generalize (DecimalPos.Unsigned.to_of d). rewrite Hd. simpl.
     intros H. symmetry in H. apply unorm_0 in H. now rewrite H.
   + assert (Hp := DecimalPos.Unsigned.to_of d). rewrite Hd in Hp. simpl in *.
     rewrite Hp. unfold unorm in *.
     destruct (nzhead d); trivial.
     generalize (DecimalPos.Unsigned.of_to p). now rewrite Hp.
Qed.

(** Some consequences *)

Lemma to_int_inj n n' : Z.to_int n = Z.to_int n' -> n = n'.
Proof.
 intro EQ.
 now rewrite <- (of_to n), <- (of_to n'), EQ.
Qed.

Lemma to_int_surj d : exists n, Z.to_int n = norm d.
Proof.
 exists (Z.of_int d). apply to_of.
Qed.

Lemma of_int_norm d : Z.of_int (norm d) = Z.of_int d.
Proof.
 unfold Z.of_int, Z.of_uint.
 destruct d.
 - simpl. now rewrite DecimalPos.Unsigned.of_uint_norm.
 - simpl. destruct (nzhead d) eqn:H;
   [ induction d; simpl; auto; discriminate |
     destruct (nzhead_nonzero _ _ H) | .. ];
   f_equal; f_equal; apply DecimalPos.Unsigned.of_iff;
   unfold unorm; now rewrite H.
Qed.

Lemma of_inj d d' :
 Z.of_int d = Z.of_int d' -> norm d = norm d'.
Proof.
 intros. rewrite <- !to_of. now f_equal.
Qed.

Lemma of_iff d d' : Z.of_int d = Z.of_int d' <-> norm d = norm d'.
Proof.
 split. apply of_inj. intros E. rewrite <- of_int_norm, E.
 apply of_int_norm.
Qed.