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 X Y Z Zprime : Universe, ((wd_ O X /\ (wd_ O Z /\ (wd_ O Y /\ (wd_ Z O /\ (wd_ O Zprime /\ (wd_ Z Zprime /\ (col_ Z O Zprime /\ (col_ O Y Zprime /\ col_ Z O Zprime)))))))) -> col_ Y O Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 conj20eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv2 (plus lv1 lv0))).
Admitted.
QuickChick conj20eqsynthconj2.


Require Export prosa.model.task.concept.

(** * The Sporadic Task Model *)

(** In the following, we define the arrival process commonly known as the
    sporadic task model, where jobs may arrive at any time provided any two
    jobs of a task are separated by at least the minimum inter-arrival time (or
    period) of the task. *)

(** ** Task Parameter for the Sporadic Task Model *)

(** Under the sporadic task model, each task is characterized by its minimum
    inter-arrival time, which we denote as [task_min_inter_arrival_time]. *)

Class SporadicModel (Task : TaskType) :=
  task_min_inter_arrival_time : Task -> duration.

(** ** Model Validity *)

(** Next, we define the semantics of the sporadic task model. *)
Section ValidSporadicTaskModel.
  (** Consider any type of sporadic tasks. *)
  Context {Task : TaskType} `{SporadicModel Task}.

  (** A valid sporadic task should have a non-zero minimum inter-arrival
      time. *)
  Definition valid_task_min_inter_arrival_time tsk :=
    task_min_inter_arrival_time tsk > 0.

  (** Further, in the context of a set of such tasks, ... *)
  Variable ts : TaskSet Task.

  (** ... every task in the set should have a valid inter-arrival time. *)
  Definition valid_taskset_inter_arrival_times :=
    forall tsk : Task,
      tsk \in ts -> valid_task_min_inter_arrival_time tsk.

  (** Next, consider any type of jobs stemming from these tasks ... *)
  Context {Job : JobType} `{JobTask Job Task} `{JobArrival Job}.

  (** ... and an arbitrary arrival sequence of such jobs. *)
  Variable arr_seq : arrival_sequence Job.

  (** We say that a task respects the sporadic task model if the arrivals of
      its jobs in the arrival sequence are appropriately spaced in time. *)
  Definition respects_sporadic_task_model (tsk : Task) :=
    forall (j j': Job),
      (** Given two different jobs j and j' ... *)
      j <> j' ->
      (** ...that belong to the arrival sequence... *)
      arrives_in arr_seq j ->
      arrives_in arr_seq j' ->
      (** ... and that stem from the given task, ... *)
      job_task j = tsk ->
      job_task j' = tsk ->
      (** ... if the arrival of j precedes the arrival of j' ...,  *)
      job_arrival j <= job_arrival j' ->
      (** then the arrival of j and the arrival of j' are separated by at least
          one period. *)
      job_arrival j' >= job_arrival j + task_min_inter_arrival_time tsk.

  (** Based on the above definition, we define the sporadic task model as
      follows. *)
  Definition taskset_respects_sporadic_task_model :=
    forall tsk, tsk \in ts -> respects_sporadic_task_model tsk.

End ValidSporadicTaskModel.


Require Import
  List NPeano
  QArith Qabs Qpossec Qsums Qround
  Qmetric ZArith
  CRArith CRsum (*AbstractIntegration*)
  util.Qgcd
  Program
  uneven_CRplus
  stdlib_omissions.P
  stdlib_omissions.Z
  stdlib_omissions.Q.

Open Scope uc_scope.

Set Automatic Introduction.

Hint Resolve Qpos_nonzero.
Hint Immediate Q.Qle_nat.
Hint Resolve Qmult_le_0_compat.
Hint Resolve QnonNeg.Qplus_nonneg.

Parameter (z:Z).

(* Zsqrt_plain_is_pos *)

(*
Lemma Zsqrt_r_nonneg (z: Z) (E: 0 <= z): (0 <= Zsqrt z)%Z.
Proof with auto.
  destruct Zsqrt; try easy.
  admit.
 subst. simpl. omega.
Qed.
*)

Require Import Coq.ZArith.Zsqrt_compat.

Open Scope Z_scope.

Definition Z_4th_root_floor (x: Z): (0 <= x)%Z ->
  {s: Z & {r: Z | x = Zpower s 4 + r /\ Zpower s 4 <= x < Zpower (s + 1) 4}}%Z.
Proof.
 intro E.
 destruct x.
   exists 0%Z.
   exists 0%Z.
   split. reflexivity.
   change (0 <= 0 < 1).
   omega.
  exists (projT1 (Zsqrt (projT1 (Zsqrt p (Zle_0_pos p))) (Zsqrt_plain_is_pos p E))).
  set (Zsqrt (projT1 (Zsqrt p (Zle_0_pos p))) (Zsqrt_plain_is_pos p E)).
  admit.
 exfalso. apply E. reflexivity.
Defined.

Definition Z_4th_root_floor_plain (z: Z): Z :=
  match z with
  | Zpos p => projT1 (Z_4th_root_floor p (Zle_0_pos p))
  | _ => 0%Z
  end.

Lemma Zle_uniq {x y: Z} (p q: Zle x y): p = q.
Admitted.

Goal forall z, Z_4th_root_floor_plain z = Zsqrt_plain (Zsqrt_plain z).
Proof.
 intros.
 unfold Zsqrt_plain.
 destruct z; try reflexivity.
 unfold Z_4th_root_floor_plain, Z_4th_root_floor.
 unfold projT1 at 1.
 generalize (Zsqrt_plain_is_pos). (* p (Zle_0_pos p)). *)
 unfold Zsqrt_plain.
 (*generalize (Zsqrt).*) (*p (Zle_0_pos p)).*)
 admit.
(*
 destruct s.
 simpl @projT1 at 1.
 destruct x.
   simpl. reflexivity. *)
admit.
admit.
(*
rewrite (Zle_uniq z (Zle_0_pos p)).
   intro.
  reflexivity.
 simpl. intro. exfalso. apply z. reflexivity.*)
Qed.

Definition Q_4th_root_floor_plain (q: Q): Z := Z_4th_root_floor_plain (Qceiling q).

Section definition.

  Context
    (f: Q_as_MetricSpace --> CR)
    (b: Q). (* bound for the absolute value of f's fourth derivative *)

  Section approx.

    Context (n : positive)(fr: Q) (w: Qpos) (e: Qpos).

    Definition N: positive := P_of_succ_nat (Zabs_nat (Q_4th_root_floor_plain ((w^5) / 2880 * b / e))).
      (* This Zabs is silly because we know the squaring thing only returns nonnegatives, but whatever. *)
      (* Also, a ceil variant would obviate need to take the successor, but I haven't defined ceil variants
       of the 4th root for Z/Q yet. *)

    Definition iw : Qpos := (w / N)%Qpos.
    Definition iw1 : Qpos := (w / n)%Qpos.
    Definition halfiw : Qpos := (w / ((2#1) * N))%Qpos.
    Definition halfiw1 : Qpos := (w / ((2#1) * n))%Qpos.

    Open Scope Q_scope.

    Definition simpson (fr: Q): CR :=
      (' (iw / 6) * (f fr + f (fr + halfiw)%Q * '4 + f (fr + iw)%Q))%CR.
    Definition simpson1 (fr: Q): CR :=
      (' (iw1) * (f fr + f (fr + halfiw1)%Q * '4 + f (fr + iw1)%Q))%CR.

    Definition approx: CR := CRsum_list (map (fun i: nat => simpson (fr + i * iw)) (N.enum (nat_of_P N))).
    Definition approx1 : CR :=
      CRsum_list (map (fun i: nat => simpson1 (fr + i * iw1)) (N.enum (nat_of_P n))).

  End approx.

  Lemma regular fr w: is_RegularFunction_noInf CR (approx fr w).
  Admitted.

  Definition simpson_integral fr w: CR := Cjoin (mkRegularFunction ('(0%Q))%CR (regular fr w)).

(*
  Global Instance integrate: Integral f := @integral_extended_to_nn_width f pre_result.
*)

End definition.

Require Import ARtrans.
Require Import Qdlog.
Require Import BigQ ARbigQ ARQ ARbigD.

Definition eps (n : positive) := (1 # (10^n))%Qpos.

Definition answer (n:positive) (r:CR) : Z :=
 let m := (10^n)%positive in
 let (a,b) := ((approximate r (1#m)%Qpos) * m)%Q in
 Zdiv a b.

(*Time Eval vm_compute in approximate (simpson_integral sin_uc 1 0 1) (1#100000)%Qpos.*)

Definition sum_pos `{Zero A, Plus A} (f : positive -> A) (n : positive) :=
  Pos.peano_rect (λ _, A) 0 (λ p x, f p + x) n.

