Require Import Raft.
Require Import RaftRefinementInterface.

Section LeaderLogsLogProperties.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition log_property (P : list entry -> Prop) :=
    forall net h,
      refined_raft_intermediate_reachable net ->
      P (log (snd (nwState net h))).

  Definition log_properties_hold_on_leader_logs net :=
    forall P h t ll,
      log_property P ->
      In (t, ll) (leaderLogs (fst (nwState net h))) ->
      P ll.

  Class log_properties_hold_on_leader_logs_interface : Prop :=
    {
      log_properties_hold_on_leader_logs_invariant :
        forall (net : network),
          refined_raft_intermediate_reachable net ->
          log_properties_hold_on_leader_logs net
    }.

End LeaderLogsLogProperties.


Set Implicit Arguments.

Require Import Decidable.
Require Import Arith.
Require Import Program.
Require Import Packages.
Require Import MGraph.
Require Import Verifier.
Require Import Classical_Prop.

Module Import DepGraph := DiGraph PackageSet.
Import PackageSet.
Import PAux.Props.
Module Import PAux := Aux PackageSet.

Definition conj_cone_of (R: PackageSet.t) (P: PackageSet.t | P [<=] R): PackageSet.t :=
  cone_of Dependencies is_conjunctive_bool R P.

Lemma add_edge_vinv: forall g v v' v'',
  IsVertex v (add_edge (v', v'') g) ->
  IsVertex v g \/ Package.eq v v' \/ Package.eq v v''.
Proof.
  intros. elim (Package.eq_dec v v').
    intros. right. left. apply a.
    intros. elim (Package.eq_dec v v'').
      intros. right. right. apply a.
    intros. left. apply add_edge_v4 with v' v''.
      apply b.
      apply b0.
      apply H.
Qed.

Lemma add_edge_inv: forall g e e',
  IsEdge e' (add_edge e g) ->
  IsEdge e' g \/ Edges.E.eq e e'.
Proof.
  intros. elim (Edges.E.eq_dec e e').
    intros. right. apply a.
    intros. left. apply add_edge_3 with e. intro.  apply b. apply Edge.eq_sym. apply H0. apply H.
Qed.

Lemma cpl: forall p,
  compat_op Package.eq DepGraph.eq
           (fun (p' : elt) (acc : DepGraph.t) =>
            if Props.Dec.F.eq_dec p p' then acc else add_edge (p, p') acc).
Proof.
  intros. unfold compat_op. intros.
  elim (Props.Dec.F.eq_dec p x).
    elim (Props.Dec.F.eq_dec p x').
      intros. apply H0.
      intros. absurd (~Package.eq p x'). intro. apply H1.
      rewrite <- H. apply a. apply b.
    elim (Props.Dec.F.eq_dec p x').
      intros. absurd (~Package.eq p x). intro. apply H1.
      rewrite H. apply a. apply b.
      intros. split.
        intros. split. intros. elim (add_edge_vinv H1).
        intros. rewrite H0 in H2. apply add_edge_v1. apply H2.
      intros. elim H2.
        intros. rewrite H3. apply add_edge_v2.
        intros. rewrite H3. rewrite H. apply add_edge_v3.
      intros. elim (add_edge_vinv H1).
        intros. rewrite <- H0 in H2. apply add_edge_v1. apply H2.
      intros. elim H2.
        intros. rewrite H3. apply add_edge_v2.
        intros. rewrite H3. rewrite <- H. apply add_edge_v3.
      intros. assert (Edges.E.eq (p,x) (p,x')).
        split.
          simpl. reflexivity.
          simpl. apply H.
        split.
          intros. elim (add_edge_inv H2).
            intros. apply add_edge_2. rewrite <- H0. apply H3.
            intros. apply add_edge_1. rewrite <- H1. apply H3.
          intros. elim (add_edge_inv H2).
            intros. apply add_edge_2. rewrite H0. apply H3.
            intros. apply add_edge_1. rewrite H1. apply H3.
Qed.

Lemma tpl: forall p,
  transpose DepGraph.Equal
    (fun (p' : elt) (acc : DepGraph.t) =>
    if Props.Dec.F.eq_dec p p' then acc else add_edge (p, p') acc).
Proof.
  intros. unfold transpose. intros.
  split.
    intros.
      elim (Props.Dec.F.eq_dec p x).
         elim (Props.Dec.F.eq_dec p y).
           intros. reflexivity.
           intros. reflexivity.
         elim (Props.Dec.F.eq_dec p y).
           intros. reflexivity.
           intros. split.
             intros. elim (add_edge_vinv H).
             intros. elim (add_edge_vinv H0).
             intros. apply add_edge_v1. apply add_edge_v1. apply H1.
             intros. elim H1.
               intros. rewrite H2. apply add_edge_v1. apply add_edge_v2.
               intros. rewrite H2. apply add_edge_v3.
             intros. elim H0.
             intros. rewrite H1. apply add_edge_v2.
             intros. rewrite H1. apply add_edge_v1. apply add_edge_v3.
             intros. elim (add_edge_vinv H).
             intros. elim (add_edge_vinv H0).
             intros. apply add_edge_v1. apply add_edge_v1. apply H1.
             intros. elim H1.
               intros. rewrite H2. apply add_edge_v1. apply add_edge_v2.
               intros. rewrite H2. apply add_edge_v3.
             intros. elim H0.
             intros. rewrite H1. apply add_edge_v2.
             intros. rewrite H1. apply add_edge_v1. apply add_edge_v3.
  intros. elim (Props.Dec.F.eq_dec p x).
    elim (Props.Dec.F.eq_dec p y).
      intros. reflexivity.
      intros. reflexivity.
    elim (Props.Dec.F.eq_dec p y).
      intros. reflexivity.
      intros. split.
        intros. elim (add_edge_inv H).
          intros. elim (add_edge_inv H0).
            intros. apply add_edge_2. apply add_edge_2. apply H1.
            intros. apply add_edge_1. apply H1.
          intros. apply add_edge_2. apply add_edge_1. apply H0.
        intros. elim (add_edge_inv H).
          intros. elim (add_edge_inv H0).
            intros. apply add_edge_2. apply add_edge_2. apply H1.
            intros. apply add_edge_1. apply H1.
          intros. apply add_edge_2. apply add_edge_1. apply H0.
Qed.

Lemma bla: forall p q P,
  (* In p P -> *)
  IsEdge (p, q) (PackageSet.fold (fun p' acc => if Package.eq_dec p p' then acc else add_edge (p, p') acc) P DepGraph.empty) -> ~Package.eq p q.
Proof.
  intros. induction P using set_induction.
  rewrite (fold_1 DepGraph.EqualSetoid) in H. intro. apply empty_edge with (p, q). apply H.
    apply H0.
  rewrite (fold_2 DepGraph.EqualSetoid _ (cpl p) (tpl p) H0 H1) in H.
  elim (Package.eq_dec x q).
  intros. generalize H. clear H. elim (Props.Dec.F.eq_dec p x).
    intros. apply (IHP1 H).
    intros. intro. apply b. rewrite a. rewrite H2. reflexivity.
    intros. generalize H. clear H. elim (Props.Dec.F.eq_dec p x).
    intros. apply (IHP1 H).
    intros. apply IHP1. apply add_edge_3 with (p, x). intro. apply b. inversion H2.
    simpl in H4. symmetry. apply H4. apply H.
Qed.

Lemma bla2: forall (f: Package.t -> DepGraph.t -> DepGraph.t) Z p q,
  (compat_op Package.eq DepGraph.Equal f) ->
  (transpose DepGraph.Equal f) ->
  (forall x g p q, IsEdge (p, q) (f x g) -> IsEdge (p, q) g \/ Package.eq x q) ->
  IsEdge (p, q) (fold f Z DepGraph.empty) ->
  Exists (fun s => Package.eq s  q) Z.
Proof.
  intros. induction Z using set_induction.
   rewrite (fold_1 DepGraph.EqualSetoid) in H2. absurd (IsEdge (p, q) DepGraph.empty).
     apply empty_edge. apply H2. apply H3.
   rewrite (fold_2 DepGraph.EqualSetoid _ H H0 H3 H4) in H2.
   elim H1 with x (fold f Z1 DepGraph.empty) p q. intros.
     elim (IHZ1 H5). intros. exists x0. destruct H6. split.
     elim (H4 x0). intros. apply H9. right. apply H6.
     apply H7.
     intros. unfold Exists. exists x. split. elim (H4 x). intros.
     apply H7. left. reflexivity. apply H5.
   apply H2.
Qed.

Lemma not_empty_add:
  forall S: PackageSet.t, ~Empty S ->
    exists x: Package.t, exists S': PackageSet.t,
      ~In x S' /\ Add x S' S.
Proof.
  intros. induction S using set_induction.
  absurd (Empty S). apply H. apply H0.
  exists x S1. split. apply H0. apply H1.
Qed.

Lemma bla3: forall p v S,
  ~Package.eq p v -> In v S ->
  IsEdge (p, v) (fold (fun p' acc => if Props.Dec.F.eq_dec p p' then acc else add_edge (p, p') acc)
     S DepGraph.empty).
Proof.
  intros. induction S using set_induction.
  rewrite (fold_1 DepGraph.EqualSetoid).
    absurd (In v S). apply H1. apply H0. apply H1.
  rewrite (fold_2 DepGraph.EqualSetoid _ (cpl p) (tpl p) H1 H2).
  elim (H2 v). intros. elim (H3 H0). intros.
    elim (Package.eq_dec p x).
      intros. absurd (Package.eq p x).
      intro. apply H. rewrite a. exact H5.
      exact a.
      intros. apply add_edge_1. unfold Edge.eq. split. simpl. reflexivity. simpl. apply H5.
    intros. elim (Package.eq_dec p x).
      intros. apply IHS1. apply H5.
      intros. apply add_edge_2. apply IHS1. apply H5.
Qed.

Program Definition add_conj_edges
  (R: PackageSet.t) (p: Package.t | In p R):
  { G: DepGraph.t |
    forall v: DepGraph.vertex, DepGraph.IsEdge (p, v) G <->
    conjunctive_dependency R p v /\ ~Package.eq p v } :=
PackageSet.fold (fun p' acc =>
  if Package.eq_dec p p' then acc else DepGraph.add_edge (p, p') acc
) (conj_cone_of (exist (fun P => P [<=] R) (singleton p) (PkgDefinitions.PAux.s_ss (proj2_sig p)))) DepGraph.empty.
Obligation 1.
  split.
  (* edge -> cjd *) intros.
     split. elim (cone_in_dep Dependencies is_conjunctive_bool R (exist (fun x => In x R) p H) v).
     trivial.
     (* p = v; absurd because of fold cond *) intros. simpl in H1.
       absurd (Package.eq p v). apply bla with (conj_cone_of (exist (fun P => P [<=] R) (singleton p) (PkgDefinitions.PAux.s_ss (proj2_sig (exist (fun p => In p R) p H))))).
       apply H0. apply H1.
     simpl. simpl in H0. elim bla2 with
      (fun p' acc => if Props.Dec.F.eq_dec p p' then acc else add_edge (p, p') acc)
      (conj_cone_of (exist (fun P => P [<=] R) (singleton p) (PkgDefinitions.PAux.s_ss H)))
      p v.
     intros. destruct H1. rewrite <- H2. unfold conj_cone_of in H1. apply H1.
     apply cpl.
     apply tpl.
     intros x g p0 q. elim (Props.Dec.F.eq_dec p x).
       intros. left. apply H1.
       intros. elim (add_edge_inv H1).
         intros. left. apply H2.
         intros. destruct H2. simpl in H3. right. apply H3.
     apply H0.
     apply (bla H0).
   (* cjd -> edge *) intros. simpl.
   destruct H0. apply bla3.
   apply H1.
   apply (dep_in_cone Dependencies is_conjunctive_bool R (exist (fun x => In x R) p H) v H0).
Qed.

Program Lemma cpb_trim: forall R C, compat_bool Package.eq (fun p => negb (is_empty ((verify R C p (install_function R C p))))).
Proof.
  intros. unfold compat_bool. intros.
  apply eq_bool_prop_intro. split.
    intros. apply negb_prop_intro. intro.
    elim (negb_prop_elim (is_empty (proj1_sig (verify R C x (install_function R C x))))).
    apply H0.
    apply Is_true_eq_left. apply is_empty_1. rewrite (verify_eq R C H (install_function_eq R C x y)).
    apply is_empty_2. apply Is_true_eq_true. apply H1.
    intros. apply negb_prop_intro. intro.
    elim (negb_prop_elim (is_empty (proj1_sig (verify R C y (install_function R C y))))).
    apply H0.
    apply Is_true_eq_left. apply is_empty_1. rewrite (verify_eq R C (Package.eq_sym H) (install_function_eq R C y x)).
    apply is_empty_2. apply Is_true_eq_true. apply H1.
Qed.

Program Definition trim (R: PackageSet.t) (C: ConflictSet.t):
  { Rt: PackageSet.t | forall p: Package.t,
    In p Rt -> exists I, I [<=] R /\ is_install_set p R C I } :=
  PackageSet.filter (fun p => negb (is_empty (verify R C p (install_function R C p)))) R.
Obligation 1.
  assert (~Empty (proj1_sig `(verify R C p (install_function R C p)))).
  intro. apply (negb_prop_elim (is_empty (proj1_sig `(verify R C p (install_function R C p))))).
    apply Is_true_eq_left. apply (filter_2 (cpb_trim R C) H).
    apply Is_true_eq_left. apply is_empty_1. apply H0.
    exists (proj1_sig (verify R C p (install_function R C p))).
    split.
    elim (verify R C p (install_function R C p)). simpl.
    intros. elim p0. intros. rewrite (empty_is_empty_1 H1). apply subset_empty.
    intros. unfold is_install_set in H1. destruct H1. destruct H2. apply H2.
    generalize H0. clear H0. elim (verify R C p (install_function R C p)). simpl.
    intros. elim p0. intros. contradiction.
    intros. apply H1.
Qed.

Module EAux := Aux DepGraph.Edges.

Program Definition create_graph_strong_deps
  (R: PackageSet.t) (C: ConflictSet.t):
  { G: DepGraph.t |
     forall (p q: DepGraph.vertex), DepGraph.IsEdge (p, q) G <->
     strong_dep R C p q /\ ~Package.eq p q } :=
  PackageSet.fold (fun p_id acc =>
     let is := verify R C p_id (install_function R C p_id) in
     if (empty_dec is) then
       acc
     else
       PackageSet.fold (fun p' acc' =>
         if (IsEdge_dec (p_id, p') acc') then
           acc
         else
           (if (bool_dec (strong_dep_function R C p_id p') true) then
              add_edge (p_id, p') acc'
            else
              acc'
           )
       ) is acc
  ) (trim R C) DepGraph.empty.
Obligation 1.
  induction R using set_induction.
    (* R is empty *) assert (Empty (proj1_sig (trim R C))).
      intro. intro. apply (H a). apply (filter_1 (cpb_trim R C)). apply H0.
    rewrite (fold_1 _ DepGraph.empty _ H0). split.
      intros. absurd (IsEdge (p, q) DepGraph.empty). apply empty_edge. apply H1.
      intros. absurd (strong_dep R C p q).
        intro. destruct H2. elim H2. intros. absurd (is_install_set p R C x).
          intro. destruct H5. destruct H6. unfold Subset in H6. apply (H p). apply H6. apply H5.
          apply H4. destruct H1. apply H1.
(*    (* R = R2 = R1 + x *) assert (~In x (proj1_sig (trim R1 C))).
        intro. apply H. apply (filter_1 (cpb_trim R1 C)). apply H1. *)
    rewrite (fold_2 (x:=x) (s:=proj1_sig (trim R1 C)) (s':=proj1_sig (trim R2 C))).
      split. elim (empty_dec (proj1_sig (verify R2 C x (install_function R2 C x)))).
      intros. split. split.

Unset Implicit Arguments.


Require Import Arith.
Require Import ZArith.
Require Import List.
Import ListNotations.
Require Import Sorted.
Require Import Omega.
Require Import Psatz.

Require Import v1.NeutronTactics.
Require Import v1.Util.
Require Import v1.Multi.
Require Import v1.MForall.
Require Import v1.FloatAux.

Require epics.ControlFlow.
Require Import epics.Opcodes.
Require Import epics.Preservation.
Require Import epics.Step.
Require Import epics.Types.
Require Import epics.Records.
Require Import epics.Wf.
Require expr.Dbl.
Require Import expr.Expr.
Require Import floatabs.Records.
Require Import floatabs.RecordData.
Require floatabs.AbsExpr.
Require Import floatabs.AbsExprProofs.
Require Import util.ListLemmas.

Set Default Timeout 10.
Set Implicit Arguments.
Open Scope Z.

Module ER.
    Include epics.SpecRecords.
    Include epics.SpecRecordData.
    Include epics.SpecRecordSetters.
End ER.

Module Abs.
    Include floatabs.Records.
    Include floatabs.RecordData.
End Abs.

Module ExprAbs := floatabs.AbsExpr.

Module CF := epics.ControlFlow.

(* list lemmas *)

Lemma lookup_abs_type : forall dba dbt rn ra rt,
    dbt = database_abs_type dba ->
    rt = record_abs_type ra ->
    lookup_abs dba rn = Some ra ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrs;
destruct dba; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_abs_type_eq : forall dba dbt rn ra rt,
    dbt = database_abs_type dba ->
    lookup_abs dba rn = Some ra ->
    lookup_type dbt rn = Some rt ->
    rt = record_abs_type ra.
first_induction rn; intros0 Heqdbt Hls Hlt;
subst dbt; destruct dba; simpl in *; try congruence.
eapply IHrn; eauto.
Qed.

Inductive refine_val : abs_value -> value -> Prop :=
| RvTop : forall v, refine_val None v
| RvDouble : forall d z min max,
        fwhole_eq d z ->
        (min <= z <= max)%Z ->
        refine_val (Some (min, max)) (VDouble d)
| RvEnum : forall z pf min max,
        (min <= z <= max)%Z ->
        refine_val (Some (min, max)) (VEnum (EEnum z pf))
| RvLong : forall z pf min max,
        (min <= z <= max)%Z ->
        refine_val (Some (min, max)) (VLong (ELong z pf))
.

Inductive refine_record : record_abs -> record_state -> Prop :=
| RefineRecord : forall ra rs,
        record_abs_type ra = record_state_type rs ->
        (forall fn,
            forall va, Abs.read_field ra fn = Some va ->
            forall vs, read_field rs fn = Some vs ->
            refine_val va vs) ->
        refine_record ra rs.

Definition refine dba dbs :=
    Forall2 refine_record dba dbs.

Inductive wider : abs_value -> abs_value -> Prop :=
| WiderTop : forall a, wider a None
| WiderRange : forall min1 max1 min2 max2,
        min2 <= min1 ->
        max1 <= max2 ->
        wider (Some (min1, max1)) (Some (min2, max2)).

Definition check_wider : forall a a',
    { wider a a' } + { ~ wider a a' }.
destruct a, a'; try solve [ right; inversion 1 | left; econstructor ].
- destruct p as [min1 max1], p0 as [min2 max2].
  destruct (Z_le_dec min2 min1); [ | right; inversion 1; lia ].
  destruct (Z_le_dec max1 max2); [ | right; inversion 1; lia ].
  left. constructor; assumption.
Qed.

Lemma wider_refl : forall a, wider a a.
destruct a; try constructor.
destruct p; try constructor; lia.
Qed.

Lemma wider_trans : forall a1 a2 a3,
    wider a1 a2 ->
    wider a2 a3 ->
    wider a1 a3.
intros0 Hw12 Hw23.
invc Hw12; invc Hw23; constructor; lia.
Qed.

Lemma refine_val_wider : forall a a' v,
    refine_val a v ->
    wider a a' ->
    refine_val a' v.
destruct a, a', v; intros0 Hr Hw;
invc Hr; invc Hw; try solve [ econstructor ].
- econstructor.
  + eassumption.
  + lia.
- econstructor. lia.
- econstructor. lia.
Qed.

Lemma lookup_refine : forall dbs rn rs dba ra,
    refine dba dbs ->
    lookup dbs rn = Some rs ->
    lookup dba rn = Some ra ->
    refine_record ra rs.
unfold lookup, refine. intros.
eapply Forall2_nth_error; eauto.
Qed.

Lemma read_record_field_refine : forall dbs rn fn val dba ra a,
    refine dba dbs ->
    read_record_field dbs rn fn = Some val ->
    lookup dba rn = Some ra ->
    Abs.read_field ra fn = Some a ->
    refine_val a val.
intros0 Hr Hst_rrf Habs_rn Habs_fn.

unfold read_record_field in Hst_rrf.
destruct (lookup_state _ _) eqn:Hst_rn; [ | discriminate ].
simpl in Hst_rrf. rename Hst_rrf into Hst_fn.
forward eapply lookup_refine as HH; eauto.
invc HH. eauto.
Qed.

Lemma update_record_lookup_eq : forall f dbs rn dbs' rn' rs rs',
    update_record f dbs rn = Some dbs' ->
    lookup dbs rn' = Some rs ->
    lookup dbs' rn' = Some rs' ->
    rn = rn' ->
    f rs = Some rs'.
first_induction rn; intros0 Hup Hlook Hlook' Hrn; subst rn'.

- destruct dbs, dbs'; simpl in *; try discriminate.
  break_match; try discriminate.
  congruence.

- destruct dbs, dbs'; simpl in *; try discriminate.
  break_match; try discriminate.
  inject_some.
  specialize (IHrn ?? ?? ?? ?? ?? ?? ** ** ** ***). assumption.
Qed.

Lemma update_record_lookup_ne : forall f dbs rn dbs' rn' rs rs',
    update_record f dbs rn = Some dbs' ->
    lookup dbs rn' = Some rs ->
    lookup dbs' rn' = Some rs' ->
    rn <> rn' ->
    rs = rs'.
first_induction rn'; intros0 Hup Hlook Hlook' Hrn.

- destruct rn; try congruence.
  destruct dbs, dbs'; simpl in *; try discriminate.
  break_match; try discriminate.
  congruence.

- destruct dbs, dbs'; simpl in *; try discriminate.
  destruct rn.
  + break_match; try discriminate.
    congruence.
  + break_match; try discriminate.
    inject_some. eapply IHrn'; eauto.
Qed.

Lemma update_record_length : forall f dbs rn dbs',
    update_record f dbs rn = Some dbs' ->
    length dbs = length dbs'.
induction dbs; intros0 Hup; simpl in *; try discriminate.
break_match; break_match; try discriminate.

- destruct dbs'; inject_some. simpl. reflexivity.

- destruct dbs'; inject_some. simpl.
  specialize (IHdbs ?? ?? **). congruence.
Qed.

Lemma update_record_forall : forall f dbs rn dbs' rs0,
    update_record f dbs rn = Some dbs' ->
    lookup dbs rn = Some rs0 ->
    Forall2 (fun rs rs' => rs = rs' \/ (rs = rs0 /\ f rs = Some rs')) dbs dbs'.
intros0 Hup Hlook.
eapply nth_error_Forall2.
  { eauto using update_record_length. }
intros rn' rs rs' ? ?.
destruct (eq_nat_dec rn rn').
- right. split.
  + subst. unfold lookup in Hlook. congruence.
  + eapply update_record_lookup_eq; eauto.
- left.
  eapply update_record_lookup_ne; eauto.
Qed.

Lemma update_record_refine : forall dba f dbs rn dbs',
    (forall ra rs rs',
        lookup dba rn = Some ra ->
        lookup dbs rn = Some rs ->
        f rs = Some rs' ->
        refine_record ra rs ->
        refine_record ra rs') ->
    update_record f dbs rn = Some dbs' ->
    refine dba dbs ->
    refine dba dbs'.
first_induction dbs; destruct rn; intros0 Hf Hupd Href; try discriminate; simpl in *.
- rename a into rs. invc Href. rename x into ra. rename l into dba.
  destruct (f rs) as [ rs' | ] eqn:?; [ | discriminate Hupd ].
  inject_some.
  specialize (Hf ?? ?? ?? *** *** ** **).
  constructor; eauto.
- rename a into rs. invc Href. rename x into ra. rename l into dba.
  destruct (update_record _ _ _) as [ dbs'' | ] eqn:?; [ | discriminate Hupd ].
  inject_some.
  constructor; eauto.
  eapply IHdbs; eauto.
Qed.

Require Import ProofIrrelevance.

Lemma write_field_read_eq' : forall rs fn val rs',
    write_field rs fn val = Some rs' ->
    read_field rs' fn = Some val.
intros0 Hwf; destruct_record rs as [st]; destruct fn;
try discriminate Hwf.

all: destruct val; try discriminate Hwf.

all: cbv  [write_field bind_option unwrap_double unwrap_string unwrap_long unwrap_enum] in Hwf;
     try break_match; try discriminate;
     fancy_injr <- Hwf; destruct st;
     cbv -[multi_get multi_set];
     try rewrite multi_set_get; (* multi fields *)
     try reflexivity.

all: try solve [
    (* VArray handling *)
    simpl in *;
    do 2 (break_match; try discriminate);
    on (Some _ = Some _), invc; reflexivity
].

Qed.

Lemma write_field_read_eq : forall rs fn val rs' fn',
    write_field rs fn val = Some rs' ->
    fn = fn' ->
    read_field rs' fn' = Some val.
intros0 Hwf Hfn.  subst fn'.  eauto using write_field_read_eq'.
Qed.

Lemma write_field_read_ne : forall rs fn val rs' fn',
    write_field rs fn val = Some rs' ->
    fn <> fn' ->
    read_field rs fn' = read_field rs' fn'.
intros0 Hwf Hne; destruct_record rs as [st]; destruct fn;
try discriminate Hwf.

all: cbv  [write_field bind_option unwrap_double unwrap_string unwrap_long unwrap_enum] in Hwf;
     repeat break_match; try discriminate; (* both VEnum and other cases *)
     fancy_injr <- Hwf; destruct st;
     cbv -[multi_get multi_set];
     destruct fn'; try reflexivity; try congruence.

all: try solve [
    (* multi field case *)
    destruct i as [i Hi], i0 as [i0 Hi0];
    destruct (eq_nat_dec i i0);
        [ contradict Hne; subst; f_equal; f_equal; eapply proof_irrelevance | ];
    rewrite multi_set_get_other by (simpl; congruence);
    reflexivity
].

Qed.

Lemma write_field_refine : forall rs fn val rs' ra a,
    refine_record ra rs ->
    write_field rs fn val = Some rs' ->
    Abs.read_field ra fn = Some a ->
    refine_val a val ->
    refine_record ra rs'.
intros0 Hr Hst_fn Habs_fn Hrv.
invc Hr. constructor.  { erewrite <- write_field_preserves_state_type; eauto. }
intros fn' ? Habs_fn' ? Hst_fn'.
destruct (field_name_eq_dec fn fn').

- forward eapply write_field_read_eq with (fn := fn) (fn' := fn'); eauto.
  congruence.

- forward eapply write_field_read_ne with (fn := fn) (fn' := fn'); eauto.
  on _, eapply_; eauto. congruence.

Qed.

Lemma write_record_field_refine : forall dbs rn fn val dbs' dba ra a,
    refine dba dbs ->
    write_record_field dbs rn fn val = Some dbs' ->
    lookup dba rn = Some ra ->
    Abs.read_field ra fn = Some a ->
    refine_val a val ->
    refine dba dbs'.
intros0 Hr Hst_wrf Habs_rn Habs_fn Hrv.

unfold write_record_field in Hst_wrf.
unfold refine in *.

forward eapply lookup_length_ex with (ys := dbs) as HH; eauto using Forall2_length.
  destruct HH as [rs Hst_rn].
eapply nth_error_Forall2.
  { erewrite Forall2_length by eassumption. eauto using update_record_length. }
intros rn' ra' rs' Hra Hrs.
destruct (eq_nat_dec rn rn').

- subst rn'.
  replace ra' with ra in * by (unfold lookup in *; congruence).
  forward eapply update_record_lookup_eq; eauto. cbv beta in *.
  eapply write_field_refine; eauto.
  eapply Forall2_nth_error; eauto.

- forward eapply lookup_length_ex with (ys := dbs) as HH; eauto.
    symmetry. eauto using update_record_length.
    destruct HH as [rs0' Hrs0'].
  forward eapply update_record_lookup_ne with (rn := rn) (rn' := rn'); eauto.
  eapply Forall2_nth_error; eauto. subst. assumption.
Qed.

Definition convert_abs (a : abs_value) (old_ty new_ty : field_type) : abs_value :=
    (* In general, if precise conversions exist for all values in `a`, then the
       result is `a`.  Otherwise, the conversion result is unconstrained, and
       we return `None`. *)
    match old_ty, new_ty with
    | TDouble, TDouble => a
    | TDouble, TEnum =>
            if check_wider a (Some (0, ENUM_MAX - 1)%Z) then a else None
    | TDouble, TLong =>
            if check_wider a (Some (-LONG_MAX, LONG_MAX - 1)%Z) then a else None
    | TDouble, _ => None

    | TEnum, TDouble => a
    | TEnum, TEnum => a
    | TEnum, TLong => a
    | TEnum, _ => None

    | TLong, TDouble => a
    | TLong, TEnum =>
            if check_wider a (Some (0, ENUM_MAX - 1)%Z) then a else None
    | TLong, TLong => a
    | TLong, _ => None

    | _, _ => None (* strings and arrays *)
    end.

Lemma convert_abs_top : forall old_ty new_ty,
    convert_abs None old_ty new_ty = None.
intros.
destruct old_ty, new_ty; simpl; try reflexivity.
all: break_match; reflexivity.
Qed.

Lemma convert_value_refine : forall v a ty v',
    refine_val a v ->
    convert_value v ty v' ->
    refine_val (convert_abs a (value_type v) ty) v'.
intros0 Hrv Hconv. invc Hrv.

- rewrite convert_abs_top. constructor.

- destruct ty; simpl; try constructor.
  all: try break_match; try constructor.
  all: unfold convert_value in Hconv; break_and.
  all: try on >wider, invc.
  all: rename H2 into Hconv.

  + subst. econstructor; eauto.

  + erewrite B2Z_safe_complete in * by eassumption.
    assert (0 <= z < ENUM_MAX). { unfold ENUM_MAX. lia. }
    rewrite (Hconv **).
    constructor. eauto.

  + erewrite B2Z_safe_complete in * by eassumption.
    assert (-LONG_MAX <= z < LONG_MAX). { unfold LONG_MAX. lia. }
    rewrite (Hconv **).
    constructor. eauto.

- destruct ty; simpl; try constructor.
  all: try break_match; try constructor.
  all: unfold convert_value in Hconv; break_and.
  all: try on >wider, invc.
  all: rename H1 into Hconv.

  + rewrite Hconv by lia.
    econstructor; eauto.
    eapply fwhole_eq_Z2B. rewrite Z.abs_lt.
    change (53 - 1) with 52.
    unfold ENUM_MAX in *.  lia.

  + rewrite Hconv.
    constructor; eauto.

  + rewrite Hconv.
    constructor; eauto.

- destruct ty; simpl; try constructor.
  all: try break_match; try constructor.
  all: unfold convert_value in Hconv; break_and.
  all: try on >wider, invc.
  all: rename H1 into Hconv.

  + rewrite Hconv by lia.
    econstructor; eauto.
    eapply fwhole_eq_Z2B. rewrite Z.abs_lt.
    change (53 - 1) with 52.
    unfold LONG_MAX in *.  lia.

  + rewrite (Hconv ltac:(unfold ENUM_MAX in *; lia)).
    constructor; eauto.

  + rewrite Hconv.
    constructor; eauto.

Qed.

Inductive error :=
| ENoRecord : record_name -> error
| ENoField : field_name -> error
| ENotCalc : record_name -> error
| EBadExpr : record_name -> error
| ENotWider : abs_value -> abs_value -> error
| EBadConst : value -> abs_value -> error
| EBadType : field_type -> field_type -> error
| ENotImplemented : micro -> error
| ELenMismatch : nat -> nat -> error

| EInOpcode : micro -> error -> error
| EInRecord : record_name -> error -> error
.

Definition in_context {A} (ctx : error -> error) (r : A + list error) : A + list error :=
    match r with
    | inl x => inl x
    | inr e => inr (map ctx e)
    end.

Ltac die x := right; exact x.
Ltac die_auto :=
    match goal with
    | [ e : list error |- _ ] => die e
    end.
Ltac die_ctx c :=
    match goal with
    | [ e : list error |- _ ] => apply (in_context c); die e
    end.

Definition check_refine_const : forall a v,
    { refine_val a v } + { ~ refine_val a v }.
destruct a, v; try solve [left; constructor | right; inversion 1].

- rename e into x.
  destruct (B2Z_safe x) as [ z | ] eqn:?; cycle 1.
    { right. inversion 1. forward eapply B2Z_safe_complete; eauto. congruence.  }

  destruct p as [min max].
  destruct (Z_le_gt_dec min z); cycle 1.
    { right. inversion 1. forward eapply B2Z_safe_complete; eauto.
      replace z0 with z in * by congruence. lia. }
  destruct (Z_le_gt_dec z max); cycle 1.
    { right. inversion 1. forward eapply B2Z_safe_complete; eauto.
      replace z0 with z in * by congruence. lia. }

  left. econstructor; eauto using B2Z_safe_correct.

- destruct e. rename val into z.

  destruct p as [min max].
  destruct (Z_le_gt_dec min z); cycle 1.
    { right. inversion 1. lia. }
  destruct (Z_le_gt_dec z max); cycle 1.
    { right. inversion 1. lia. }

  left. econstructor. eauto.

- destruct e. rename val into z.

  destruct p as [min max].
  destruct (Z_le_gt_dec min z); cycle 1.
    { right. inversion 1. lia. }
  destruct (Z_le_gt_dec z max); cycle 1.
    { right. inversion 1. lia. }

  left. econstructor. eauto.
Qed.

Definition db_step_ok dba rn op :=
    forall dbs dbs',
    database_state_type dbs = database_abs_type dba ->
    refine dba dbs ->
    db_step rn op dbs dbs' ->
    refine dba dbs'.

Definition check_set_const : forall dba rn fn val,
    db_step_ok dba rn (MSetConst fn val) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (Abs.read_field ra fn) as [dest_abs | ] eqn:?; [ | die [ENoField fn] ].
destruct (check_refine_const dest_abs val); [ | die [EBadConst val dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
Defined.

Definition check_copy : forall dba rn fn_src src_ty fn_dest dest_ty,
    db_step_ok dba rn (MCopy fn_src src_ty fn_dest dest_ty) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (Abs.read_field ra fn_src) as [src_abs | ] eqn:?; [ | die [ENoField fn_src] ].
destruct (Abs.read_field ra fn_dest) as [dest_abs | ] eqn:?; [ | die [ENoField fn_dest] ].
set (conv_abs := convert_abs src_abs src_ty dest_ty).
destruct (check_wider conv_abs dest_abs); [ | die [ENotWider conv_abs dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
eapply refine_val_wider; try eassumption.
eapply convert_value_refine; eauto.
eapply read_record_field_refine; try eassumption.
Defined.

Definition check_read_link : forall dba rn il il_ty fn f_ty,
    db_step_ok dba rn (MReadLink il il_ty fn f_ty) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (lookup dba (fl_rn il)) as [ra' | ] eqn:?; [ | die [ENoRecord (fl_rn il)] ].
destruct (Abs.read_field ra' (fl_fn il)) as [src_abs | ] eqn:?; [ | die [ENoField (fl_fn il)] ].
destruct (Abs.read_field ra fn) as [dest_abs | ] eqn:?; [ | die [ENoField fn] ].
set (conv_abs := convert_abs src_abs il_ty f_ty).
destruct (check_wider conv_abs dest_abs); [ | die [ENotWider conv_abs dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
eapply refine_val_wider; try eassumption.
eapply convert_value_refine; eauto.
eapply read_record_field_refine; try eassumption.
Defined.

Definition check_write_link : forall dba rn fn f_ty ol ol_ty,
    db_step_ok dba rn (MWriteLink fn f_ty ol ol_ty) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (lookup dba (fl_rn ol)) as [ra' | ] eqn:?; [ | die [ENoRecord (fl_rn ol)] ].
destruct (Abs.read_field ra fn) as [src_abs | ] eqn:?; [ | die [ENoField fn] ].
destruct (Abs.read_field ra' (fl_fn ol)) as [dest_abs | ] eqn:?; [ | die [ENoField (fl_fn ol)] ].
set (conv_abs := convert_abs src_abs f_ty ol_ty).
destruct (check_wider conv_abs dest_abs); [ | die [ENotWider conv_abs dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
eapply refine_val_wider; try eassumption.
eapply convert_value_refine; eauto.
eapply read_record_field_refine; try eassumption.
Defined.

Definition check_calc : forall ra,
    { a2l, val | ra = RaCalc (CalcAbs a2l val) } +
    { forall abs, ra <> RaCalc abs }.
intros.
destruct_record_abs ra; try solve [right; intros; discriminate ].
- left. destruct a. eexists. reflexivity.
Qed.

Definition check_list : forall A (P : A -> Prop) xs
        (check_one : forall x, P x + list error),
    Forall P xs + list error.
induction xs; intros.
- left. constructor.
- rename a into x.
  destruct (check_one x); [ | die_auto ].
  destruct (IHxs check_one); [ | die_auto ].
  left. constructor; eauto.
Defined.

Definition check_multi : forall n (A : Set) (P : A -> Prop) (x : multi n A)
        (check_one : forall x, P x + list error),
    MForall P x + list error.
intros.
destruct (check_list P (multi_to_list x) check_one); [ | die_auto ].
left. rewrite MForall_Forall. auto.
Defined.

Definition check_list2 : forall A B (P : A -> B -> Prop) xs ys
        (check_one : forall x y, P x y + list error),
    Forall2 P xs ys + list error.
induction xs; destruct ys; intros.
- left. constructor.
- die [ELenMismatch 0 (S (length ys))].
- die [ELenMismatch (S (length xs)) 0].
- rename a into x. rename b into y.
  destruct (check_one x y); [ | die_auto ].
  destruct (IHxs ys check_one); [ | die_auto ].
  left. constructor; eauto.
Defined.

Definition check_multi2 : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi n A) (y : multi n B)
        (check_one : forall x y, P x y + list error),
    MForall2 P x y + list error.
intros.
destruct (check_list2 P (multi_to_list x) (multi_to_list y) check_one); [ | die_auto ].
left. rewrite MForall2_Forall2. auto.
Defined.

Definition check_wider' : forall val val',
    wider val val' + list error.
intros.
destruct (check_wider val val'); [ | die [ENotWider val val'] ].
left. auto.
Qed.

Definition state_A_to_L s :=
    match s with
    | RsCalc st => Some (ER.calc_A_to_L st)
    | RsCalcOut st => Some (ER.calc_out_A_to_L st)
    | _ => None
    end.

Definition abs_A_to_L a :=
    match a with
    | RaCalc abs => Some (Abs.calc_A_to_L abs)
    | RaCalcOut abs => Some (Abs.calc_out_A_to_L abs)
    | _ => None
    end.

Lemma abs_A_to_L_ex : forall rs ra sa2l,
    refine_record ra rs ->
    state_A_to_L rs = Some sa2l ->
    exists aa2l, abs_A_to_L ra = Some aa2l.
intros0 Hrefine Hsa2l.
destruct_record rs as [st]; try discriminate Hsa2l; destruct st.
all: simpl in Hsa2l; inject_some.
all: invc Hrefine; unfold record_state_type in *.
all: destruct_record_abs ra as [abs]; try discriminate; destruct abs.
all: eexists; reflexivity.
Qed.

Lemma run_calculate_record_effect : forall f fn_out rs rs',
    run_calculate_record f fn_out rs = Some rs' ->
    exists a2l a2l' out',
        state_A_to_L rs = Some a2l /\
        f a2l = (a2l', out') /\
        state_A_to_L rs' = Some a2l' /\
        read_field rs' fn_out = Some (VDouble out').
intros0 Hrun.

destruct_record rs as [ st ]; try discriminate.
all: destruct st; simpl in Hrun.
all: destruct (f _) as (a2l', out') eqn:?.
all: destruct fn_out; try discriminate.
all: inject_some; simpl.
all: eauto 7.
Qed.

Lemma run_calculate_record_preserved : forall f fn_out rs rs' fn,
    run_calculate_record f fn_out rs = Some rs' ->
    (forall i, fn <> f_A_to_L i) ->
    fn <> fn_out ->
    read_field rs' fn = read_field rs fn.
intros0 Hrun Ha2l Hval.
destruct_record rs as [ st ]; try discriminate.
all: destruct st; simpl in Hrun.
all: destruct (f _) as (a2l', out').
all: destruct fn_out; try discriminate.
all: inject_some; simpl.
all: destruct fn; try solve [exfalso; congruence | reflexivity].
Qed.

Lemma A_to_L_state_read_field : forall rs a2l i val,
    state_A_to_L rs = Some a2l ->
    read_field rs (f_A_to_L i) = Some (VDouble val) <-> (a2l !! i) = val.
intros0 Ha2l.
destruct_record rs as [st]; try discriminate; destruct st.
all: simpl in Ha2l; inject_some.
all: compute -[multi_get].
all: intuition congruence.
Qed.

Lemma A_to_L_abs_read_field : forall ra a2l i val,
    abs_A_to_L ra = Some a2l ->
    Abs.read_field ra (f_A_to_L i) = Some val <-> (a2l !! i) = val.
intros0 Ha2l.
destruct_record_abs ra as [abs]; try discriminate; destruct abs.
all: simpl in Ha2l; inject_some.
all: compute -[multi_get].
all: intuition congruence.
Qed.

Lemma A_to_L_MForall2 : forall (P : _ -> _ -> Prop) rs ra sa2l aa2l,
    state_A_to_L rs = Some sa2l ->
    abs_A_to_L ra = Some aa2l ->
    (forall i sv av,
        read_field rs (f_A_to_L i) = Some (VDouble sv) ->
        Abs.read_field ra (f_A_to_L i) = Some av ->
        P sv av) <->
    MForall2 P sa2l aa2l.
intros0 Hrs Hra. split; intro HH.

- rewrite MForall2_forall. intros. subst. eapply HH.
  + rewrite A_to_L_state_read_field; eauto.
  + rewrite A_to_L_abs_read_field; eauto.

- rewrite MForall2_forall in HH. intros. eapply HH.
  + rewrite <- A_to_L_state_read_field; eauto.
  + rewrite <- A_to_L_abs_read_field; eauto.
Qed.

Lemma refine_val_double_iff' : forall dty aty dbl abs,
    (match dty as dty_, aty as aty_
        return ty_denote floatabs.AbsExprProofs.D dty_ ->
               ty_denote floatabs.AbsExprProofs.A aty_ -> Prop with
    | expr.Dbl.Nil, ExprAbs.Nil => fun dbl abs => True
    | expr.Dbl.Dbl, ExprAbs.Abs => fun dbl abs => refine_val abs (VDouble dbl)
    | _, _ => fun dbl abs => False
    end) dbl abs <->
    floatabs.AbsExprProofs.refine_value dty aty dbl abs.
intros. split; intro HH.
- destruct dty, aty; try solve [exfalso; auto].
  + destruct dbl, abs. constructor.
  + invc HH; do 2 econstructor; eauto.
- destruct HH; auto.
  on >floatabs.AbsExprProofs.refine_dbl, invc.
  all: econstructor; eauto.
Qed.

Lemma refine_val_double_iff : forall dbl abs,
    refine_val abs (VDouble dbl) <->
    floatabs.AbsExprProofs.refine_value expr.Dbl.Dbl ExprAbs.Abs dbl abs.
intros.
rewrite <- refine_val_double_iff'. split; auto.
Qed.
Hint Rewrite -> refine_val_double_iff.
Hint Rewrite <- refine_val_double_iff.

Lemma refine_record_A_to_L : forall ra rs aa2l sa2l,
    refine_record ra rs ->
    abs_A_to_L ra = Some aa2l ->
    state_A_to_L rs = Some sa2l ->
    MForall2 (fun s a => refine_val a (VDouble s)) sa2l aa2l.
intros. erewrite <- A_to_L_MForall2; eauto.
intros. on >refine_record, invc.  eauto.
Qed.

Lemma refine_record_A_to_L' : forall ra rs aa2l sa2l,
    refine_record ra rs ->
    abs_A_to_L ra = Some aa2l ->
    state_A_to_L rs = Some sa2l ->
    MForall2 (floatabs.AbsExprProofs.refine_value expr.Dbl.Dbl ExprAbs.Abs) sa2l aa2l.
intros. forward eapply refine_record_A_to_L; eauto.
rewrite -> MForall2_Forall2 in *.
compute -[multi_to_list e_double abs_value]. (* modifies implicit arguments *)
remember (multi_to_list sa2l) as sa2l'.
remember (multi_to_list aa2l) as aa2l'.
try rewrite <- Heqaa2l' in *.
(* `remember` should do this, but there's an issue with the implicits in 8.5pl1 *)
list_magic_on (sa2l', (aa2l', tt)).
rewrite <- refine_val_double_iff. auto.
Qed.

Definition is_A_to_L_dec : forall fn,
    { i | fn = f_A_to_L i } + { ~ exists i, fn = f_A_to_L i }.
destruct fn; try solve [ right; inversion 1; discriminate ].
left; eauto.
Defined.

Lemma run_calculate_record_refine : forall expr f f' fn_out rs rs' ra a2l a2l' out out',
    expr.Dbl.denote expr = Some f ->
    ExprAbs.denote expr = Some f' ->
    f' a2l = (a2l', out') ->
    abs_A_to_L ra = Some a2l ->
    MForall2 wider a2l' a2l ->
    Abs.read_field ra fn_out = Some out ->
    wider out' out ->
    refine_record ra rs ->
    run_calculate_record f fn_out rs = Some rs' ->
    refine_record ra rs'.
intros0 Hf Hf' Hcalc' Hra_a2l Ha2l Hra_out Hout Hrefine Hcalc_rec.
inv Hrefine. rename H0 into Hrefine'. constructor.
  { erewrite <- run_calculate_record_preserves_state_type; eauto. }
intros0 Hread. intros0 Hread'.
specialize (Hrefine' _ _ Hread).

forward eapply run_calculate_record_effect as HH; eauto.
  destruct HH as (sa2l & sa2l' & sout' & ? & ? & ? & ?).

forward eapply floatabs.AbsExprProofs.denote_refine as HH; eauto.
  destruct HH as (f'' & ? & ?).
  replace f'' with f' in * by congruence.
forward refine (floatabs.AbsExprProofs.refine_state_fn_noxvar_dbl_abs_inv _ _ _)
    as Hfrel; eauto.
do 6 spec_evar Hfrel. spec_assert Hfrel; [ | do 2 spec Hfrel by eassumption ].
  { eapply refine_record_A_to_L'; eauto. }
destruct Hfrel as [Hrel_a2l Hrel_out].

destruct (field_name_eq_dec fn fn_out).
  { subst fn.
    replace va with out in * by congruence.
    eapply refine_val_wider; eauto.
    replace vs with (VDouble sout') in * by congruence.
    rewrite refine_val_double_iff. auto. }

destruct (is_A_to_L_dec fn) as [ [i ?] | ? ].
  { subst fn.
    remember (sa2l' !! i) as vdbl. symmetry in Heqvdbl.
    rewrite <- A_to_L_state_read_field in Heqvdbl by eauto.
    rewrite A_to_L_abs_read_field in Hread by eauto.
    replace vs with (VDouble vdbl) by congruence.
    rewrite A_to_L_state_read_field in Heqvdbl by eauto.
    subst va. subst vdbl.
    eapply refine_val_wider; cycle 1.  { eapply MForall2_get; try eassumption. }
    rewrite refine_val_double_iff. eapply MForall2_get. auto. }

  { eapply Hrefine'.
    erewrite <- run_calculate_record_preserved; try eassumption.
    intros. intro. on _, eapply_. eauto. }

Timeout 20 Qed.

Definition check_calculate : forall dba rn expr fn_out,
    db_step_ok dba rn (MCalculate expr fn_out) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (abs_A_to_L ra) as [a2l_abs | ] eqn:?; [ | die [ENotCalc rn] ].
destruct (Abs.read_field ra fn_out) as [out_abs | ] eqn:?; [ | die [ENoField fn_out] ].
destruct (ExprAbs.denote expr) as [ calc | ] eqn:?; [ | die [EBadExpr rn] ].
destruct (calc a2l_abs) as [a2l' out'] eqn:?.
destruct (check_multi2 _ _ a2l' a2l_abs check_wider'); [ | die_auto ].
destruct (check_wider out' out_abs); [ | die [ENotWider out' out_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
unfold run_calculate in *.
eapply update_record_refine; try eassumption. intros.
replace ra0 with ra in * by congruence.
eapply run_calculate_record_refine; try eassumption.
Defined.

Definition check_hw_read : forall dba rn fn f_ty,
    db_step_ok dba rn (MHwRead fn f_ty) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (Abs.read_field ra fn) as [dest_abs | ] eqn:?; [ | die [ENoField fn] ].
destruct (check_wider None dest_abs); [ | die [ENotWider None dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
eapply refine_val_wider; try eassumption.
constructor.
Defined.

Definition check_unk_read : forall dba rn fn f_ty,
    db_step_ok dba rn (MUnkRead fn f_ty) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
destruct (Abs.read_field ra fn) as [dest_abs | ] eqn:?; [ | die [ENoField fn] ].
destruct (check_wider None dest_abs); [ | die [ENotWider None dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
eapply refine_val_wider; try eassumption.
constructor.
Defined.

Definition check_unk_write : forall dba rn,
    db_step_ok dba rn (MUnkWrite) + list error.
intros.

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
assumption.
Defined.

Definition check_havoc_write : forall dba rn ol ol_ty,
    db_step_ok dba rn (MHavocWrite ol ol_ty) + list error.
intros.
destruct (lookup dba (fl_rn ol)) as [ra | ] eqn:?; [ | die [ENoRecord (fl_rn ol)] ].
destruct (Abs.read_field ra (fl_fn ol)) as [dest_abs | ] eqn:?; [ | die [ENoField (fl_fn ol)] ].
destruct (check_wider None dest_abs); [ | die [ENotWider None dest_abs] ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply write_record_field_refine; try eassumption.
eapply refine_val_wider; try eassumption.
constructor.
Defined.

Lemma read_field_has_field : forall ra fn abs,
    Abs.read_field ra fn = Some abs ->
    exists ty, record_has_field (record_abs_type ra) fn ty.
destruct fn, ra; intros0 Hrf; try discriminate Hrf.
all: eexists; constructor; reflexivity.
Qed.

Definition check_havoc_update : forall dba rn,
    db_step_ok dba rn (MHavocUpdate) + list error.
intros.
destruct (lookup dba rn) as [ra | ] eqn:?; [ | die [ENoRecord rn] ].
forward eapply check_list with (xs := all_fields)
    (P := fun fn => Abs.read_field ra fn = None \/ Abs.read_field ra fn = Some None)
    as HH.
  { intro fn.
    destruct (Abs.read_field ra fn) as [abs | ] eqn:?; [ | left; solve [auto] ].
    destruct abs eqn:?; [ die [ENotWider None abs] | ].
    left. auto. }
  destruct HH; [ | die_auto ].

left. unfold db_step_ok. intros0 Hty Hr Hstep. invc Hstep.
eapply update_record_refine; eauto.
intros.
replace ra0 with ra in * by congruence.  clear ra0.
replace rs0 with rs in * by congruence.  clear rs0.
replace rs'0 with rs' in * by congruence.  clear rs'0.

on >refine_record, invc.
constructor. { congruence. }
intros.

assert (In fn all_fields).
  { forward eapply read_field_has_field; eauto. break_exists.
    eauto using in_all_fields. }
on >Forall, fun H => rename H into Hfa. rewrite Forall_forall in Hfa.
specialize (Hfa ?? **). destruct Hfa.
  { find_rewrite. discriminate. }
find_rewrite.
(* A lot of tactics are extremely slow at this poirt for some reason.
   Even `on (Some _ = Some va), fun H => clear -H` times out... *)
generalize dependent va. clear. intros.
inject_some. constructor.
Qed.

Definition check_db_step : forall dba rn op,
    db_step_ok dba rn op + list error.
intros.
destruct op eqn:?;
try solve [left; inversion 3]. (* trivial result for unsupported ops *)

- eapply check_set_const.
- eapply check_copy.
- eapply check_read_link.
- eapply check_write_link.
- eapply check_calculate.
- eapply check_hw_read.
- eapply check_unk_read.
- eapply check_unk_write.
- eapply check_havoc_update.
- eapply check_havoc_write.
Defined.

Definition step_ok dba rn op :=
    forall dbp dbs dbs' stk code stk' oes,
    let state := State dbs (Frame rn (op :: code) :: stk) in
    let state' := State dbs' stk' in
    database_state_type dbs = database_abs_type dba ->
    refine dba dbs ->
    step dbp state state' oes ->
    refine dba dbs'.

Lemma db_op_output_op_disjoint : forall op,
    is_db_op op = true ->
    is_output_op op = true ->
    False.
destruct op; simpl; intros; congruence.
Qed.

Definition check_step' : forall dba rn op,
    step_ok dba rn op + list error.
intros.
eapply (in_context (EInRecord rn)).
eapply (in_context (EInOpcode op)).
destruct (is_db_op op) eqn:?;
destruct (is_output_op op) eqn:?;
try solve [exfalso; eapply db_op_output_op_disjoint; eassumption].
3: destruct op eqn:?; try solve [exfalso; discriminate].

- (* db_step *)
  destruct (check_db_step dba rn op) as [Hok | ?]; [ | die_auto ].

  left. unfold step_ok. intros0 Hty Hr Hstep.
  invc Hstep; try discriminate; cycle 1.
    { destruct op; try discriminate; on >output_step, invc. }
  eapply Hok; eauto.

- (* output_step *)
  left. unfold step_ok. intros0 Hty Hr Hstep.
  invc Hstep; try discriminate.
    { destruct op; try discriminate; on >db_step, invc. }
  assumption.

- (* Process *)
  left. unfold step_ok. intros0 Hty Hr Hstep.
  invc Hstep; [on >db_step, invc | on >output_step, invc | ].
  assumption.

- (* CalcCond *)
  left. unfold step_ok. intros0 Hty Hr Hstep.
  invc Hstep; [on >db_step, invc | on >output_step, invc | | ].
  all: assumption.

- (* CheckPACT *)
  left. unfold step_ok. intros0 Hty Hr Hstep.
  invc Hstep; [on >db_step, invc | on >output_step, invc | | ].
  all: assumption.

- (* HavocProcess *)
  left. unfold step_ok. intros0 Hty Hr Hstep.
  invc Hstep; [on >db_step, invc | on >output_step, invc | | ].
  all: assumption.

Defined.

Definition check_step : forall dba rn op,
    MicroForall (step_ok dba rn) op + list error.
intros ? ?.
induction op using micro_rect_mut with
    (Pl := fun ops => (Forall (MicroForall (step_ok dba rn)) ops + list error)%type).

all: try match goal with
| [ |- (MicroForall _ ?op + _)%type ] =>
        destruct (check_step' dba rn op); [ | die_auto ]
end.

(* flat opcodes - just use the proof we got from the check_step' call *)
all: try solve [ left; eapply MfOther; auto ].

- (* CalcCond *)
  destruct IHop; [ | die_auto ].
  left. constructor; auto.

- (* ScheduleCallback *)
  destruct IHop; [ | die_auto ].
  left. constructor; auto.

- (* nil *)
  left. constructor.

- (* cons *)
  destruct IHop; [ | die_auto ].
  destruct IHop0; [ | die_auto ].
  left. constructor; auto.
Defined.

Definition record_program_ok dba rn rp :=
    Forall (MicroForall (step_ok dba rn)) (rp_code rp).

Fixpoint database_program_ok' dba rn dbp :=
    match dbp with
    | [] => True
    | rp :: dbp => record_program_ok dba rn rp /\ database_program_ok' dba (S rn) dbp
    end.

Definition database_program_ok dba dbp :=
    database_program_ok' dba 0%nat dbp.

Definition check_record_program : forall dba rn rp,
    record_program_ok dba rn rp + list error.
intros. destruct rp. induction rp_code.

- left. constructor.

- rename a into op.
  destruct (check_step dba rn op) as [Hop | errs1];
  destruct IHrp_code as [Hops | errs2].
  + left. constructor; assumption.
  + right; exact errs2.
  + right; exact errs1.
  + right; exact (errs1 ++ errs2).
Defined.

Definition check_database_program' : forall dba rn dbp,
    database_program_ok' dba rn dbp + list error.
intros. generalize dependent rn. induction dbp; intros.

- left. exact I.

- rename a into rp.
  destruct (check_record_program dba rn rp) as [Hr | errs1];
  destruct (IHdbp (S rn)) as [Hrs | errs2].
  + left. split; assumption.
  + right; exact errs2.
  + right; exact errs1.
  + right; exact (errs1 ++ errs2).
Defined.

Definition check_database_program : forall dba dbp,
    database_program_ok dba dbp + list error.
intros.
eapply check_database_program'.
Defined.

Open Scope nat_scope.

Lemma database_program_ok'_lookup : forall dba dbp rn_base rn rp,
    database_program_ok' dba rn_base dbp ->
    lookup dbp rn = Some rp ->
    record_program_ok dba (rn_base + rn)%nat rp.
first_induction dbp; intros0 Hok Hlook.
  { destruct rn; simpl in Hlook; discriminate. }
invc Hok. destruct rn.
  { simpl in *. inject_some.
    unfold record_name in rn_base.
    replace ((rn_base + 0)%nat) with rn_base by lia. assumption. }

specialize (IHdbp ?? ?? ?? ?? ** **).
replace (rn_base + S rn) with (S rn_base + rn) by lia. assumption.
Qed.

Lemma database_program_ok_lookup : forall dba dbp rn rp,
    database_program_ok dba dbp ->
    lookup dbp rn = Some rp ->
    record_program_ok dba rn rp.
intros. eapply database_program_ok'_lookup with (rn_base := 0); eauto.
Qed.

Theorem step_preserves_refine : forall dba dbp state state' oes,
    let dbt := database_program_type dbp in
    database_state_type (state_dbs state) = dbt ->
    database_abs_type dba = dbt ->
    CF.state_ok dbp state ->
    database_program_ok dba dbp ->
    refine dba (state_dbs state) ->
    step dbp state state' oes ->
    refine dba (state_dbs state').
intros0 Hdbs_ty Hdba_ty Hcontrol Hprog Hstate Hstep.

destruct state, state_stk; simpl in *.
  { invc Hstep. }

on >CF.state_ok, invc.
on >CF.frame_ok, invc.
forward eapply database_program_ok_lookup; eauto.
unfold record_program_ok in *.
forward eapply CF.suffix_forall; eauto.

destruct f. simpl in *.
destruct frame_code as [| op ?]; simpl in *.
  { (* pop *) invc Hstep. simpl. assumption. }
on (Forall _ (op :: _)), invc.
assert (Hok : step_ok dba frame_rn op) by (eapply forall_one; assumption).

unfold step_ok in Hok.
destruct state'. simpl in *.
eapply Hok; try exact Hstep; eauto. congruence.
Qed.

Theorem star_step_preserves_refine : forall dba dbp state state' oes,
    let dbt := database_program_type dbp in
    database_state_type (state_dbs state) = dbt ->
    database_abs_type dba = dbt ->
    CF.state_ok dbp state ->
    database_program_ok dba dbp ->
    refine dba (state_dbs state) ->
    star_step dbp state state' oes ->
    refine dba (state_dbs state').
induction 6.
- eauto using step_preserves_refine.
- eapply IHstar_step; eauto.
  + erewrite <- step_preserves_state_type by eassumption. assumption.
  + eauto using CF.step_state_ok.
  + eauto using step_preserves_refine.
Qed.

Definition float_abs_check dbp dba :=
    check_database_program dba dbp.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^235 - 15
Base: 23.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 23 + 1/2;
    bitwidth := 32;
    s := 2^235;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.tests.Thread0 Bedrock.Platform.tests.WebServer Bedrock.Platform.Bootstrap.

Module Type HIDE.
  Parameter heapSize4 : N -> N.
  Axiom heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.

  Parameter to_nat : N -> nat.
  Axiom to_nat_eq : to_nat = N.to_nat.
End HIDE.

Module Hide : HIDE.
  Definition heapSize4 n := (n * 4)%N.
  Theorem heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.
    auto.
  Qed.

  Definition to_nat := N.to_nat.
  Theorem to_nat_eq : to_nat = N.to_nat.
    auto.
  Qed.
End Hide.

Module Type S.
  Parameter heapSize : N.
  Parameters port numWorkers : W.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%N.
  Definition globalSock : W := globalSched ^+ $4.
  Definition globalTree : W := globalSched ^+ $8.
  Definition globalPages : W := globalSched ^+ $12.

  Definition port := M.port.
  Definition numWorkers := M.numWorkers.

  Definition inbuf_size := 256.

  Theorem inbuf_size_lower : (inbuf_size >= 2)%nat.
    unfold inbuf_size; auto.
  Qed.

  Theorem inbuf_size_upper : (N_of_nat (inbuf_size * 4) < Npow2 32)%N.
    reflexivity.
  Qed.
End M'.

Import M'.

Module E := WebServer.Make(M').
Import E.

Section boot.
  Definition heapSize' := Hide.to_nat heapSize.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%N.

  Let heapSizeLowerBound' : (3 <= heapSize')%nat.
    intros; unfold heapSize'; rewrite Hide.to_nat_eq.
    assert (heapSize >= 3)%N by (apply N.le_ge; auto); nomega.
  Qed.

  Definition size := heapSize' + 50 + 3.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize' * 4).
    goodSize.
  Qed.

  Lemma heapSizeLowerBound'' : natToW 3 <= NToW heapSize.
    hnf; intros.
    red in H.
    pre_nomega.
    rewrite wordToNat_natToWord_idempotent in H by reflexivity.
    unfold heapSize' in *.
    rewrite Hide.to_nat_eq in *.
    unfold NToW in *.
    rewrite NToWord_nat in *.
    rewrite wordToNat_natToWord_idempotent in H.
    omega.
    rewrite N2Nat.id.
    eapply goodSize_weaken in mem_size.
    2: instantiate (1 := N.to_nat heapSize); unfold size.
    Transparent goodSize.
    unfold goodSize in *.
    rewrite N2Nat.id in *.
    assumption.
    unfold heapSize'.
    rewrite Hide.to_nat_eq.
    omega.
  Qed.

  Hint Immediate heapSizeLowerBound''.

  Definition bootS := {|
    Reserved := 49;
    Formals := nil;
    Precondition := fun _ => st ~> Ex n, ![ 0 =?> (heapSize' + 50 + 3) * strings n globalPages ] st
  |}.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "web"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%N;;

        Assert [Al n, PREmain[_] 0 =?> heapSize' * globalSched =?> 3 * strings n globalPages ];;

        Call "malloc"!"init"(0, heapSize)
        [Al n, PREmain[_] globalSched =?> 1 * globalSock =?> 1 * globalTree =?> 1 * strings n globalPages
          * mallocHeap 0];;

        Goto "web"!"main"
      end
    }}.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = (heapSize' * 4)%nat
    -> goodSize (heapSize' * 4)
    -> False.
    intros; eapply bootstrap_Sp_nonzero; try eassumption; eauto.
  Qed.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = (heapSize' * 4)%nat
    -> freeable sp 50.
    intros; eapply bootstrap_Sp_freeable; try eassumption; eauto.
  Qed.

  Lemma noWrap : noWrapAround 4 (wordToNat (NToW heapSize) - 1).
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize' in *; rewrite Hide.to_nat_eq in *.
    rewrite wordToNat_natToWord_idempotent.
    apply noWrap; eauto.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Local Hint Immediate bootstrap_Sp_nonzero bootstrap_Sp_freeable noWrap.

  Lemma break : NToW ((heapSize + 50) * 4)%N = ((heapSize' + 50) * 4)%nat.
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; rewrite N2Nat.inj_add; auto.
  Qed.

  Lemma times4 : (Hide.heapSize4 heapSize : W) = (heapSize' * 4)%nat.
    rewrite Hide.heapSize4_eq; intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; auto.
  Qed.

  Lemma wordToNat_heapSize : wordToNat (NToW heapSize) = heapSize'.
    unfold heapSize'; rewrite Hide.to_nat_eq.
    unfold NToW.
    rewrite NToWord_nat.
    apply wordToNat_natToWord_idempotent.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Hint Rewrite break times4 wordToNat_heapSize : sepFormula.

  Ltac t := unfold globalSched, localsInvariantMain, M'.globalSock, M'.globalTree, M'.globalPages, M'.globalSched;
    genesis; rewrite natToW_plus; reflexivity.

  Theorem ok0 : moduleOk boot.
    unfold boot; rewrite <- Hide.heapSize4_eq; vcgen; abstract t.
  Qed.

  Global Opaque heapSize'.

  Definition m1 := link boot E.T.m.
  Definition m2 := link Buffers.m m1.
  Definition m3 := link E.MyIo.m m2.
  Definition m4 := link StringDb.m m3.
  Definition m := link E.m m4.

  Lemma ok1 : moduleOk m1.
    link ok0 E.T.ok.
  Qed.

  Lemma ok2 : moduleOk m2.
    link Buffers.ok ok1.
  Qed.

  Lemma ok3 : moduleOk m3.
    link E.MyIo.ok ok2.
  Qed.

  Lemma ok4 : moduleOk m4.
    link StringDb.ok ok3.
  Qed.

  Theorem ok : moduleOk m.
    link E.ok ok4.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis prec : forall specs, interp specs (Precondition bootS None (stn, st)).

  Import Safety.

  Theorem safe : sys_safe stn prog (w, st).
    eapply safety; try eassumption; [
      link_simp; unfold labelSys, labelSys'; simpl; tauto
      | apply ok
      | apply LabelMap.find_2; link_simp; reflexivity
      | auto ].
  Qed.
End boot.

End Make.


From Undecidability.Shared.Libs.PSL Require Import Vectors.

From Coq Require Import Vector List.

From Undecidability.L Require Import L LTactics L_facts Functions.Eval Functions.Decoding Functions.Encoding.
From Undecidability.L.Datatypes Require Import LBool Lists LVector List.List_fold.
From Undecidability.L.Complexity.LinDecode Require Import LTDbool LTDlist LTDnat.

From Undecidability.TM.L.CompilerBoolFuns Require Import Compiler_spec NaryApp.

Import ListNotations.
Import VectorNotations.
Import L_Notations.

Definition L_computable_closed {k} (R : Vector.t nat k -> nat -> Prop) :=
  exists s, closed s /\ forall v : Vector.t nat k,
      (forall m, R v m <-> L.eval (Vector.fold_left (fun s n => L.app s (encNatL n)) s v) (encNatL m)) /\
      (forall o, L.eval (Vector.fold_left (fun s n => L.app s (encNatL n)) s v) o -> exists m, o = encNatL m).

Definition L_bool_computable_closed {k} (R : Vector.t (list bool) k -> (list bool) -> Prop) :=
  exists s, closed s /\ forall v : Vector.t (list bool) k,
      (forall m, R v m <-> L.eval (Vector.fold_left (fun s n => L.app s (encBoolsL n)) s v) (encBoolsL m)) /\
      (forall o, L.eval (Vector.fold_left (fun s n => L.app s (encBoolsL n)) s v) o -> exists m, o = encBoolsL m).

Local Instance vector_enc_bool {n} : computable (@enc (Vector.t (list bool) n) _).
Proof.
  unfold enc. cbn. unfold enc. cbn. extract.
Qed.

Lemma logical {X} (P Q : X -> Prop) :
(forall x, Q x  -> P x) -> ((forall x, Q x  -> P x) -> forall x, P x -> Q x) -> forall x, P x <-> Q x.
Proof. firstorder. Qed.

Definition apply_to (s : L.term) {k} {X : Type} `{registered X} (v : Vector.t X k) :=
  many_app s (Vector.map enc v).

Lemma apply_to_cons (s : L.term) {k} {X : Type} `{registered X} (v : Vector.t X k) x :
  apply_to s (x :: v) = apply_to (L.app s (enc x)) v.
Proof.
  reflexivity.
Qed.

Lemma equiv_eval_equiv s t o :
  s == t -> s ⇓ o <-> t ⇓ o.
Proof.
  intros H. split; now rewrite H.
Qed.

Lemma apply_to_equiv' s t {X k} (v : Vector.t X k) `{registered X} :
  s == t -> apply_to s v == apply_to t v.
Proof.
  eapply equiv_many_app_L.
Qed.

Lemma subst_closed s n u :
  closed s -> subst s n u = s.
Proof.
  now intros ->.
Qed.

Lemma equiv_R (s t t' : term):
  t == t' -> s t == s t'.
Proof.
  now intros ->.
Qed.

Section lemma.

  Context {X : Type}.
  Context {Hr : registered X}.
  Context {Hcmp : computable (@enc X _)}.

Definition apply_encs_to (s : term) k := ((Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) (var n))) s (many_vars k))).

Lemma subst_apply_encs_to s n u k :
  k >= n -> subst (apply_encs_to s n) k u = apply_encs_to (subst s k u) n.
Proof.
  induction n in s, k |- *; intros Hk; cbn -[many_vars].
  + reflexivity.
  + unfold apply_encs_to. rewrite many_vars_S. cbn. unfold apply_encs_to in IHn. rewrite IHn.
    cbn. repeat (rewrite subst_closed; [| now Lproc]). destruct (Nat.eqb_spec n k). lia.
    match goal with |- context[subst (ext ?s) _ _] => assert (closed (ext s)) by Lproc end.
    repeat f_equal. eapply H. lia.
Qed.

Lemma many_subst_apply_encs_to s n (u : Vector.t term n) :
closed s -> (forall x, Vector.In x u -> closed x) ->
  many_subst (apply_encs_to s n) 0 u = ((Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) n)) s u)).
Proof.
  induction u in s |- *; intros Hs Hu; cbn -[many_vars].
  - reflexivity.
  - unfold apply_encs_to. rewrite many_vars_S. cbn. unfold apply_encs_to in IHu. rewrite <- IHu.
    fold (apply_encs_to (ext L.app s (ext (@enc X _) n)) n).
    rewrite subst_apply_encs_to. 2:lia. unfold apply_encs_to. repeat f_equal.
    cbn. repeat (rewrite subst_closed; [| now Lproc]). now rewrite Nat.eqb_refl.
    assert (closed h) as Hh. eapply Hu. econstructor. Lproc. intros. eapply Hu. now econstructor.
Qed.

Lemma equiv_fold_left n t1 t2 {v : Vector.t X n} : t1 == t2 -> Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) n)) t1 (Vector.map enc v) == Vector.fold_left (fun s n => ext L.app s (ext (@enc X _) n)) t2 (Vector.map enc v).
Proof.
  induction v in t1, t2 |- *; cbn; intros H.
  - exact H.
  - eapply IHv. now rewrite H.
Qed.

Lemma total_decodable_closed_new k (s : L.term) { Y}  `{linTimeDecodable Y} :
  (forall v : Vector.t X k, forall o : L.term, L_facts.eval (apply_to s v)   o -> exists l : Y, o = enc l) ->
  exists s', closed s' /\ forall v : Vector.t X k, forall o, L_facts.eval (apply_to s' v) o <-> L_facts.eval (apply_to s v) o.
Proof using Hcmp.
  intros Htot.
  assert (closed Eval) as He. { unfold Eval. Lproc. }
  exists (many_lam k (ext (decode Y) (Eval (apply_encs_to (enc s) k)) (lam 0) (ext false))).
  split. { intros n u. rewrite subst_many_lam. cbn -[Eval]. repeat (rewrite subst_closed; [| now Lproc]). rewrite subst_apply_encs_to. 2:lia. now repeat (rewrite subst_closed; [| now Lproc]). }
  intros v. revert s Htot. induction v; intros s Htot o.
  - cbn. specialize (Htot (Vector.nil _)). cbn in Htot.
    eapply logical; clear o.
    + intros o Hl. pose proof Hl as [y ->] % Htot. eapply eval_Eval in Hl. rewrite Hl.
      split. 2: Lproc. Lsimpl. rewrite decode_correct. now Lsimpl.
    + intros Hrev o Heval.
      match type of Heval with L_facts.eval ?l _ => assert (Hc : converges l) by eauto end.
      eapply app_converges in Hc as [[[_ Hc]%app_converges _] % app_converges _].
      eapply Eval_converges in Hc as [o' [Hc Hl]]. rewrite Hc.
      enough (o = o'). subst. now econstructor; eauto. eapply eval_unique.
      eapply Heval. eapply Hrev. rewrite Hc. split; eauto. reflexivity.
  - cbn -[apply_to tabulate many_vars]. rewrite !apply_to_cons. specialize (IHv (s (enc h))). rewrite <- IHv.
    + unfold apply_encs_to. cbn -[many_vars]. rewrite many_vars_S. cbn. eapply equiv_eval_equiv. etransitivity. eapply apply_to_equiv'. eapply beta_red. Lproc. reflexivity.
      rewrite subst_many_lam. cbn [subst]. replace (n + 0) with n by lia.
      rewrite He. assert (closed (ext (decode Y))) as H2 by Lproc. unfold closed in H2. rewrite H2. clear H2. cbn.
      assert (closed (ext false)) as H2 by Lproc. unfold closed in H2. rewrite H2. clear H2. unfold apply_to.
      rewrite many_beta. rewrite !many_subst_app. repeat (rewrite many_subst_closed; [ | now Lproc]).
      symmetry.
      rewrite many_beta. rewrite !many_subst_app. repeat (rewrite many_subst_closed; [ | now Lproc]).
      2:{ clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec. }
      2:{ clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec. }
      repeat (eapply equiv_app_proper; try reflexivity). clear.
      fold (@apply_encs_to (enc (s (enc h))) n). fold (apply_encs_to (ext L.app (enc s) (ext (@enc X _) n)) n).
      rewrite subst_apply_encs_to. cbn. repeat (rewrite subst_closed; [ | now Lproc]). rewrite Nat.eqb_refl.
      rewrite !many_subst_apply_encs_to.
      * rewrite equiv_fold_left. reflexivity. now Lsimpl.
      * Lproc.
      * clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec.
      * Lproc.
      * clear. induction v; cbn; intros ? Hi. inversion Hi. inv Hi. Lproc. eapply IHv. eapply Eqdep_dec.inj_pair2_eq_dec in H2. subst. eauto. eapply nat_eq_dec.
      * lia.
    + intros. now apply (Htot (h :: v0)).
Qed.

End lemma.

Lemma many_app_eq {k} (v : Vector.t (list bool) k) s :  many_app s (Vector.map enc v) = Vector.fold_left (fun (s : term) n => s (encBoolsL n)) s v.
Proof.
   induction v in s |- *.
   * cbn. reflexivity.
   * cbn. now rewrite IHv.
Qed.

Lemma L_bool_computable_can_closed k R:
  L_bool_computable_closed R <-> L_bool_computable (k:=k) R.
Proof.
  split.
  - intros (s & _ & H). exists s. exact H.
  - intros (s & H).
    unshelve edestruct (@total_decodable_closed_new (list bool) _ _ k s (list bool) _  ) as (s' & Hcl & Hs'); try exact _.
    + intros v o. rewrite <- eval_iff. intros. eapply (H v). unfold apply_to in H0. revert H0.
      now rewrite many_app_eq.
    + unfold apply_to in Hs'. exists s'. split. Lproc. intros v. split.
      * intros m. specialize (H v) as [H1 H2]. rewrite H1. rewrite !eval_iff. rewrite <- !many_app_eq. now rewrite Hs'.
      * intros o. rewrite eval_iff. rewrite <- many_app_eq. rewrite Hs'. rewrite <- eval_iff. rewrite many_app_eq. eapply H.
Qed.

Lemma many_app_eq_nat {k} (v : Vector.t nat k) s :  many_app s (Vector.map enc v) = Vector.fold_left (fun (s : term) n => s (encNatL n)) s v.
Proof.
   induction v in s |- *.
   * cbn. reflexivity.
   * cbn. now rewrite IHv.
Qed.

Lemma L_computable_can_closed k R:
  L_computable_closed R <-> L_computable (k:=k) R.
Proof.
  split.
  - intros (s & _ & H). exists s. exact H.
  - intros (s & H).
    unshelve edestruct (@total_decodable_closed_new nat _ _ k s nat _  ) as (s' & Hcl & Hs'); try exact _.
    + intros v o. rewrite <- eval_iff. intros. eapply (H v). unfold apply_to in H0. revert H0.
      now rewrite many_app_eq_nat.
    + unfold apply_to in Hs'. exists s'. split. Lproc. intros v. split.
      * intros m. specialize (H v) as [H1 H2]. rewrite H1. rewrite !eval_iff. rewrite <- !many_app_eq_nat. now rewrite Hs'.
      * intros o. rewrite eval_iff. rewrite <- many_app_eq_nat. rewrite Hs'. rewrite <- eval_iff. rewrite many_app_eq_nat. eapply H.
Qed.


(**************************************************************************)
(*                                                                        *)
(*  This file is part of octant-proof.                                    *)
(*                                                                        *)
(*  Copyright (C) 2019-2020 Orange                                        *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, either version 3 of the License, or (at your option)      *)
(*  any later version.                                                    *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  You should have received a copy of the GNU Lesser General Public      *)
(*  License along with the software. If not, see                          *)
(*  <https://www.gnu.org/licenses/>.                                      *)
(*                                                                        *)
(**************************************************************************)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun choice fintype tuple finset.

From Equations Require Import Equations Signature.
Set Implicit Arguments.

Unset Strict Implicit.

(** * uniq_seq: finite sequences, bounded by unicity *)
Section uniq_seq.

(** ** Definition *)

Structure uniq_seq {A : eqType} := {useq :> seq A ; buniq : uniq useq}.

Lemma andP_to_uniq {A : eqType} {t : A} {b : uniq_seq} (H : t \notin (useq b) /\ uniq b) : uniq (t::b).
Proof.
by apply/andP.
Qed.

(** ** uniq_seq is a subtype of seq *)
Canonical uniq_seq_subType {A : eqType} := Eval hnf in [subType for @useq A].
(** ** as well as eqType, choiceType, countType and subCountType *)
Canonical uniq_seq_eqType {A : eqType} := Eval hnf in EqType _ [eqMixin of (@uniq_seq A) by <:].
Canonical uniq_seq_choiceType {A : choiceType} := Eval hnf in ChoiceType _ [choiceMixin of (@uniq_seq A) by <:].
Canonical uniq_seq_countType {A : countType} := Eval hnf in CountType _ [countMixin of (@uniq_seq A) by <:].
Canonical uniq_seq_subCountType {A : countType} := Eval hnf in [subCountType of (@uniq_seq A)].

Lemma notinnil {A : eqType} (x : A) : x \notin [::].
Proof.
auto.
Qed.

(** ** constructors for uniq_seq *)
Definition unil {A : eqType} : @uniq_seq A  := {| useq := [::]; buniq := is_true_true |}.
Definition ucons1 {A : eqType} (t : A) :=
  {| useq := [:: t]; buniq := notinnil t |}.
Definition ucons {A : eqType} (t : A) (b : uniq_seq) (H : t \notin (useq b)) : uniq_seq :=
{| useq := t :: b; buniq := (andP_to_uniq (conj H (buniq b))) |}.
(* tries to add t to b *)
Definition pucons {A : eqType} (t : A) (b : @uniq_seq A) : @uniq_seq A :=
 match Sumbool.sumbool_of_bool (t \notin (useq b)) with
    | left H => ucons H
    | in_right => b
  end.

Lemma uniq_behead {A : eqType} (s : seq A) : uniq s -> uniq (behead s).
Proof.
induction s as [|h l Hs];auto.
by move=>/andP [].
Qed.

Definition useq_behead {A : eqType} (us : @uniq_seq A) : @uniq_seq A :=
  match us with
    | {| useq := s; buniq := Hus |} => {| useq := behead s; buniq := uniq_behead Hus |}
end.

Definition useq_hd {A : eqType} (us : @uniq_seq A) : option A :=
  match us with
    | {| useq := [::] |} => None
    | {| useq := hd :: tl |} => Some hd end.

(** ** uniq_seq is a finType *)
(* thanks to Arthur Azevedo De Amorim *)
Lemma size_useq {A : finType} (d : @uniq_seq A) : size d < #|A|.+1.
Proof.
rewrite ltnS [card]unlock uniq_leq_size ?buniq // => ?.
rewrite mem_enum. auto.
Qed.

Definition tag_of_uniq_seq {A : finType} (d : @uniq_seq A) : {k : 'I_#|A|.+1 & k.-tuple A} :=
  @Tagged _ (Sub (size d) (size_useq d))
            (fun k : 'I_#|A|.+1 => k.-tuple A)
            (in_tuple d).

Definition uniq_seq_of_tag {A : finType} (t : {k : 'I_#|A|.+1 & k.-tuple A}) : option (@uniq_seq_countType A) :=
  insub (val (tagged t)).

Lemma tag_of_dbranchK {A : finType} : pcancel (@tag_of_uniq_seq A) uniq_seq_of_tag.
Proof. by rewrite /tag_of_uniq_seq /uniq_seq_of_tag=> x; rewrite valK. Qed.

Definition uniq_seq_finMixin {A : finType} := PcanFinMixin (@tag_of_dbranchK A).
Canonical uniq_seq_finType {A : finType} := Eval hnf in FinType (@uniq_seq A) uniq_seq_finMixin.

End uniq_seq.

(** * Wlist: finite sequences, with a size bounded by a nat *)
Section Wlist.

(** ** Definition *)

Inductive Wlist (X: Type): nat -> Type :=
  Bnil : forall n, (Wlist X n)
| Bcons : forall n, X -> (Wlist X n) -> (Wlist X n.+1).

(** ** Canceling lemmas *)

Section Cancel.

Variable A: Type.

Definition g (_: unit) := (Bnil A 0).

Definition f (x: Wlist A 0) := tt.

Lemma nil_list0 : forall n (x: Wlist A n), (n = 0) -> (eq x (Bnil A n)).
intros n x.
elim x.
auto.
intros.
contradict H0.
auto.
Defined.

Lemma nil0 : forall (x: Wlist A 0), (eq x (Bnil A 0)).
intro; by [apply nil_list0].
Defined.

Lemma cancelfg : cancel f g.
intro x.
rewrite (nil0 x).
auto.
Defined.

Definition gg (n: nat) (x: unit + A * Wlist A n) : (Wlist A n.+1) :=
match x with
| inl _ => Bnil A n.+1
| inr (H1, H2) => Bcons H1 H2
end.

Derive Signature for Wlist.
Equations ff (n : nat) (x : Wlist A n.+1) : (unit + A * Wlist A n) :=
  ff (Bnil _) := inl tt ;
  ff (Bcons a l) := inr (a,l).

Lemma cancelffgg: forall n, cancel (@ff n) (@gg n).
intros n x.
dependent elimination x; compute; auto.
Defined.

End Cancel.

(** ** Wlist is a type with dedicable equality *)
Section WlistEqType.
Variable A: eqType.

Definition wlist0_eqMixin := CanEqMixin (@cancelfg A).
Definition wlist0_eqType := EqType (Wlist A 0) wlist0_eqMixin.

Fixpoint wlistn_eqMixin n : Equality.mixin_of (Wlist A n).
elim n.
exact wlist0_eqMixin.
intros n0 EM.
apply (@CanEqMixin _ (sum_eqType unit_eqType (prod_eqType A (Equality.Pack EM))) (@ff A n0) (@gg A n0) (@cancelffgg A n0)).
Defined.

Definition wlistn_eqType n := Eval hnf in EqType (Wlist A n) (wlistn_eqMixin n).
End WlistEqType.

(** ** Wlist is a subtype of seq *)
Section WlistSubType.

Fixpoint wlist_to_seq {X : Type} {m : nat} (s : Wlist X m) : seq X := match s with
  | Bnil _ => [::]
  | Bcons _ a b => a :: (wlist_to_seq b) end.

Fixpoint seq_to_wlist {X : Type} (m : nat) (s : seq X) := match m with
  0 => Bnil X 0
  | m'.+1 => match s with
              [::] => Bnil X m'.+1
              | a :: l => Bcons a (seq_to_wlist m' l) end end.

Lemma seq_to_bnil {X : Type} (m : nat) : @seq_to_wlist X m [::] = Bnil X m.
Proof.
by destruct m.
Qed.

Lemma wlist_seqK {X : Type} {m : nat} (l : Wlist X m) : (seq_to_wlist m (wlist_to_seq l)) = l.
Proof.
by induction l ; [destruct n | simpl ; apply/f_equal/IHl].
Qed.

Lemma seq_wlistK {X : Type} {m : nat} (l : seq X) (H : size l <= m) : (wlist_to_seq (seq_to_wlist m l)) = l.
Proof.
move:m H.
induction l.
- by destruct m.
- move => m H ; destruct m.
  + inversion H.
  + simpl ; apply/f_equal/IHl/H.
Qed.

Definition seq_to_wlist_uncut {X : Type} {m : nat} (s : seq X) (H : size s <= m) : Wlist X m :=
  seq_to_wlist m s.

Lemma wlist_to_seq_size {X : Type} {m : nat} (s : Wlist X m) : size (wlist_to_seq s) <= m.
Proof.
by induction s.
Defined.

Lemma wlist_elim {A : Type} {m : nat} : forall K : Wlist A m -> Type,
 (forall (s : seq A) (Ps : size s <= m), K (seq_to_wlist_uncut Ps)) -> forall u : Wlist A m, K u.
Proof.
move => K Ps s. unfold seq_to_wlist_uncut in Ps.
rewrite <- wlist_seqK. apply Ps. apply wlist_to_seq_size.
Qed.

Lemma wlist_ind {A : Type} {m : nat} : forall K : Wlist A m -> Prop,
 (forall (s : seq A) (Ps : size s <= m), K (seq_to_wlist_uncut Ps)) -> forall u : Wlist A m, K u.
Proof.
move => K Ps s. unfold seq_to_wlist_uncut in Ps.
rewrite <- wlist_seqK. apply Ps. apply wlist_to_seq_size.
Qed.

Lemma seq_wlist_uncut_K {A : Type} {m : nat} (s : seq A) (Ps : size s <= m) :
  wlist_to_seq (seq_to_wlist_uncut Ps) = s.
Proof.
apply (seq_wlistK Ps).
Qed.

Definition wlist_subType {A : Type} {w : nat} :=
  Eval hnf in (SubType (@Wlist A w) (@wlist_to_seq A w) seq_to_wlist_uncut wlist_elim seq_wlist_uncut_K).

Coercion wlist_to_seq_co {A : Type} {m : nat} x := @wlist_to_seq A m x.

End WlistSubType.

(** ** Wlist is a choice type *)
Section WlistChoiceType.
Variable A: choiceType.
Definition wlist0_choiceMixin := CanChoiceMixin (@cancelfg A).
Definition wlist0_choiceType := ChoiceType (wlist0_eqType A) wlist0_choiceMixin.

Fixpoint wlistn_choiceMixin (n:nat) :  Choice.mixin_of (Wlist A n).
elim n.
exact wlist0_choiceMixin.
intros n0 EC.

apply  (@CanChoiceMixin (sum_choiceType unit_choiceType (prod_choiceType A (ChoiceType (wlistn_eqType A n0) EC)  ))
                        (Wlist A n0.+1) (@ff A n0) (@gg A n0) (@cancelffgg A n0)).
Defined.

Definition wlistn_choiceType n := Eval hnf in (@ChoiceType (wlistn_eqType A n) (wlistn_choiceMixin n)).
End WlistChoiceType.

(** ** Wlist is a count type *)
Section WlistCountType.

Variable A: countType.
Definition wlist0_countMixin := CanCountMixin (@cancelfg A).
Definition wlist0_countType := CountType (wlist0_choiceType A) wlist0_countMixin.

Fixpoint wlistn_countMixin (n:nat): Countable.mixin_of (Wlist A n).
elim n.
exact wlist0_countMixin.
intros n0 EN.

apply (@CanCountMixin
           (sum_countType unit_countType (prod_countType A (CountType (wlistn_choiceType A n0) EN)  ))
           _ (@ff A n0) (@gg A n0) (@cancelffgg A n0)).
Defined.

Definition wlistn_countType n := Eval hnf in (@CountType (wlistn_choiceType A n) (wlistn_countMixin n)).

Lemma cteq: wlistn_countType 0 = wlist0_countType.
Proof.
compute. trivial.
Qed.

End WlistCountType.

(** ** Wlist is a finite type *)
Section WlistFinType.

Variable A: finType.

Definition wlist0_finMixin := @CanFinMixin (wlist0_countType A) unit_finType (@f A) (@g A) (@cancelfg A).
Definition wlist0_finType := FinType (wlist0_countType A) wlist0_finMixin.

Fixpoint wlistn_finMixin (n:nat): Finite.mixin_of (wlistn_countType A n).
elim n.
rewrite cteq.
exact wlist0_finMixin.
intros n0 EF.
apply (@CanFinMixin
           (wlistn_countType A n0.+1)
           (sum_finType unit_finType (prod_finType A (FinType (wlistn_countType A n0) EF)  ))
           (@ff A n0) (@gg A n0) (@cancelffgg A n0)).
Defined.

Definition wlistn_finType n := Eval hnf in (@FinType (wlistn_choiceType A n) (wlistn_finMixin n)).
End WlistFinType.

(** ** Utility lemmas and definitions for Wlist *)
Section WlistUtils.

Fixpoint wsize {X : Type} {m : nat} (t : Wlist X m) : nat := match t with
  | Bnil _ => 0
  | Bcons _ a b => (wsize b).+1 end.

Fixpoint wmap {X Y : Type} {m : nat} (f : X -> Y) (t : Wlist X m) : Wlist Y m := match t with
  | Bnil a => Bnil Y a
  | Bcons n a b => Bcons (f a) (@wmap X Y _ f b) end.

Lemma size_wmap {X Y : Type} {m : nat} : forall (f : X -> Y) (s : Wlist X m),
  wsize (wmap f s) = wsize s.
Proof.
by induction s ; [ | simpl ; auto].
Defined.

Lemma wmapcoK {X Y : Type} {m : nat} (f : X -> Y) (t : Wlist X m) : wlist_to_seq_co (wmap f t) = map f (wlist_to_seq_co t).
Proof.
by induction t => /= ; [|apply/f_equal].
Qed.

Lemma wmapK {X Y : Type} {m : nat} (f : X -> Y) (t : Wlist X m) : wlist_to_seq (wmap f t) = map f (wlist_to_seq t).
Proof.
by induction t => /= ; [|apply/f_equal].
Qed.

Fixpoint w_subtype {X : Type} {n : nat} (m : nat) (l : Wlist X n) : Wlist X (n+m) := match l with
  | Bnil n => Bnil X (n+m)
  | Bcons _ a b => Bcons a (w_subtype m b) end.

Fixpoint wapp {X : Type} {n m : nat} (l : Wlist X n) (ll : Wlist X m) : Wlist X (n+m)
 := match l with
  | Bnil n => eq_rect_r (Wlist X) ((w_subtype n ll)) (addnC n m)
  | Bcons _ a b => Bcons a (wapp b ll) end.

Fixpoint wall {X : Type} {m : nat} (P : X -> bool) (s : Wlist X m) : bool := match s with
  | Bnil _ => true
  | Bcons _ a b => (P a) && (wall P b) end.

Lemma wall_allK {A : Type} {w : nat} {l : Wlist A w} {P : pred A} : wall P l = all P (wlist_to_seq l).
Proof.
by induction l ; [ | apply andb_id2l].
Qed.

Lemma wall_to_all {A : Type} {w : nat} {l : Wlist A w} {P : pred A} : wall P l -> all P (wlist_to_seq l).
Proof.
by rewrite wall_allK.
Qed.

Definition w_all_prop (T : Type) (a : T -> Prop) :=
fix all {w : nat} (s : Wlist T w) : Prop :=
  match s with
  | Bnil _ => True
  | Bcons n x s' => a x /\ all n s'
  end.

(*Coercion wlist_to_seq : (Wlist X m) >-> seq X.*)

Fixpoint tuple_to_wlist {X : Type} {n : nat} (t : n.-tuple X) : Wlist X n.
destruct t.
move:n i.
induction tval.
  - move => n i ; simpl in i. assert(0 = n). apply/eqP/i. rewrite <- H. apply Bnil.
  - move => n i. simpl in i. assert((size tval).+1 = n). apply/eqP/i. destruct n.
    inversion H.
    inversion H.
    assert (size tval == n). apply/eqP/H1.
    rewrite H1.
    apply (Bcons a (IHtval n H0)).
Defined.

Lemma wmap_nil {X Y : Type} {n : nat} (f : X -> Y) (l : Wlist X n):
  map f (wlist_to_seq_co l) = [::] -> l = Bnil X n.
Proof.
by destruct l.
Qed.

End WlistUtils.

End Wlist.


Require Import String.
Import List.
Import ListNotations.

Ltac nth_error_empty :=
  match goal with
  | [H : nth_error [] ?i = Some _ |- _] =>
      destruct i;
      simpl in H;
      discriminate
  end.

Lemma concat_cons: forall (A : Type) (l l' : list A) (e : A),
  l ++ (e :: l') = (l ++ [e]) ++ l'.
Proof.
  intros A l.
  induction l;
  intros l' e.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

Lemma cons_concat: forall (A : Type) (l : list A) (a1 a2 : A),
  a1 :: a2 :: l = [a1 ; a2] ++ l.
Proof.
  intros.
  trivial.
Qed.

Lemma concat_list_two: forall (A : Type) (l : list A) (a1 a2 : A),
  l ++ [a1 ; a2] = (l ++ [a1]) ++ [a2].
Proof.
  intros A l.
  induction l;
  intros a1 a2.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

Lemma nth_different_tail_smaller:
  forall (A : Type) (l : list A) (i : nat) (a1 a2 : A),
  a1 <> a2 ->
  nth_error (l ++ [a1]) i = Some a2 ->
  nth_error l i = Some a2.
Proof.
  intros A l.
  induction l;
  intros i a1 a2;
  intros H_diff H_nth.
  - simpl in * |- *.
    destruct i;
    simpl in H_nth.
    + inversion H_nth.
      contradiction.
    + destruct i;
      simpl in H_nth;
      discriminate.
  - simpl in * |- *.
    destruct i;
    simpl in H_nth |- *.
    + assumption.
    + apply IHl with a1;
      assumption.
Qed.

Lemma nth_succes_larger:
  forall (A : Type) (l l' : list A) (i : nat) (a1 : A),
  nth_error l i = Some a1 ->
  nth_error (l ++ l') i = Some a1.
Proof.
  intros A l l' i a1.
  intros H_nth.
  rewrite nth_error_app1.
  - assumption.
  - apply nth_error_Some.
    unfold not.
    intros H_none.
    rewrite H_none in H_nth.
    discriminate.
Qed.

Lemma nth_index_in_concat:
  forall (A : Type) (l l' : list A) (i : nat) (a : A),
  nth_error (l ++ l') i = Some a ->
  nth_error l i = Some a \/ (exists j, j + (Datatypes.length l) = i /\ nth_error l' j = Some a).
Proof.
  intros.
  assert (i < Datatypes.length l \/ Datatypes.length l <= i) by apply PeanoNat.Nat.lt_ge_cases.
  destruct H0.
  - left.
    rewrite <- H.
    rewrite nth_error_app1.
    + reflexivity.
    + assumption.
  - right.
    exists (i - Datatypes.length l).
    split.
    + apply PeanoNat.Nat.sub_add.
      assumption.
    + rewrite <- H.
      rewrite nth_error_app2.
      * reflexivity.
      * assumption.
Qed.

Lemma nth_error_concat_not_in_tail_implies_head:
  forall (A : Type) (l l' : list A) (i : nat) (e : A),
  nth_error (l ++ l') i = Some e ->
  ~ In e l' ->
  nth_error l i = Some e.
Proof.
  intros A l.
  induction l;
  intros l' i e;
  intros H_nth H_not_in;
  simpl in H_nth.
  - apply nth_error_In in H_nth.
    contradiction.
  - destruct i;
    simpl in * |- *.
    + assumption.
    + eapply IHl;
      eassumption.
Qed.