Definition sum_pos_iter `{Zero A, Plus A} (f : positive -> A) (n : positive) : A :=
match n with
| xH => 0
| _ =>
  let z :=
    Pos.iter
      (Pos.pred n)
      (λ y : positive * A, let (p, x) := y in ((Pos.succ p), (f p + x)))
      (1%positive, 0) in
    snd z
end.

Section ARsum.

Context `{AppRationals AQ}.

Definition ARsum_list_raw (l : list AR) (e : QposInf) : AQ :=
fold_left (@plus AQ _)
match l with
| nil => nil
| cons h t =>
  let e' := QposInf_mult (1#(Pos.of_nat (length t)))%Qpos e in
   (map (fun x => approximate x e') l)
end
0.

Definition ARsum_raw (f : positive -> AR) (n : positive) (eps : QposInf) : AQ :=
let e := (eps * (1 # Pos.pred n)%Qpos)%QposInf in
  sum_pos_iter (λ p, approximate (f p) e) n.

Lemma ARsum_list_prf : forall l, @is_RegularFunction AQ_as_MetricSpace (ARsum_list_raw l).
Admitted.

Lemma ARsum_prf : forall f n, @is_RegularFunction AQ_as_MetricSpace (ARsum_raw f n).
Admitted.

Definition ARsum_list (l : list AR) : AR := Build_RegularFunction (ARsum_list_prf l).

Definition ARsum (f : positive -> AR) (n : positive) : AR := Build_RegularFunction (ARsum_prf f n).

End ARsum.

Section ARInt.

Context
  `{AppRationals AQ}
  (f : AR -> AR)
  (B : Q) (* bound for the absolute value of f's fourth derivative *)
  (a b : AR) (w : AQ).

Let width : AR := b - a.

Section ARIntN.

Variable n : positive.

Section ARIntEps.

Variable eps : Qpos.

Let hl' : AR := width * AQinv ('(Zpos n~0)). (* hl' = width / (2 * n) *)
Let eps' : Qpos := eps * (1 # (6 * n)%positive)%Qpos.
Let h (p : positive) := approximate (f (a + ARscale ('(Zpos p)) hl')) eps'.

Definition ARsimpson_sum_raw : AQ :=
  4 * (sum_pos_iter (λ p, h (Pos.pred_double p)) (Pos.succ n)) +
  2 * (sum_pos_iter (λ p, h p~0) n) +
  (approximate (f a) eps' + approximate (f b) eps').

End ARIntEps.

Lemma ARsimson_sum_regular : is_RegularFunction_noInf AQ_as_MetricSpace ARsimpson_sum_raw.
Admitted.

Definition ARsimpson_sum : AR := mkRegularFunction 0 ARsimson_sum_regular.

End ARIntN.

Section ARIntEps1.

Variable eps : Qpos.

Definition num_intervals : nat := S (Z.to_nat (Q_4th_root_floor_plain ('w^5 / 2880 * B / eps))).
(* To be optimized *)
Definition num_intervals1 : positive :=
  P_of_succ_nat (Zabs_nat (Q_4th_root_floor_plain (('w^5) / 2880 * B / eps))).

Definition num_intervals2 : positive :=
  let w : Q := 'approximate width (1#1000)%Qpos + (1#1000) in
    Pos.succ (Z.to_pos (Q_4th_root_floor_plain (w^5 / 2880 * B / eps))).

(* half-length *)
Let hl : AR := width * AQinv ('(Zpos (num_intervals2~0)%positive)).

Let f' (n : nat) := f(a + '(n : Z) * 'w * AQinv ('(2 * (num_intervals : Z))%Z)).
Let g (p : positive) := f(a + ARscale ('(Zpos p)) hl).
(*Let h (p : positive) (e : Qpos) := approximate (f (a + ARscale ('(Zpos p)) hl)) e.*)

Definition ARsimpson_raw : AR :=
  (ARscale 4 (ARsum_list (map (fun i : nat => f' (2 * i + 1)) (N.enum (num_intervals - 0)))) +
   ARscale 2 (ARsum_list (map (fun i : nat => f' (2 * i + 2)) (N.enum (num_intervals - 1)))) +
   (f' 0 + f' (2 * num_intervals))) * 'w * AQinv ('(6 * (num_intervals : Z))%Z).

Definition ARsimpson1_raw : AR :=
  ((ARscale 4 (ARsum (λ p, g (Pos.pred_double p)) (Pos.succ num_intervals2))) +
   (ARscale 2 (ARsum (λ p, g p~0) num_intervals2)) +
   (f a + f b))
  * width * AQinv ('(6 * (num_intervals2 : Z))%Z).

(*Definition ARsimpson_sum_raw : AQ :=
  let e := eps * (1 # (6 * num_intervals2)%positive)%Qpos in
    4 * (sum_pos_iter (λ p, h (Pos.pred_double p) e) (Pos.succ num_intervals2)) +
    2 * (sum_pos_iter (λ p, h p~0 e) num_intervals2) +
    (approximate (f a) e + approximate (f b) e).*)

Definition ARsimpson2_raw : AR :=
  ARsimpson_sum num_intervals2 * (width * AQinv ('Zpos (6 * num_intervals2)%positive)).

End ARIntEps1.

Lemma ARsimson_regular : is_RegularFunction_noInf AR ARsimpson_raw.
Admitted.

Lemma ARsimson1_regular : is_RegularFunction_noInf AR ARsimpson1_raw.
Admitted.

Lemma ARsimson2_regular : is_RegularFunction_noInf AR ARsimpson2_raw.
Admitted.

Definition ARsimpson : AR := Cjoin (mkRegularFunction 0 ARsimson_regular).
Definition ARsimpson1 : AR := Cjoin (mkRegularFunction 0 ARsimson1_regular).
Definition ARsimpson2 : AR := Cjoin (mkRegularFunction 0 ARsimson2_regular).

End ARInt.

(*Time Compute approximate (ARexp (AQ := bigD) 4) (eps 2000)

Time Check approximate ((ARexp (AQ := bigD) 4) * '((10 ^ 1000)%positive : Z)) (1#1)%Qpos.*)

(*Compute N 3 1 (eps 20).
Compute num_intervals (AQ := bigD) 3 1 (eps 13).*)

(*Extraction "mult.ml" ARmult.*)

(*Time Compute approximate (simpson_integral (exp_bound_uc 2) 3 0 1) (eps 11).*)

(*
(* The following shows that in evaluating x * y up to eps, (approximate x
(eps / (2 * c))) where c is an approximation of y up to 1, is computed once
and not twice. We make y very large so that the approximation of x takes a
long time. Multiplcation takes less than twice the time of the approximation of x. *)

Definition int := (ARsimpson (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 3 0 1).
Definition e := '((10 ^ 12)%positive : Z) : ARbigD.

Time Compute approximate (int * e) (1#1)%Qpos.

Time Compute approximate int (eps 13).
*)

(* (ARexp x) calls ARexp_bounded on (Qceiling ('approximate x (1#1)%Qpos + (1#1))) and x.
If x = 1, then the approximation is 2. *)

Definition repeat {A : Type} (M : unit -> A) (n : positive) :=
  Pos.iter n (fun _ => (fun _ => tt) (M tt)) tt.

(*Definition M :=
  fun _ : unit =>
    approximate (ARexp_bounded (AQ := bigD) 2 1) (eps 12).*)

(*Compute num_intervals2 (AQ := bigD) 3 0 1 (eps 15).*)

(*Time Compute approximate (ARsimpson (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 3 0 1) (eps 14).
Time Compute approximate (ARsimpson1 (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 3 0 1) (eps 14).*)
(*Time Compute approximate (ARsimpson2 (AQ := Q) (ARexp_bounded 2) 3 0 1) (eps 9).
Time Compute approximate (ARsimpson_sum (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 0 1 1012) (eps 14).*)

Section Picard.

Context `{AppRationals AQ} (F : AR -> AR) (a b : AR).

Definition picard (f : AR -> AR) (x : AR) := b + ARsimpson2 (AQ := AQ) (λ t, F (f t)) 1 a x.

Definition picard_iter (n : nat) : AR -> AR := nat_iter n picard (λ _, b).

End Picard.

Definition d := approximate (picard_iter (AQ := bigD) (λ y, y) 0 1 6 1) (eps 1).

Extraction "simpson.ml" d.

Time Compute approximate (picard_iter (AQ := bigD) (λ y, y) 0 1 6 1) (eps 1).

(*Time Compute approximate (ARsimpson (AQ := bigD) ARexp 3 0 1) (eps 10).
Time Compute approximate (ARsimpson (AQ := bigD) ARarctan 1 0 1) (eps 1).
Time Compute approximate (ARsimpson (AQ := bigD) ARsqrt 3 0 1) (eps 12).
Timeout 30 Compute approximate (ARsimpson (AQ := bigD) ARexp 3 0 1) (eps 1).
Compute num_intervals (AQ := bigD) 3 1 (eps 0).*)

Section ARInt'.

Context
  `{AppRationals AQ}
  (f : AQ -> AR)
  (B : Q). (* bound for the absolute value of f's fourth derivative *)

Section ARapprox.

  Context (n : positive) (a : AQ) (w : AQ) (eps : Qpos).

  Definition N' : nat := Z.to_nat (1 + Zdiv (Qdlog2 ('w^5 / 2880 * B / eps))%Q 4).

  Definition iw' : AQ := w ≪ -(N' : Z).
  Definition iw1' : AQ := w ≪ -(n : Z).

  Definition simpson' (a' : AQ) : AR :=
    ('iw' * (f a' + f (a' + (iw' ≪ -1)) * '4 + f (a' + iw'))).
  Definition simpson1' (a' : AQ) : AR :=
    ('iw1' * (f a' + f (a' + (iw1' ≪ -1)) * '4 + f (a' + iw1'))).

  Definition approx' : AR :=
    ARsum_list (map (fun i : nat => simpson' (a + '(i : Z) * iw')) (N.enum (2^N'))).
  Definition approx1' : AR :=
    ARsum_list (map (fun i : nat => simpson1' (a + '(i : Z) * iw1')) (N.enum (nat_of_P (2^n)%positive))).

End ARapprox.

Lemma regular' a w : is_RegularFunction_noInf AR (approx' a w).
Admitted.

Definition simpson_integral' a w : AR := Cjoin (mkRegularFunction 0 (regular' a w)).

End ARInt'.

Time Compute approximate (simpson_integral' (AQ := bigD) AQexp 3 0 1) (eps 10).
Time Compute approximate (simpson_integral' (AQ := bigD) ARexp 3 0 1) (eps 10).

(*Eval compute in N' (AQ := bigD) 1 1 (eps 8).
Eval compute in N 1 1 (eps 8).*)

(*Time Check approximate (ARexp_bounded_uc (AQ := bigD) 2 1) (eps 20).
Time Check approximate (ARexp (AQ := bigD) 1) (eps 20).

Time Eval vm_compute in approximate (ARexp_bounded_uc (AQ := bigD) 2 1) (eps 20).
Time Eval vm_compute in approximate (ARexp (AQ := bigD) 1) (eps 20).*)

(*Time Check approximate (Cjoin_fun (Cmap_fun AQPrelengthSpace (ARexp_bounded_uc (AQ := bigD) 2) 1)) (eps 20).
Time Eval vm_compute in
  approximate (Cjoin_fun (Cmap_fun AQPrelengthSpace (ARexp_bounded_uc (AQ := bigD) 2) 1)) (eps 20).*)

Time Eval vm_compute in approximate (ARexp (AQ := bigD) 1) (eps 20).
Time Eval vm_compute in approximate (exp 1) (eps 20).
Time Eval vm_compute in approximate (exp_bound_uc 3 1) (eps 130).

Time Eval vm_compute in approximate (ARsin_uc (AQ := bigD) 1) (eps 20).
Time Eval vm_compute in approximate (sin_uc 1) (eps 20).

Time Eval vm_compute in approximate (sin_slow 1) (eps 50).
Time Eval vm_compute in approximate (ARsin (AQ := bigD) 1) (eps 50).

Require Import PowerSeries.

Time Eval vm_compute in
  approximate (ARsin (AQ := bigD) (ARsin (AQ := bigD) (ARsin (AQ := bigD) 1))) (eps 25).

Time Eval vm_compute in approximate (approx1 sin_uc 32 0 1) (eps 50).
Time Eval vm_compute in approximate (approx1' (AQ := bigD) ARsin_uc 5 0 1) (eps 50).

Time Eval vm_compute in
  (fun _ => tt) (map (fun _ => approximate (ARsin_uc (AQ := bigD) 1) (eps 10)) (N.enum 10)).
Time Eval vm_compute in
  (fun _ => tt) (map (fun _ => approximate (sin_uc 1) (eps 10)) (N.enum 10)).

Time Eval vm_compute in approximate (approx' (AQ := bigD) ARsin_uc 1 0 1 (eps 8)) (eps 8).

Time Eval vm_compute in approximate (simpson_integral sin_uc 1 0 1) (1#100000000)%Qpos.
Time Eval vm_compute in answer 8 (simpson_integral sin_uc 1 0 1).

(*Eval vm_compute in approximate (simpson' (AQ := bigD) ARsin_uc 1 1 (1#1)%Qpos 0) (1#1)%Qpos.*)

(*Eval vm_compute in (*cast _ Q*)
  (approximate (approx' (AQ := bigD) ARsin_uc 1 0 1 (1#10)%Qpos) (1#10)%Qpos).*)

Time Eval vm_compute in
  cast _ Q (approximate (simpson_integral' (AQ := bigD) ARsin_uc 1 0 1) (1#100000000)%Qpos).

Time Eval vm_compute in N.enum ((2 : nat)^(N' (AQ := bigD) 1 1 (1#10000000000)%Qpos)).


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

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

Print Assumptions sub.


Require Import MSetList MSets Structures.Orders Eqdep_dec.

Module BoolDec <: DecidableType.
    Definition U := bool.
    Definition eq_dec := Bool.bool_dec.
End BoolDec.

Module Type SetExtT.
  Include SWithLeibniz.
  Parameter Disjoint : t -> t -> Prop.
  Axiom Disjoint_spec : forall m m',  Disjoint m m' <-> forall k, ~ (In k m /\ In k m').
  Parameter set_extensionality :
    forall (X Y : t), (forall (x : elt), In x X <-> In x Y) -> X = Y.
  Parameter set_map : (elt -> elt) -> t -> t.
  Axiom set_map_spec : forall (f : elt -> elt) (X : t) (e : elt),
      In e X -> In (f e) (set_map f X).
  Axiom set_map_spec_1 : forall (f : elt -> elt) (X : t) (e e' : elt),
      In e X -> e' = f e -> In e' (set_map f X).
  Axiom set_map_iff : forall (f : elt -> elt) (X : t) e,
    In e (set_map f X) <-> exists e', e = f e' /\ In e' X.
  Axiom union_assoc :
    forall s s' s'' : t, (union (union s s') s'') = (union s (union s' s'')).
  Axiom union_comm : forall s s' : t, union s s' = union s' s.
  Axiom set_map_card : forall f s, cardinal (set_map f s) = cardinal s.
End SetExtT.

Module SetExt (E : UsualOrderedType) <: SetExtT.
  Module SLeib <: MSetList.OrderedTypeWithLeibniz.
  Include E.
  Lemma eq_leibniz : forall x y, eq x y -> x = y.
  Proof.
    intros x y Heq. auto.
  Qed.
  End SLeib.
  Module S := MSetList.MakeWithLeibniz SLeib.

  Include S.

  Module OP := OrdProperties S.
  Import OP.

  Module Dec := DecidableEqDep BoolDec.

  Lemma set_extensionality (X Y : t):
    (forall  (x : elt), In x X <-> In x Y) -> X = Y.
  Proof.
    intros Hin.
    destruct X as [xs sxs]. destruct Y as [ys sys].
    assert (Heq : xs = ys) by
        (apply eq_leibniz_list;
         apply OP.sort_equivlistA_eqlistA; try rewrite Raw.isok_iff; auto).
    subst. f_equal.
    (* NOTE: We can solve this goal without assuming proof irrelevance, because
       for types with decidable equality UIP in provable *)
    apply Dec.UIP.
  Qed.

  Definition set_map (f : elt -> elt) (X : t) : t :=
    fold (fun x Y => add (f x) Y) X empty.

  Lemma set_map_spec (f : elt -> elt) (X : t) : forall (e : elt),
    In e X -> In (f e) (set_map f X).
  Proof.
    (* NOTE: it is very convenient to use special induction principle for fold here *)
    apply P.fold_rec with (P:=fun X Y => forall e, In e X -> In (f e) Y).
    + intros. exfalso. unfold S.Empty in *. apply (H e);auto.
    + intros. apply P.FM.add_iff. destruct (H1 e). intuition. subst. auto.
  Qed.

  Lemma set_map_spec_1 (f : elt -> elt) (X : t) : forall (e e' : elt),
    In e X -> e' = f e -> In e' (set_map f X).
  Proof.
    intros. subst. apply set_map_spec;auto.
  Qed.

  Lemma set_map_iff (f : elt -> elt) (X : t) : forall e,
    In e (set_map f X) <-> exists e', e = f e' /\ In e' X.
  Proof.
    intros e.
    split.
    + revert e. apply P.fold_rec with
          (P := fun x' Y => forall e, In e Y -> exists e', e = f e' /\ In e' X).
      intros s' H' e He.
      * inversion He.
      * intros x a Y Y' Hx Hx' Hadd IH e He. apply P.FM.add_iff in He. intuition.
        subst. exists x. unfold P.Add in *. destruct (Hadd x);intuition.
    + intros. destruct H. intuition. subst.
      apply set_map_spec;auto.
  Qed.

  Definition Disjoint (m m' : t) :=
    forall k, ~ (In k m /\ In k m').

  Lemma Disjoint_spec m m' : Disjoint m m' <-> forall k, ~ (In k m /\ In k m').
  Proof.
    split;auto.
  Qed.

  Lemma union_assoc :
    forall s s' s'' : S.t, (S.union (S.union s s') s'') = (S.union s (S.union s' s'')).
  Proof.
    intros. apply set_extensionality. apply P.union_assoc.
  Qed.

  Lemma union_comm : forall s s' : S.t, S.union s s' = S.union s' s.
  Proof.
    intros.
    apply set_extensionality. intros.
    split;intros; apply P.Dec.F.union_1 in H; intuition;auto with set.
  Qed.
  Axiom set_map_card : forall f s, cardinal (set_map f s) = cardinal s.
End SetExt.


From isla Require Import opsem.

Definition a80018 : isla_trace :=
  WriteReg "R0" [] (RegVal_Base (Val_Bits (BV 64%N 0x90000%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


Require Import SPAM.SeparationLogic.Syntax.
Require Import SPAM.SeparationLogic.Semantics.
Require Import SPAM.SeparationLogic.Program.

Theorem triple_sound :
  forall
    (pre post : sassert)
    (stat : statement)
    (e : logicalEnv)
    (s s' : variableStore)
    (h h' : heap),
    { pre }- stat -{ post }
    -> (e, s, h) |= pre
    -> <stat, (s, h)> ~> (s', h')
    -> (e, s', h') |= post.
Proof.
  (* TODO: this proof requires many lemmas *)
  intros pre post stat0 e s s' h0 h'0 triple.
  generalize h0 h'0.
  eelim triple.
  { admit.
  }
  { admit.
  }
  { admit.
  }
  { admit.
  }
  { intros A A' B B' stat A'_impl_A B_impl_B' triple_ IHtriple h h' A'_sat stat_runs.
    apply B_impl_B'.
    apply IHtriple with (h0:=h); try assumption.
    now apply A'_impl_A.
  }
  { (* TODO: probably the hardest part of this proof
       - showing that frame is sound! *)
    (* The basic sketch is:
        * Anything not in the modifies set is unchanged by execution
        * A statement which doesn't use the modifies set has the same truth value after execution
        * So the framed off statement still holds
    *)
    admit.
  }
  Admitted.

Theorem program_triple_sound :
  forall
    (pre post : sassert)
    (prog : program)
    (e : logicalEnv)
    (s s' : variableStore)
    (h h' : heap),
    { pre }* prog *{ post }
    -> (e, s, h) |= pre
    -> <prog, (s, h)> ~>* (s', h')
    -> (e, s', h') |= post.
Proof.
  intros pre0 post0 prog0 e s0 s1 h0 h1 triple.
  generalize s0 h0 s1 h1.
  eelim triple.
  { intros pre post stat triple_ s h s' h' pre_sat final_runs.
    inversion final_runs as [ stat_ s'_ h'_ | ].
    now apply triple_sound with (pre:=pre) (stat:=stat) (s:=s) (h:=h).
  }
  { intros A B C stat prog triple_stat triple_prog IHtriple s h s' h' pre_sat seq_runs.
    inversion seq_runs as [ | stat_ prog_ s'' s'_ h'' h'_ ].
    apply IHtriple with (s0:=s'') (h0:=h''); try assumption.
    now apply triple_sound with (pre:= A) (stat:=stat) (s:=s) (h:=h).
  }
  Qed.


Require Import FunctionalExtensionality.

From iris Require Export bi.bi proofmode.tactics proofmode.monpred.

Axiom prop_extensionality : forall A B:Prop, (A <-> B) -> A = B.
Definition pred_incl {A} (P Q : A -> Prop) := forall x, P x -> Q x.

Definition pred_impl {A} (P Q : A -> Prop) := fun x => P x -> Q x.

Notation "P ==> Q" := (pred_incl P Q).

Section hprop.

  (* Operators *)
  Definition hprop := Prop.

  Definition hand (H1 H2:hprop):hprop := H1 /\ H2.

  Definition hor (H1 H2:hprop) : hprop := H1 \/ H2.

  Definition hempty : hprop := True.

  Definition hsingle : hprop := True.

  Definition hstar := hand.

  Definition hexists {A} (J : A -> hprop) : hprop :=
    exists x, J x.

  Definition hpure (P:Prop) : hprop := P.

  Definition htop : hprop := True.

  Definition hforall {A} (f : A -> hprop) : hprop := forall a, f a.

  Definition hwand (H1 H2 : hprop) : hprop := H1 -> H2.

  Definition hpure_abs (P : Prop) : hprop := P.

  Lemma hempty_intro : hempty.
  Proof. reflexivity. Qed.

  Local Notation "'heap_empty'" := (∅).

  Local Notation "h1 \u h2" := (h1 ∪ h2) (at level 37, right associativity).

  Local Notation "'Hexists' x1 , H" := (hexists (fun x1 => H))
                                         (at level 39, x1 name, H at level 50).
  Local Notation "'Hexists' x1 x2 , H" := (Hexists x1, Hexists x2, H)
                                            (at level 39, x1 name, x2 name, H at level 50).
  Local Notation "'Hexists' x1 x2 x3 , H" := (Hexists x1, Hexists x2, Hexists x3, H)
                                               (at level 39, x1 name, x2 name, x3 name, H at level 50).

  Local Notation "'\[]'" := (hempty)
                              (at level 0).

  Local Notation "\[ P ]" := (hpure P)
                               (at level 0, P at level 99, format "\[ P ]").

  Local Notation "H1 '\*' H2" := (hstar H1 H2)
                                   (at level 41, right associativity).

  Local Notation "\Top" := htop.

  Declare Scope heap_scope.

  Ltac extens := apply prop_extensionality.

  Section Properties.

    Lemma hstar_comm : forall H1 H2,
      H1 \* H2 = H2 \* H1.
    Proof using.
      intros H1 H2. extens.
      split; intro; destruct H; split; auto.
    Qed.

    Lemma hstar_assoc : forall H1 H2 H3,
        (H1 \* H2) \* H3 = H1 \* (H2 \* H3).
    Proof.
      intros H1 H2 H3. extens. split.
      intros [[P0 P1] P2]. repeat split; auto.
      intros [P0 [P1 P2]]. repeat split; auto.
    Qed.

  End Properties.

  Definition hpersistent (H:hprop) : hprop := H.

  Definition hlater (H : hprop) := H.

  Set Warnings "-redundant-canonical-projection -convert_concl_no_check".
  Canonical Structure hpropO := leibnizO hprop.

  Program Canonical Structure hpropProp : bi :=
    Bi hprop _ _ impl hempty hpure_abs hand hor
       impl (@hforall) (@hexists) hstar hwand hpersistent hlater _ _ _ _.
  Next Obligation.
    repeat split; unfold impl; intros; eauto.
    - rewrite H in H0. auto.
    - rewrite H. auto.
    - rewrite leibniz_equiv_iff. destruct H. extens. split; intro; auto.
    - intros P0 P1 equiv. extens. unfold hpure_abs. auto.
    - intros A P0 P1 equiv y P2. unfold hand. rewrite P1. rewrite P2. reflexivity.
    - intros A P0 P1 equiv y P2. rewrite P1. rewrite P2. reflexivity.
    - intros l0 P0 P1. repeat red. intros. rewrite H. rewrite P1. reflexivity.
    - intros l P0 P1. repeat red in P1. repeat red. unfold hforall. extens.
      split; intros. rewrite <- P1. auto. rewrite P1. auto.
    - intros l P0 P1. repeat red in P1. repeat red. unfold hexists. extens.
      split; intros [x P]; exists x. rewrite <- P1. auto. rewrite P1. auto.
    - intros l P0 P1 P2 y P3. rewrite P1. rewrite P3. auto.
    - intros l P0 P1 P2 y P3. rewrite P1. rewrite P3. auto.
    - intros l P0 P1. rewrite P1. auto.
    - apply H; auto. red. trivial.
    - destruct H. auto.
    - destruct H. auto.
    - left. auto.
    - right. auto.
    - destruct H1; tauto.
    - apply H. split; auto.
    - destruct H0. tauto.
    - unfold hforall. intro. auto.
    - exists a. auto.
    - destruct H0. eapply H. eauto.
    - unfold impl in *. unfold hstar in *. destruct H1. tauto.
    - destruct H1. unfold impl in *. tauto.
    - destruct H. auto.
    -  destruct H. auto.
    - destruct H. auto.
    - do 2 destruct H. auto.
    - do 2 destruct H. auto.
    - do 2 destruct H. auto.
    - intro. unfold hstar in H. unfold hand in H. tauto.
    - destruct H0. apply H; tauto.
    - unfold hpersistent in *. tauto.
    - unfold hpersistent in *. destruct H. tauto.
    - destruct H. apply H.
    - destruct H. auto.
  Qed.
  Next Obligation.
    repeat split; try(solve_proper); eauto.
    - intros A Φ. rewrite /hlater. auto.
    - intros A Φ h a. apply h.
    - intros Hp h P. right. destruct P. exists x; auto.
    - destruct H. auto.
    - destruct H. auto.
    - destruct H. auto.
    - destruct H. auto.
    - intros P0 P1. right. intro. auto.
  Qed.

  Instance inhabited_unit : Inhabited unit.
  Proof.
    split. apply ().
  Qed.

  Instance PreOrder_unit : PreOrder (fun (t1 t2 : unit) => t1 = t2).
  Proof.
    split; repeat red; intros; trivial. destruct x,y,z. reflexivity.
  Qed.

  Program Canonical Structure biInd := BiIndex unit inhabited_unit _ PreOrder_unit.

  Lemma emp_trivial : ⊢ (emp : monPred biInd hpropProp). Proof. simpl. auto. Qed.

  Lemma soundness1 (Φ : Prop) : (⊢ ⌜ Φ ⌝ : monPred biInd hpropProp) -> Φ.
  Proof.
    MonPred.unseal=> -[H]. repeat red in H. eapply (H tt).
    MonPred.unseal. repeat red. trivial.
  Qed.

  Lemma soundness2 (Φ : monPred biInd hpropProp) : (⊢ Φ) -> Φ ().
  Proof.
    intros. apply H. MonPred.unseal. repeat red. trivial.
  Qed.

  Lemma soundness3 (Φ : monPred biInd hpropProp) : Φ () -> (⊢Φ).
  Proof.
    split. MonPred.unseal. intros i P0. destruct i. auto.
  Qed.

End hprop.


Require Import Arith.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Coqlib.
Require Import List.
Require Import List. Import ListNotations.

Definition asZ (x : bool) : Z := if x then 1 else 0.

Lemma asZT: asZ true = 1. reflexivity. Qed.
Lemma asZF: asZ false = 0. reflexivity. Qed.

Definition convertByteBits bits (byte : Z) : Prop :=
  exists (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
   bits = [b0; b1; b2; b3; b4; b5; b6; b7] /\
   byte =  (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
         + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)).
(* TODO: stuck here *)

Lemma AUX1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15:
Z.lxor
  (1 * 1 + 2 * 1 + 4 * asZ b2 + 8 * asZ b3 + 16 * asZ b4 + 32 * asZ b5 +
   64 * asZ b6 + 128 * asZ b7)
  (1 * asZ b8 + 2 * asZ b9 + 4 * asZ b10 + 8 * asZ b11 + 16 * asZ b12 +
   32 * asZ b13 + 64 * asZ b14 + 128 * asZ b15) =
1 * (if negb b8 then 1 else 0) + 2 * (if negb b9 then 1 else 0) +
4 * (if xorb b2 b10 then 1 else 0) + 8 * (if xorb b3 b11 then 1 else 0) +
16 * (if xorb b4 b12 then 1 else 0) + 32 * (if xorb b5 b13 then 1 else 0) +
64 * (if xorb b6 b14 then 1 else 0) + 128 * (if xorb b7 b15 then 1 else 0).
Proof.
      destruct b2; try rewrite asZT; try rewrite asZF.
      { rewrite (xorb_true_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
      { rewrite (xorb_false_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
Qed.
Lemma AUX2 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15:
Z.lxor (1 * 1 + 2 * 0 + 4 * asZ b2 + 8 * asZ b3 + 16 * asZ b4 + 32 * asZ b5 +
   64 * asZ b6 + 128 * asZ b7)
  (1 * asZ b8 + 2 * asZ b9 + 4 * asZ b10 + 8 * asZ b11 + 16 * asZ b12 +
   32 * asZ b13 + 64 * asZ b14 + 128 * asZ b15) =
1 * (if negb b8 then 1 else 0) + 2 * (if b9 then 1 else 0) +
4 * (if xorb b2 b10 then 1 else 0) + 8 * (if xorb b3 b11 then 1 else 0) +
16 * (if xorb b4 b12 then 1 else 0) + 32 * (if xorb b5 b13 then 1 else 0) +
64 * (if xorb b6 b14 then 1 else 0) + 128 * (if xorb b7 b15 then 1 else 0).
Proof.
      destruct b2; try rewrite asZT; try rewrite asZF.
      { rewrite (xorb_true_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
      { rewrite (xorb_false_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
Qed.

Lemma AUX3 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15:
Z.lxor
  (1 * 0 + 2 * 1 + 4 * asZ b2 + 8 * asZ b3 + 16 * asZ b4 + 32 * asZ b5 +
   64 * asZ b6 + 128 * asZ b7)
  (1 * asZ b8 + 2 * asZ b9 + 4 * asZ b10 + 8 * asZ b11 + 16 * asZ b12 +
   32 * asZ b13 + 64 * asZ b14 + 128 * asZ b15) =
1 * (if b8 then 1 else 0) + 2 * (if negb b9 then 1 else 0) +
4 * (if xorb b2 b10 then 1 else 0) + 8 * (if xorb b3 b11 then 1 else 0) +
16 * (if xorb b4 b12 then 1 else 0) + 32 * (if xorb b5 b13 then 1 else 0) +
64 * (if xorb b6 b14 then 1 else 0) + 128 * (if xorb b7 b15 then 1 else 0).
Proof.
      destruct b2; try rewrite asZT; try rewrite asZF.
      { rewrite (xorb_true_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
      { rewrite (xorb_false_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
Qed.

Lemma AUX4 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15:
Z.lxor (1 * 0 + 2 * 0 + 4 * asZ b2 + 8 * asZ b3 + 16 * asZ b4 + 32 * asZ b5 +
   64 * asZ b6 + 128 * asZ b7)
  (1 * asZ b8 + 2 * asZ b9 + 4 * asZ b10 + 8 * asZ b11 + 16 * asZ b12 +
   32 * asZ b13 + 64 * asZ b14 + 128 * asZ b15) =
1 * (if b8 then 1 else 0) + 2 * (if b9 then 1 else 0) +
4 * (if xorb b2 b10 then 1 else 0) + 8 * (if xorb b3 b11 then 1 else 0) +
16 * (if xorb b4 b12 then 1 else 0) + 32 * (if xorb b5 b13 then 1 else 0) +
64 * (if xorb b6 b14 then 1 else 0) + 128 * (if xorb b7 b15 then 1 else 0).
Proof.
      destruct b2; try rewrite asZT; try rewrite asZF.
      { rewrite (xorb_true_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
      { rewrite (xorb_false_l b10).
        destruct b3; try rewrite asZT; try rewrite asZF.
        { rewrite (xorb_true_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
        { rewrite (xorb_false_l b11).
          destruct b4; destruct b5; destruct b6; destruct b7; destruct b8; destruct b9;
          destruct b10; destruct b11; destruct b12; destruct b13; destruct b14; destruct b15; trivial.
        }
      }
Qed.

Lemma xor_correspondence :
  forall (b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 : bool)
         (byte0 byte1 : Z),
    convertByteBits [b0; b1; b2; b3; b4; b5; b6; b7] byte0 ->
    convertByteBits [b8; b9; b10; b11; b12; b13; b14; b15] byte1 ->

    convertByteBits
      [xorb b0 b8; xorb b1 b9; xorb b2 b10; xorb b3 b11;
       xorb b4 b12; xorb b5 b13; xorb b6 b14; xorb b7 b15]
      (Z.lxor byte0 byte1).
Proof.
  intros.
  generalize dependent H. generalize dependent H0. intros H0 H1.
  unfold convertByteBits. unfold asZ.

  do 8 eexists. split. reflexivity.
  unfold convertByteBits in *.

  destruct H0 as [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ]] ]] ].  (* nested 8 *)
  destruct H.
  symmetry in H.
  inversion H. clear H.
  subst.

  destruct H1 as [ ? [ ? [ ? [ ? [ ? [ ? [ ? [ ? ? ] ] ] ]] ]] ].  (* nested 8 *)
  destruct H.
  symmetry in H.
  inversion H. clear H.
  subst.
  destruct b0; try rewrite asZT; try rewrite asZF.
  { rewrite (xorb_true_l b8).
    destruct b1; try rewrite asZT; try rewrite asZF.
    { rewrite (xorb_true_l b9). apply AUX1. }
    { rewrite (xorb_false_l b9). apply AUX2. }
  }
  { rewrite (xorb_false_l b8).
    destruct b1; try rewrite asZT; try rewrite asZF.
    { rewrite (xorb_true_l b9). apply AUX3. }
    { rewrite (xorb_false_l b9). apply AUX4. }
  }
Qed.


Require Import Basic.
Set Implicit Arguments.

Require Import Event.

Module Language.
  Section Language.
  Definition fid: Type := IdentMap.key.

    Structure t := mk {
      syntax: Type;
      state: Type;

      init: syntax -> fid -> option state;
      is_terminal: state -> Prop;
      step: forall (e: ProgramEvent.t) (s1: state) (s2: state), Prop;

      (** rtl is deterministic in itself, until it trys to read something from memory pool *)
      deterministic:
        forall (st st1 st2: state) (e1 e2: ProgramEvent.t)
               (STEP1: step e1 st st1)
               (STEP2: step e2 st st2),
          (e1 = e2 /\ st1 = st2) \/
          (exists or loc val1 val2, e1 = ProgramEvent.read loc val1 or /\ e2 = ProgramEvent.read loc val2 or) \/
          (exists or ow loc valr valw valr', e1 = ProgramEvent.update loc valr valw or ow /\
                                             e2 = ProgramEvent.read loc valr' or) \/
          (exists or ow loc valr valw valr', e2 = ProgramEvent.update loc valr valw or ow /\
                                             e1 = ProgramEvent.read loc valr' or);

      read_abitrary_1:
        forall (st1 st2: state) (val val': Const.t) loc ord
               (READ: step (ProgramEvent.read loc val ord) st1 st2),
        exists st2',
          step (ProgramEvent.read loc val' ord) st1 st2' \/
          (exists valw ordw, step (ProgramEvent.update loc val' valw ord ordw) st1 st2');

      read_abitrary_2:
        forall (st1 st2: state) (val val' valw: Const.t) loc ordr ordw
               (UPDATE: step (ProgramEvent.update loc val valw ordr ordw) st1 st2),
        exists st2',
          step (ProgramEvent.read loc val' ordr) st1 st2' \/
          step (ProgramEvent.update loc val' valw ordr ordw) st1 st2'
    }.
  End Language.
End Language.

Definition language: Type := Language.t.


Require Import helperGen.

Require Import MetaCoq.Template.All.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import PCUICToTemplate.
From MetaCoq.PCUIC Require Import TemplateToPCUIC.

Require Import List String.
Import ListNotations MonadNotation Nat.
Require Import MetaCoq.Template.Pretty.
Require Import MetaCoq.PCUIC.PCUICPretty.

From Equations Require Import Equations.
Require Import nested_datatypes.

Open Scope string_scope.

(* list satisfy *)
Inductive is_list A (PA:A->Type) : list A -> Type :=
| is_nil : is_list A PA nil
| is_cons a (pa: PA a) l (pl:is_list A PA l): is_list A PA (a::l).

Definition listAssumption2 {X} (P:X->Type) (xs:list X) := is_list _ P xs.

Lemma is_list_in {X} (P:X->Prop) xs : is_list X P xs -> forall x, In x xs -> P x.
Proof.
  intros.
  induction X0.
  - now contradict H.
  - destruct H as [->|H].
    + apply pa.
    + apply IHX0, H.
Qed.

Definition listProof2 {X} (P:X->Type) (f:forall x, P x) (xs:list X) : listAssumption2 P xs.
Proof.
  unfold listAssumption2.
  induction xs.
  - constructor.
  - constructor.
    + apply f.
    + apply IHxs.
Defined.

Definition prodAssumption X (Px:X->Type) Y (Py:Y->Type) (t:X*Y) : Type := let (x,y) := t in (Px x) * (Py y).
Definition prodProof X (Px:X->Type) (fx:forall x, Px x) Y (Py:Y->Type) (fy:forall y, Py y) (t:X*Y) : prodAssumption _ Px _ Py t.
Proof.
  destruct t.
  cbn. split;[apply fx | apply fy].
Defined.

Definition listAssumption {X} (P:X->Prop) (xs:list X) := forall t, In t xs -> P t.

Definition listProof {X} (P:X->Prop) (f:forall x, P x) (xs:list X) : listAssumption P xs :=
(list_ind (fun xs0 : list X => listAssumption P xs0)
            (fun (t : X) (H0 : In t []) => match H0 return (P t) with
                                                  end)
            (fun (a : X) (xs0 : list X) (IHxs : listAssumption P xs0)
               (t : X) (H0 : In t (a :: xs0)) =>
             match H0 with
             | or_introl H1 => Coq.Init.Logic.eq_ind a (fun t0 : X => P t0) (f a) t H1
             | or_intror H1 => IHxs t H1
             end) xs).

(* invalid f only for smaller instances *)
(* Goal forall X (P:X->Prop) (f:forall x, P x) (xs:list X) , listAssumption P xs. *)
(* Proof. *)
(*   unfold listAssumption. *)
(*   intros. *)
(*   apply f. *)
(* Qed. *)

Inductive is_prod X Y (Px : X->Type) (Py: Y -> Type) : X*Y->Type :=
| is_pair x y (px:Px x) (py:Py y) : is_prod X Y Px Py (x,y).
Definition prodProof2 {X Y} (Px:X->Type) (Py:Y->Type) (fx:forall x, Px x) (fy:forall y, Py y) (t:X*Y) : is_prod _ _ Px Py t.
Proof.
  destruct t.
  cbn. split;[apply fx | apply fy].
Defined.

Definition vec:=Vector.t.

Inductive is_vec {X:Type} (Px: X->Type) : forall n, vec X n -> Type :=
| is_nilV : is_vec Px 0 (@Vector.nil _)
| is_consV (x:X) (px:Px x) n (xs:Vector.t X n) (pxs:is_vec Px n xs): is_vec Px (S n) (Vector.cons X x n xs).

Definition vecProof {X} (P:X->Type) (f:forall x, P x) n (xs:vec X n) : is_vec P n xs.
Proof.
  induction xs.
  - constructor.
  - constructor.
    + apply f.
    + apply IHxs.
Defined.

Definition rtree_ind_MC_Test
     : forall (A : Type) (p : rtree A -> Type),
       (forall a : A, p (Leaf A a)) ->
       (forall l : list (rtree A), is_list (rtree A) p l -> p (Node A l)) -> forall inst : rtree A, p inst :=
fun (A : Type) (p : rtree A -> Type) (H_Leaf : forall a : A, p (Leaf A a))
  (H_Node : forall l : list (rtree A), is_list (rtree A) p l -> p (Node A l)) =>
fix f (inst : rtree A) : p inst :=
  match inst as inst0 return (p inst0) with
  | @Leaf _ a => H_Leaf a
  | @Node _ l =>
      H_Node l
        ((fix F (l0 : list (rtree A)) : is_list (rtree A) p l0 :=
            match l0 as l1 return (is_list (rtree A) p l1) with
            | [] => is_nil (rtree A) p
            | y :: l1 => is_cons (rtree A) p y (f y) l1 (F l1)
            end) l)
  end.

Inductive is_rtree X (Px : X -> Type) : rtree X -> Type :=
| is_Leaf x (px: Px x) : is_rtree X Px (Leaf X x)
| is_Node xs (pxs: is_list (rtree X) (is_rtree X Px) xs) : is_rtree X Px (Node X xs).

Definition rtreeProof2 X (P:X->Type) (f:forall x, P x) (r:rtree X) : is_rtree X P r.
Proof.
  revert r.
  refine (fix IH r := _).
  destruct r.
  - constructor. apply f.
  - constructor.
    apply listProof2.
    apply IH.
Defined.

Definition rtreeProof X (P:X->Type) (f:forall x, P x) (r:rtree X) : is_rtree X P r.
Proof.
  induction r using rtree_ind_MC_Test.
  - constructor. apply f.
  - constructor. apply X0.
Defined.

Definition roseTreeO3_ind_MC :=
fun (X : Type) (p : roseTreeO3 X -> Prop)
  (H_treeO3 : forall (x : X) (xs : list X)
                (xxs : roseTreeO3 X),
              p xxs ->
              forall xsxs : list (roseTreeO3 X),
              is_list (roseTreeO3 X)
                (fun H : roseTreeO3 X => p H) xsxs ->
              p (treeO3 X x xs xxs xsxs)) =>
fix f (inst : roseTreeO3 X) : p inst :=
  match inst as inst0 return (p inst0) with
  | @treeO3 _ x xs xxs xsxs =>
      H_treeO3 x xs xxs (f xxs) xsxs
        ((fix F (l : list (roseTreeO3 X)) :
            is_list (roseTreeO3 X)
              (fun H : roseTreeO3 X => p H) l :=
            match
              l as l0
              return
                (is_list (roseTreeO3 X)
                   (fun H : roseTreeO3 X => p H) l0)
            with
            | [] =>
                is_nil (roseTreeO3 X)
                  (fun H : roseTreeO3 X => p H)
            | y :: l0 =>
                is_cons (roseTreeO3 X)
                  (fun H : roseTreeO3 X => p H) y
                  (f y) l0 (F l0)
            end) xsxs)
  end.

Inductive listᵗ (A : Type) (Aᵗ : A -> Type) : list A -> Type :=
    nilᵗ : listᵗ A Aᵗ [] | consᵗ : forall H : A, Aᵗ H -> forall H0 : list A, listᵗ A Aᵗ H0 -> listᵗ A Aᵗ (H :: H0).

Inductive roseTreeO3ᵗ (X : Type) (Xᵗ : X -> Type) : roseTreeO3 X -> Prop :=
    treeO3ᵗ : forall x : X,
               Xᵗ x ->
               forall xs : list X,
               is_list X Xᵗ xs ->
               forall xxs : roseTreeO3 X,
               roseTreeO3ᵗ X Xᵗ xxs ->
               forall xsxs : list (roseTreeO3 X),
               is_list (roseTreeO3 X) (roseTreeO3ᵗ X Xᵗ) xsxs ->
               roseTreeO3ᵗ X Xᵗ (treeO3 X x xs xxs xsxs).

Definition rtreeO3Proof X (P:X->Type) (f:forall x, P x) (r:roseTreeO3 X) : roseTreeO3ᵗ X P r.
Proof.
  induction r using roseTreeO3_ind_MC.
  - constructor.
    + apply f.
    + apply listProof2.
      apply f.
    + apply IHr.
    + apply X0. (* alternative: listProof2 & IH explizit with fix *)
Restart.
  revert r.
  refine (fix IH r := _).
  destruct r.
  - constructor.
    + apply f.
    + apply listProof2.
      apply f.
    + apply IH.
    + apply listProof2.
      apply IH.
Qed.

Inductive Accᵗ (A : Type) (Aᵗ : A -> Type) (R : A -> A -> Prop)
(Rᵗ : forall H : A,
      Aᵗ H -> forall H0 : A, Aᵗ H0 -> R H H0 -> Prop)
(x : A) (xᵗ : Aᵗ x) : Acc R x -> Prop :=
    Acc_introᵗ : forall
                   H : forall y : A, R y x -> Acc R y,
                 (forall (y : A) (yᵗ : Aᵗ y)
                    (H0 : R y x),
                  Rᵗ y yᵗ x xᵗ H0 ->
                  Accᵗ A Aᵗ R Rᵗ y yᵗ (H y H0)) ->
                 Accᵗ A Aᵗ R Rᵗ x xᵗ (Acc_intro x H).

Definition AccProof (A : Type) (Aᵗ : A -> Type) (R : A -> A -> Prop)
(Rᵗ : forall H : A,
      Aᵗ H -> forall H0 : A, Aᵗ H0 -> R H H0 -> Prop)
(x : A) (xᵗ : Aᵗ x) (r : Acc R x) : Accᵗ A Aᵗ R Rᵗ x xᵗ r.
Proof.
  intros.
  revert x xᵗ r.
  refine (fix IH x xᵗ r := _).
  destruct r.
  constructor.
  intros.
  apply IH.
Defined.

Inductive boolᵗ : bool -> Set :=
  trueᵗ : boolᵗ true | falseᵗ : boolᵗ false.
Inductive natᵗ : nat -> Set :=
    Oᵗ : natᵗ 0
  | Sᵗ : forall H : nat, natᵗ H -> natᵗ (S H).

Inductive
containerInd4ᵗ (b : bool) (bᵗ : boolᵗ b)
(X : Type) (Xᵗ : X -> Type) (n : nat)
(nᵗ : natᵗ n)
  : containerInd4 b X n -> Prop :=
  c4ᵗ : containerInd4ᵗ b bᵗ X Xᵗ n nᵗ (c4 b X n).

Definition containerInd4Proof (b : bool) (bᵗ : boolᵗ b)
(X : Type) (Xᵗ : X -> Type) (n : nat)
(nᵗ : natᵗ n) (a:containerInd4 b X n) :
  containerInd4ᵗ b bᵗ X Xᵗ n nᵗ a.
Proof.
  destruct a.
  constructor.
Defined.

Inductive
vecᵗ (A : Type) (Aᵗ : A -> Type)
  : forall H : nat, natᵗ H -> vec A H -> Type :=
    vecnilᵗ : vecᵗ A Aᵗ 0 Oᵗ (@Vector.nil A)
  | vecconsᵗ : forall H : A,
               Aᵗ H ->
               forall (n : nat) (nᵗ : natᵗ n)
                 (H0 : vec A n),
               vecᵗ A Aᵗ n nᵗ H0 ->
               vecᵗ A Aᵗ (S n) (Sᵗ n nᵗ)
                    (@Vector.cons A H n H0).

Definition vecProof2
           (A : Type) (Aᵗ : A -> Type) (fA: forall a, Aᵗ a)
           (n : nat) (H:natᵗ n) (fn: forall n, natᵗ n)
           (a:vec A n) :
  vecᵗ A Aᵗ n H a.
Proof.
  induction a in H, fn |- *.
  - depelim H.
    constructor.
  - depelim H.
    constructor.
    + apply fA.
    + apply IHa.
      apply fn.
Qed.

Inductive
vecᵗ' (A : Type) (Aᵗ : A -> Type)
  : forall H : nat, vec A H -> Type :=
    vecnilᵗ' : vecᵗ' A Aᵗ 0 (@Vector.nil A)
  | vecconsᵗ' : forall H : A,
               Aᵗ H ->
               forall (n : nat)
               (* (nᵗ : natᵗ n) *)
                 (H0 : vec A n),
               vecᵗ' A Aᵗ n H0 ->
               vecᵗ' A Aᵗ (S n)
                    (@Vector.cons A H n H0).

Definition vecProof2'
           (A : Type) (Aᵗ : A -> Type) (fA: forall a, Aᵗ a)
           (n : nat)
           (* (fn: forall n, natᵗ n) *)
           (a:vec A n) :
  vecᵗ' A Aᵗ n a.
Proof.
  induction a.
  - constructor.
  - constructor.
    + apply fA.
    + apply IHa.
Qed.

Print mfixpoint.
Check list.

Print def.

Definition defAssumption {X} (P:X->Type) (x:def X) :=
  prod
    (P (dtype x))
    (P (dbody x)).
Definition defProof {X} (P:X->Type) (f:forall x, P x) (x:def X) : defAssumption P x.
  now constructor.
Defined.

Definition mfixpointAssumption {X} (P:X->Type) (x:mfixpoint X) := is_list _ (defAssumption P) x.
Definition mfixpointProof {X} (P:X->Type) (f:forall x, P x) (x:mfixpoint X) : mfixpointAssumption P x.
  now apply listProof2, defProof.
Defined.

Print All_Forall.All.
Print is_list.
Print listProof2.

(* Inductive is_All (A : Type) (PA: A -> Type) (P : A -> Type) (PP:forall a:A, PA a -> P a -> Type) : forall (xs:list A), is_list _ PA xs -> All_Forall.All P xs -> Type := *)
(*     (1* is_All_nil : is_All A PA P PP (@nil A) (@is_nil A PA) (@All_nil A P). *1) *)
(* | is_All_cons (x:A) (px:PA x) (l:list A) (pl: is_list A PA l) *)
(*     (h: P x) (ph: PP x px h) (h2: All_Forall.All P l) (ph2: is_All A PA P PP l pl h2): *)
(*     is_All A PA P PP (cons x l) (@is_cons A PA x px l pl) (@All_cons A P x l h h2). *)
(*   (1* | is_All_cons : forall (x : A) (l : list A), *1) *)
(*                (1* P x -> All_Forall.All P l -> All_Forall.All P (x :: l) *1) *)
(* Definition allAssumption  := is_All. *)

(* Definition allProof (A:Type) (PA:A -> Type) (HA:forall a, PA a) *)
(*                     (P:A->Type) (PP: forall a:A, PA a -> P a -> Type) (HP: forall (a:A) (h:PA a), HA a -> PP a h ) *)

Instance listInst : registered list :=
{|
    assumption := @listAssumption2;
    proof := @listProof2
|}.

Instance prodInst : registered prod :=
{|
    assumption := @prodAssumption;
    proof := @prodProof
|}.

Instance vecInst : registered VectorDef.t :=
{|
    assumption := @is_vec;
    proof := @vecProof
|}.

Instance rtreeInst : registered rtree :=
{|
    assumption := @is_rtree;
    proof := @rtreeProof
|}.

Instance containerInd4Inst : registered containerInd4 :=
{|
    assumption := @containerInd4ᵗ;
    proof := @containerInd4Proof
|}.

Instance defInst : registered def :=
{|
    assumption := @defAssumption;
    proof := @defProof
|}.

Instance mfixpointInst : registered mfixpoint :=
{|
    assumption := @mfixpointAssumption;
    proof := @mfixpointProof
|}.


(*
  Author : Abhishek Anand
  email : abhishek.anand.iitg@gmail.com
*)

Require Export QArith.

(* only available after Coq 8.5 *)
Require Import ExtrHaskellZInteger.
Require Import ExtrHaskellZNum.

(*copied from CoRN.util.Extract.*)
Extract Inductive comparison => "Prelude.Ordering" [ "Prelude.EQ" "Prelude.LT" "Prelude.GT" ].

Extract Inlined Constant Psucc => "(Prelude.succ)".
Extract Inlined Constant Ppred => "(Prelude.pred)".
Extract Inlined Constant Pplus => "(Prelude.+)".
Extract Inlined Constant Pminus => "(Prelude.-)".
Extract Inlined Constant Pmult => "(Prelude.*)".
Extract Inlined Constant Pmin => "(Prelude.min)".
Extract Inlined Constant Pmax => "(Prelude.max)".
Extract Inlined Constant Pos.compare => "(Prelude.compare)".

(**
sudo apt-get install ghc-prof
ghc simulator.hs -main-is Simulator -o Simulator -prof -fprof-auto
time ./Simulator +RTS -p
vim Simulator.prof

        Fri Jan 22 20:10 2016 Time and Allocation Profiling Report  (Final)

          Simulator +RTS -p -RTS

       total time  =      222.64 secs   (222638 ticks @ 1000 us, 1 processor)
       total alloc = 238,092,222,376 bytes  (excludes profiling overheads)

COST CENTRE      MODULE    %time %alloc

compare_cont.\   Simulator  45.5   48.6
compare_cont.\.\ Simulator  24.1   24.3
compare_cont.\.\ Simulator  23.9   24.3
compare_cont     Simulator   1.3    0.0

*)

(**
Clearly compare_cont was the bottleneck in the above application.
It operates using the binary representation, which is costly to simulate
over machine big integers. So, we redefine it as below, so that
it only uses the above fast operations.
*)
Definition  posCompareContAbstract43820948120402312
(c: comparison) (x y: positive) :comparison :=
Pos.switch_Eq c (Pos.compare x y).

(*posCompareContAbstract43820948120402312 has to be extracted as well
in any project. Coq doesn't know that it is supposed to extracted
posCompareContAbstract43820948120402312 when Pos.compare_cont
is supposed to be extracted.*)
Extract  Constant Pos.compare_cont => "(posCompareContAbstract43820948120402312)".

(**
In one application (animating the car's motion),
the above directive cut down the cost from 3 minutes
to 3 seconds.

The proof below justifies the above directive.
*)

Lemma PosCompareContAbstract43820948120402312Correct
(c: comparison) (x y: positive) :
Pos.compare_cont c x y
= posCompareContAbstract43820948120402312 c x y.
Proof using.
  apply Pos.compare_cont_spec.
Qed.

Extract  Constant positive_eq_dec => "(Prelude.==)".
(** Although the definition of Haskell's Ratio is the
  exact same as Coq.QArith.QArith_base.Q,
  the haskell version has useful utilities like conversion
  to and from floats. Coq's operations on rationals are retained. *)

Extract Inductive Q => "(Data.Ratio.Ratio Prelude.Integer)" ["(\x y -> (Data.Ratio.%) x y)"]
  "(\fp qn -> fp (Data.Ratio.numerator qn) (Data.Ratio.denominator qn))".