(* Following http://REDACTED.net/theses/REDACTED.pdf chapter 3 *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Structures.Orders.
Require Import Coq.Lists.List.
Require Import Crypto.Algebra.Nsatz.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Decidable.Bool2Prop.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.CPSUtil.
Require Import Crypto.Util.CPSNotations.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Modulo.PullPush.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

Reserved Notation "'dlet_list_pair_only_snd' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list_pair_only_snd'  x  :=  v  'in' '//' f").
Reserved Notation "'dlet_list_pair' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list_pair'  x  :=  v  'in' '//' f").
Reserved Notation "'dlet_list' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list'  x  :=  v  'in' '//' f").
Declare Scope runtime_scope.
Delimit Scope runtime_scope with RT.
Import CPSBindNotations.
Local Open Scope cps_scope.

Module Type Runtime.
  Parameter Let_In : forall {A P} (x : A) (f : forall a : A, P a), P x.
  Parameter runtime_nth_default : forall {A}, A -> list A -> nat -> A.
  Parameter runtime_add : Z -> Z -> Z.
  Parameter runtime_sub : Z -> Z -> Z.
  Parameter runtime_mul : Z -> Z -> Z.
  Parameter runtime_div : Z -> Z -> Z.
  Parameter runtime_modulo : Z -> Z -> Z.
  Parameter runtime_opp : Z -> Z.
  Arguments runtime_add (_ _)%RT.
  Arguments runtime_sub (_ _)%RT.
  Arguments runtime_mul (_ _)%RT.
  Arguments runtime_div _%RT _%Z.
  Arguments runtime_modulo _%RT _%Z.
  Arguments runtime_opp _%RT.
  Infix "*" := runtime_mul : runtime_scope.
  Infix "+" := runtime_add : runtime_scope.
  Infix "-" := runtime_sub : runtime_scope.
  Infix "/" := runtime_div : runtime_scope.
  Notation "x 'mod' y" := (runtime_modulo x y) : runtime_scope.
  Notation "- x" := (runtime_opp x) : runtime_scope.
  Notation "'dlet_nd' x .. y := v 'in' f" := (Let_In (P:=fun _ => _) v (fun x => .. (fun y => f) .. )) (only parsing).
  Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).

  Module RT_Z.
    Parameter zselect : Z -> Z -> Z -> Z.
    Parameter add_get_carry_full : Z -> Z -> Z -> Z * Z.
    Parameter add_with_get_carry_full : Z -> Z -> Z -> Z -> Z * Z.
    Parameter mul_split : Z -> Z -> Z -> Z * Z.
    Parameter land : Z -> Z -> Z.
  End RT_Z.
End Runtime.

Module RuntimeDefinitions <: Runtime.
  Definition Let_In := @LetIn.Let_In.
  Definition runtime_nth_default := List.nth_default.
  Definition runtime_add := Z.add.
  Definition runtime_sub := Z.sub.
  Definition runtime_mul := Z.mul.
  Definition runtime_opp := Z.opp.
  Definition runtime_div := Z.div.
  Definition runtime_modulo := Z.modulo.
  Module RT_Z.
    Definition zselect := Z.zselect.
    Definition add_get_carry_full := Z.add_get_carry_full.
    Definition add_with_get_carry_full := Z.add_with_get_carry_full.
    Definition mul_split := Z.mul_split.
    Definition land := Z.land.
  End RT_Z.
End RuntimeDefinitions.

Module RuntimeAxioms : Runtime.
  Include RuntimeDefinitions.
End RuntimeAxioms.

Module Export RuntimeDefinitionsCbv.
  Import RuntimeDefinitions.
  Declare Reduction cbv_no_rt
    := cbv -[Let_In
               runtime_nth_default
               runtime_add
               runtime_sub
               runtime_mul
               runtime_opp
               runtime_div
               runtime_modulo
               RT_Z.add_get_carry_full
               RT_Z.add_with_get_carry_full
               RT_Z.mul_split].
  Declare Reduction lazy_no_rt
    := lazy -[Let_In
                runtime_nth_default
                runtime_add
                runtime_sub
                runtime_mul
                runtime_opp
                runtime_div
                runtime_modulo
                RT_Z.add_get_carry_full
                RT_Z.add_with_get_carry_full
                RT_Z.mul_split].
  Declare Reduction pattern_rt
    := pattern Let_In,
       runtime_nth_default,
       runtime_add,
       runtime_sub,
       runtime_mul,
       runtime_opp,
       runtime_div,
       runtime_modulo,
       RT_Z.add_get_carry_full,
       RT_Z.add_with_get_carry_full,
       RT_Z.mul_split.

  Import RuntimeAxioms.
  Declare Reduction pattern_ax_rt
    := pattern (@Let_In),
       (@runtime_nth_default),
       runtime_add,
       runtime_sub,
       runtime_mul,
       runtime_opp,
       runtime_div,
       runtime_modulo,
       RT_Z.add_get_carry_full,
       RT_Z.add_with_get_carry_full,
       RT_Z.mul_split.
End RuntimeDefinitionsCbv.

Module RT_Extra (Import RT : Runtime).
  Fixpoint dlet_nd_list_pair {A B} (ls : list (A * B)) {T} (f : list (A * B) -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x1 := fst x in dlet_nd x2 := snd x in @dlet_nd_list_pair A B xs T (fun xs => f ((x1, x2) :: xs))
       end.

  Fixpoint dlet_nd_list {A} (ls : list A) {T} (f : list A -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x := x in @dlet_nd_list A xs T (fun xs => f (x :: xs))
       end.

  Fixpoint dlet_nd_list_pair_only_snd {A B} (ls : list (A * B)) {T} (f : list (A * B) -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x2 := snd x in @dlet_nd_list_pair_only_snd A B xs T (fun xs => f ((fst x, x2) :: xs))
       end.

  Notation "'dlet_list_pair_only_snd' x := v 'in' f" := (dlet_nd_list_pair_only_snd v (fun x => f)).
  Notation "'dlet_list_pair' x := v 'in' f" := (dlet_nd_list_pair v (fun x => f)).
  Notation "'dlet_list' x := v 'in' f" := (dlet_nd_list v (fun x => f)).

  Definition expand_list_helper {A} (default : A) (ls : list A) (n : nat) (idx : nat) : list A
  := nat_rect
       (fun _ => nat -> list A)
       (fun _ => nil)
       (fun n' rec_call idx
        => cons (runtime_nth_default default ls idx) (rec_call (S idx)))
       n
       idx.
  Definition expand_list {A} (default : A) (ls : list A) (n : nat) : list A
    := expand_list_helper default ls n 0.
End RT_Extra.

Module Associational (Import RT : Runtime).
  Module Import Deps.
    Module Export RT_Extra := RT_Extra RT.
  End Deps.
  Definition eval (p:list (Z*Z)) : Z :=
    fold_right (fun x y => x + y) 0%Z (map (fun t => fst t * snd t) p).

  Definition mul (p q:list (Z*Z)) : list (Z*Z) :=
    flat_map (fun t =>
      map (fun t' =>
        (fst t * fst t', (snd t * snd t')%RT))
    q) p.

  Definition square_cps (p:list (Z*Z)) : ~> list (Z*Z) :=
    list_rect
      _
      (return nil)
      (fun t ts acc T k
       => (dlet two_t2 := (2 * snd t)%RT in
               acc
                 _
                 (fun acc
                  => k (((fst t * fst t, (snd t * snd t)%RT)
                           :: (map (fun t'
                                    => (fst t * fst t', (two_t2 * snd t')%RT))
                                   ts))
                          ++ acc))))
      p.

  Definition negate_snd (p:list (Z*Z)) : list (Z*Z) :=
    map (fun cx => (fst cx, (-snd cx)%RT)) p.

  Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => fst t mod s =? 0) p in
       (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)).

  Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) :=
    let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi).

  (* reduce at most [n] times, stopping early if the high list is nil at any point *)
  Definition repeat_reduce (n : nat) (s:Z) (c:list _) (p:list _) : list (Z * Z)
    := nat_rect
         _
         (fun p => p)
         (fun n' repeat_reduce_n' p
          => let lo_hi := split s p in
             if (length (snd lo_hi) =? 0)%nat
             then p
             else let p := fst lo_hi ++ mul c (snd lo_hi) in
                  repeat_reduce_n' p)
         n
         p.

  (* rough template (we actually have to do things a bit differently to account for duplicate weights):
[ dlet fi_c := c * fi in
   let (fj_high, fj_low) := split fj at s/fi.weight in
   dlet fi_2 := 2 * fi in
    dlet fi_2_c := 2 * fi_c in
    (if fi.weight^2 >= s then fi_c * fi else fi * fi)
       ++ fi_2_c * fj_high
       ++ fi_2 * fj_low
 | fi <- f , fj := (f weight less than i) ]
   *)
  (** N.B. We take advantage of dead code elimination to allow us to
      let-bind partial products that we don't end up using *)
  (** [v] -> [(v, v*c, v*c*2, v*2)] *)
  Definition let_bind_for_reduce_square_cps (c:list (Z*Z)) (p:list (Z*Z)) : ~> list ((Z*Z) * list(Z*Z) * list(Z*Z) * list(Z*Z)) :=
    fun T
    => let two := [(1,2)] (* (weight, value) *) in
       map_cps2 (fun t T k => dlet_list_pair_only_snd c_t := mul [t] c in dlet_list_pair_only_snd two_c_t := mul c_t two in dlet_list_pair_only_snd two_t := mul [t] two in k (t, c_t, two_c_t, two_t)) p.
  Definition reduce_square_cps (s:Z) (c:list (Z*Z)) (p:list (Z*Z)) : ~>list (Z*Z) :=
    (p <- let_bind_for_reduce_square_cps c p;
    let div_s := map (fun t => (fst t / s, snd t)) in
    return (list_rect
      _
      nil
      (fun t ts acc
       => (let '(t, c_t, two_c_t, two_t) := t in
           (if ((fst t * fst t) mod s =? 0)
            then div_s (mul [t] c_t)
            else mul [t] [t])
             ++ (flat_map
                   (fun '(t', c_t', two_c_t', two_t')
                    => if ((fst t * fst t') mod s =? 0)
                       then div_s
                              (if fst t' <=? fst t
                               then mul [t'] two_c_t
                               else mul [t] two_c_t')
                       else (if fst t' <=? fst t
                             then mul [t'] two_t
                             else mul [t] two_t'))
                   ts))
            ++ acc)
      p)).

  Definition bind_snd_cps (p : list (Z*Z)) : ~>list (Z * Z) :=
    @dlet_nd_list_pair_only_snd _ _ p.

  Section Carries.
    Definition carryterm_cps (w fw:Z) (t:Z * Z) : ~> list (Z * Z) :=
      fun T k
      => if (Z.eqb (fst t) w)
         then dlet_nd t2 := snd t in
              dlet_nd d2 := (t2 / fw)%RT in
              dlet_nd m2 := (t2 mod fw)%RT in
              k [(w * fw, d2);(w,m2)]
         else k [t].

    Definition carry_cps (w fw:Z) (p:list (Z * Z)) : ~> list (Z * Z):=
      fun T => flat_map_cps (carryterm_cps w fw) p.
  End Carries.
End Associational.

Module Positional (Import RT : Runtime).
  Module Import Deps.
    Module Associational := Associational RT.
  End Deps.
  Section Positional.
  Context (weight : nat -> Z).

  Definition to_associational (n:nat) (xs:list Z) : list (Z*Z)
    := combine (map weight (List.seq 0 n)) xs.
  Definition eval n x := Associational.eval (@to_associational n x).
  Definition zeros n : list Z := repeat 0 n.
  Definition add_to_nth i x (ls : list Z) : list Z
    := ListUtil.update_nth i (fun y => (x + y)%RT) ls.

  Definition place (t:Z*Z) (i:nat) : nat * Z :=
    nat_rect
      (fun _ => unit -> (nat * Z)%type)
      (fun _ => (O, if fst t =? 1 then snd t else (fst t * snd t)%RT))
      (fun i' place_i' _
       => let i := S i' in
          if (fst t mod weight i =? 0)
          then (i, let c := fst t / weight i in if c =? 1 then snd t else (c * snd t)%RT)
          else place_i' tt)
      i
      tt.

  Definition from_associational_cps n (p:list (Z*Z)) : ~> list Z :=
    fun T => fold_right_cps2 (fun t ls T k =>
      let '(p1, p2) := place t (pred n) in
      dlet_nd p2 := p2 in
      k (add_to_nth p1 p2 ls)) (zeros n) p.

  Definition extend_to_length (n_in n_out : nat) (p:list Z) : list Z :=
    p ++ zeros (n_out - n_in).

  Definition drop_high_to_length (n : nat) (p:list Z) : list Z :=
    firstn n p.

  Section mulmod.
    Context (s:Z)
            (c:list (Z*Z)).
    Definition mulmod_cps (n:nat) (a b:list Z) : ~> list Z
      := let a_a := to_associational n a in
         let b_a := to_associational n b in
         let ab_a := Associational.mul a_a b_a in
         let abm_a := Associational.repeat_reduce n s c ab_a in
         from_associational_cps n abm_a.

    Definition squaremod_cps (n:nat) (a:list Z) : ~> list Z
      := (let a_a := to_associational n a in
         aa_a <- Associational.reduce_square_cps s c a_a;
         let aam_a := Associational.repeat_reduce (pred n) s c aa_a in
         from_associational_cps n aam_a).
  End mulmod.

  Definition add_cps (n:nat) (a b:list Z) : ~> list Z
    := let a_a := to_associational n a in
       let b_a := to_associational n b in
       from_associational_cps n (a_a ++ b_a).

  Section Carries.
    Definition carry_cps n m (index:nat) (p:list Z) : ~> list Z :=
      (p <- @Associational.carry_cps (weight index)
         (weight (S index) / weight index)
         (to_associational n p);
       from_associational_cps
           m p).

    Definition carry_reduce_cps n (s:Z) (c:list (Z * Z))
               (index:nat) (p : list Z) : ~> list Z :=
      (p <- @carry_cps n (S n) index p;
         p <- from_associational_cps
           n (Associational.reduce
                s c (to_associational (S n) p));
       return p).

    (* N.B. It is important to reverse [idxs] here, because fold_right is
      written such that the first terms in the list are actually used
      last in the computation. For example, running:

      `Eval cbv - [Z.add] in (fun a b c d => fold_right Z.add d [a;b;c]).`

      will produce [fun a b c d => (a + (b + (c + d)))].*)
    Definition chained_carries_cps n s c p (idxs : list nat) : ~> _ :=
      fun T => fold_right_cps2 (fun a b => carry_reduce_cps n s c a b) p (rev idxs).

    (* carries without modular reduction; useful for converting between bases *)
    Definition chained_carries_no_reduce_cps n p (idxs : list nat) : ~> _ :=
      fun T => fold_right_cps2 (fun a b => carry_cps n n a b) p (rev idxs).

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying. *)
    Definition encode_cps n s c (x : Z) : ~> list Z :=
      (p <- from_associational_cps n [(1,x)]; chained_carries_cps n s c p (seq 0 n)).

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying, but without reduction. *)
    Definition encode_no_reduce_cps n (x : Z) : ~> list Z :=
      (p <- from_associational_cps n [(1,x)]; chained_carries_no_reduce_cps n p (seq 0 n)).
  End Carries.

  Section sub.
    Context (n:nat)
            (s:Z)
            (c:list (Z * Z))
            (coef:Z).

    Definition negate_snd_cps (a:list Z) : ~> list Z
      := let A := to_associational n a in
         let negA := Associational.negate_snd A in
         from_associational_cps n negA.

    Definition scmul_cps (x:Z) (a:list Z) : ~> list Z
      := let A := to_associational n a in
         let R := Associational.mul A [(1, x)] in
         from_associational_cps n R.

    Definition balance_cps : ~> list Z
      := (sc <- encode_cps n s c (s - Associational.eval c); v <- scmul_cps coef sc; return v).

    Definition sub_cps (a b:list Z) : ~> list Z
      := (balance <- balance_cps;
            ca <- add_cps n balance a;
            _b <- negate_snd_cps b;
            camb <- add_cps n ca _b;
            return camb).

    Definition opp_cps (a:list Z) : ~> list Z
      := sub_cps (zeros n) a.
  End sub.

  Section select.
    Definition zselect_cps (mask cond:Z) (p:list Z) : ~> _ :=
      fun T k => dlet t := RT_Z.zselect cond 0 mask in k (List.map (RT_Z.land t) p).

    Definition select (cond:Z) (if_zero if_nonzero:list Z) :=
      List.map (fun '(p, q) => RT_Z.zselect cond p q) (List.combine if_zero if_nonzero).
  End select.
End Positional.
End Positional.


Require Import compcert.common.Globalenvs.
Require Import compcert.common.Smallstep.
Require Import compcert.lib.Coqlib.
Require Import Seccomp.
Require Import CpdtTactics.

Definition semantics (p: program) :=
  Semantics step (initial_state p) final_state (Genv.globalenv p).

Lemma trace_E0:
  forall p s t s', Step (semantics p) s t s' -> t = nil.
Proof.
  intros.
  destruct H; auto.
Qed.

Lemma semantics_receptive:
  forall (p: program), receptive (semantics p).
Proof.
  intro.
  constructor; simpl; intros.

  exists s1.
  assert (t1 = t2).
  assert (t1 = nil).
  apply (trace_E0 p s t1 s1). auto.
  destruct H0; crush.
  crush.

  constructor.
  destruct H; auto.
Qed.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_or ===== *)

Definition bit_blast_or1 (g: generator) (a1 a2: literal) :generator * cnf * literal :=
  if (a1 == lit_tt) || (a2 == lit_tt) then (g, [::], lit_tt)
  else if (a1 == lit_ff) then (g, [::], a2)
       else if (a2 == lit_ff) then (g, [::], a1)
            else
              let (g', r) := gen g in
              (g', [:: [:: neg_lit r; a1; a2];
                      [:: r; neg_lit a1];
                      [:: r; neg_lit a2]], r).

Definition mk_env_or1 E g a1 a2 : env * generator * cnf * literal :=
  if (a1 == lit_tt) || (a2 == lit_tt) then (E, g, [::], lit_tt)
  else if a1 == lit_ff then (E, g, [::], a2)
       else if a2 == lit_ff then (E, g, [::], a1)
            else let (g', r) := gen g in
                 let E' := env_upd E (var_of_lit r)
                                   (interp_lit E a1 || interp_lit E a2) in
                 let cs := [:: [:: neg_lit r; a1; a2]; [:: r; neg_lit a1];
                              [:: r; neg_lit a2]] in
                 (E', g', cs, r).

Fixpoint bit_blast_or_zip g lsp : generator * cnf * word :=
  match lsp with
  | [::] => (g, [::], [::])
  | (l1, l2)::tl =>
      let '(g_hd, cs_hd, lrs_hd) := bit_blast_or1 g l1 l2 in
      let '(g_tl, cs_tl, lrs_tl) := bit_blast_or_zip g_hd tl in
      (g_tl, catrev cs_hd cs_tl, lrs_hd::lrs_tl)
  end.

Fixpoint mk_env_or_zip E g lsp : env * generator * cnf * word :=
  match lsp with
  | [::] => (E, g, [::], [::])
  | (l1, l2)::tl =>
    let '(E_hd, g_hd, cs_hd, lrs_hd) := mk_env_or1 E g l1 l2 in
    let '(E_tl, g_tl, cs_tl, lrs_tl) := mk_env_or_zip E_hd g_hd tl in
    (E_tl, g_tl, catrev cs_hd cs_tl, lrs_hd::lrs_tl)
  end.

Definition bit_blast_or g ls1 ls2 := bit_blast_or_zip g (extzip_ff ls1 ls2).

Definition mk_env_or E g ls1 ls2 := mk_env_or_zip E g (extzip_ff ls1 ls2).

Lemma bit_blast_or_zip_size_ss g lsp g' cs rlrs :
  bit_blast_or_zip g lsp = (g', cs, rlrs) ->
  size rlrs = size lsp.
Proof.
  elim: lsp g g' cs rlrs => [| [l1 l2] lsp IH] g g' cs rlrs //=.
  - case=> ? ? ?; subst. reflexivity.
  - dcase (bit_blast_or1 g l1 l2) => [[[g_hd cs_hd] lrs_hd] Hbb_hd].
    dcase (bit_blast_or_zip g_hd lsp) => [[[g_tl cs_tl] lrs_tl] Hbb_tl].
    case=> ? ? ?; subst. rewrite /=. rewrite (IH _ _ _ _ Hbb_tl). reflexivity.
Qed.

Lemma bit_blast_or_size_ss g ls1 ls2 g' cs rlrs :
  bit_blast_or g ls1 ls2 = (g', cs, rlrs) -> size ls1 = size ls2->
  size rlrs = size ls1.
Proof.
  rewrite /bit_blast_or. move=> Hbb Hs12. move: (bit_blast_or_zip_size_ss Hbb).
  rewrite /extzip_ff. rewrite size_extzip. rewrite Hs12 maxnn. by apply.
Qed.

Lemma bit_blast_or1_correct E g b1 b2 l1 l2 g' cs lr:
    bit_blast_or1 g l1 l2 = (g', cs, lr) ->
    enc_bit E l1 b1 -> enc_bit E l2 b2 ->
    interp_cnf E (add_prelude cs) ->
    enc_bit E lr (orb b1 b2).
Proof.
  rewrite /bit_blast_or1 /enc_bit.
  case Htt: ((l1 == lit_tt) || (l2 == lit_tt)).
  - case=> _ <- <- /eqP <- /eqP <-.
    move /orP: Htt. case => /eqP ->; rewrite add_prelude_empty; move=> ->.
    + done.
    + by rewrite orbT.
  - case Hff1: (l1 == lit_ff); last case Hff2: (l2 == lit_ff) .
    + case=> _ <- <- /eqP <- /eqP <- /=.
      rewrite add_prelude_empty /=; move=> Htt1.
      by rewrite (eqP Hff1) /= Htt1.
    + case=> _ <- <- /eqP <- /eqP <- /=;
      rewrite add_prelude_empty /=; move=> Htt1;
        by [rewrite (eqP Hff2) /= Htt1 orbF ] .
    + case=> _ <- <- /eqP <- /eqP <- /andP /= . case => [Htt1 Hcs].
      rewrite !interp_lit_neg_lit in Hcs . move: Hcs .
      by case: (E g); case: (interp_lit E l1); case: (interp_lit E l2) .
Qed.

Lemma mk_env_or1_is_bit_blast_or1 E g l1 l2 E' g' cs lr:
    mk_env_or1 E g l1 l2 = (E', g', cs, lr) ->
    bit_blast_or1 g l1 l2 = (g', cs, lr).
Proof.
  rewrite /mk_env_or1 /bit_blast_or1; intros;
    dite_hyps; dcase_hyps; subst; reflexivity .
Qed .

Lemma mk_env_or1_newer_gen E g l1 l2 E' g' cs lr:
    mk_env_or1 E g l1 l2 = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  rewrite /mk_env_or1 .
  case Htt :((l1 == lit_tt) || (l2 == lit_tt)) .
  - case => _ <- _ _; exact: Pos.leb_refl .
  - case Ht1: (l1 == lit_ff); last case Ht2: (l2 == lit_ff) .
    + case => _ <- _ _; exact: Pos.leb_refl .
    + case => _ <- _ _; exact: Pos.leb_refl .
    + case => _ <- _ _ . apply /pos_leP . rewrite Pos.add_1_r .
      apply: Pos.lt_le_incl . exact: Pos.lt_succ_diag_r .
Qed.

Lemma mk_env_or1_newer_res E g l1 l2 E' g' cs lr:
    mk_env_or1 E g l1 l2 = (E', g', cs, lr) ->
    newer_than_lit g l1 -> newer_than_lit g l2 ->
    newer_than_lit g' lr.
Proof.
  rewrite /mk_env_or1.
  case Htt: ((l1 == lit_tt) || (l2 == lit_tt)) .
  - case => _ <- _ <- . by case/orP: Htt; move/eqP => ->.
  - case Ht1 : (l1 == lit_ff); last case Ht2: (l2 == lit_ff) .
    + case => _ <- _ <- . done .
    + case => _ <- _ <- . done .
    + move => [[_ g0'] _] . case => <- _ _. rewrite -g0' .
      exact: (newer_than_var_add_diag_r) .
Qed .

Lemma mk_env_or1_newer_cnf E g l1 l2 E' g' cs lr:
    mk_env_or1 E g l1 l2 = (E', g', cs, lr) ->
    newer_than_lit g l1 -> newer_than_lit g l2 ->
    newer_than_cnf g' cs.
Proof.
  move=> Henv.
  move: Henv . rewrite /mk_env_or1 /= .
  case Htt: ((l1 == lit_tt) || (l2 == lit_tt)) .
  - case => _ _ <- _ . done .
  - case Ht1 : (l1 == lit_ff); last case Ht2 : (l2 == lit_ff) .
    + case => _ _ <- _ . done .
    + case => _ _ <- _ . done .
    + case => _ <- <- _ {Htt Ht1 Ht2} /= Hgl1 Hgl2.
      move: (newer_than_lit_le_newer Hgl1 (pos_leb_add_diag_r g 1)) => Hg1l1 .
      move: (newer_than_lit_le_newer Hgl2 (pos_leb_add_diag_r g 1)) => Hg1l2 .
      rewrite !newer_than_lit_neg Hg1l1 Hg1l2 .
      rewrite /newer_than_lit /var_of_lit /= .
      rewrite (newer_than_var_add_diag_r g 1) .
      done .
Qed .

Lemma mk_env_or1_preserve E g l1 l2 E' g' cs lr:
    mk_env_or1 E g l1 l2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_or1.
  case Htt: ((l1 == lit_tt) || (l2 == lit_tt)) .
  - case => <- _ _ _. done.
  - case Ht1: (l1 == lit_ff); last case Ht2: (l2 == lit_ff) .
      * case => <- _ _ _; exact: env_preserve_refl .
      * case => <- _ _ _; exact: env_preserve_refl .
      * case => <- _ _ _; exact: env_upd_eq_preserve .
Qed.

Lemma mk_env_or1_sat E g l1 l2 E' g' cs lr:
    mk_env_or1 E g l1 l2 = (E', g', cs, lr) ->
    newer_than_lit g l1 ->
    newer_than_lit g l2 ->
    interp_cnf E' cs.
Proof.
  move=> H Hgl1 Hgl2.
  move: H.
  rewrite /mk_env_or1.
  case Htt: ((l1 == lit_tt) || (l2 == lit_tt)) .
  - case => <- _ <- _. done.
  - case Ht1: (l1 == lit_ff); last case Ht2: (l2 == lit_ff) .
      * by case => <- _ <- _.
      * by case => <- _ <- _.
      * case => <- _ <- _.
        rewrite !interp_cnf_cons /= !interp_lit_neg_lit .
        rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hgl1)).
        rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hgl2)).
        by case: (interp_lit E l1); case: (interp_lit E l2);
        rewrite /interp_lit !env_upd_eq .
Qed.

Lemma bit_blast_or_zip_correct E g bsp lsp g' cs lrs :
  bit_blast_or_zip g lsp = (g', cs, lrs) ->
  enc_bits E (unzip1 lsp) (unzip1 bsp) -> enc_bits E (unzip2 lsp) (unzip2 bsp) ->
  interp_cnf E (add_prelude cs) -> enc_bits E lrs (map (fun e => orb e.1 e.2) bsp).
Proof.
  elim: lsp E g bsp g' cs lrs => [| [l1_hd l2_hd] lsp_tl IH] E g bsp g' cs lrs /=.
  - rewrite !enc_bits_nil_l unzip1_l_nil. case=> _ <- <- /eqP -> _ _ /=.
    exact: enc_bits_nil.
  - dcase (bit_blast_or1 g l1_hd l2_hd) => [[[g_hd cs_hd] lrs_hd] Hbb_hd].
    dcase (bit_blast_or_zip g_hd lsp_tl) => [[[g_tl cs_tl] lrs_tl] Hbb_tl].
    case=> _ <- <- /=. case: bsp => [| [bsp_hd1 bsp_hd2] bsp_tl] //=.
    rewrite !enc_bits_cons. move=> /andP [Henc1hd Henc1tl] /andP [Henc2hd Henc2tl].
    rewrite add_prelude_catrev => /andP [Hpre_hd Hpre_tl].
    rewrite (bit_blast_or1_correct Hbb_hd Henc1hd Henc2hd Hpre_hd) andTb.
    by rewrite (IH _ _ _ _ _ _ Hbb_tl Henc1tl Henc2tl Hpre_tl).
Qed.

Lemma bit_blast_or_correct g bs1 bs2 E ls1 ls2 g' cs lrs :
  bit_blast_or g ls1 ls2 = (g', cs, lrs) ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 -> interp_cnf E (add_prelude cs) ->
  enc_bits E lrs (orB bs1 bs2).
Proof.
  rewrite /bit_blast_or => Hbb Henc1 Henc2 Hcs.
  move: (enc_bits_size Henc1) (enc_bits_size Henc2) => Hs1 Hs2.
  move: (add_prelude_enc_bit_tt Hcs) => Henctt.
  exact: (bit_blast_or_zip_correct Hbb
                                    (enc_bits_unzip1_extzip Henctt Henc1 Henc2)
                                    (enc_bits_unzip2_extzip Henctt Henc1 Henc2) Hcs).
Qed.

Lemma mk_env_or_zip_is_bit_blast_or_zip E g lsp E' g' cs lrs :
  mk_env_or_zip E g lsp = (E', g', cs, lrs) ->
  bit_blast_or_zip g lsp = (g', cs, lrs).
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> _ <- <- <-.
  - dcase (mk_env_or1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lrs_hd] Henv_hd].
    dcase (mk_env_or_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lrs_tl] Henv_tl].
    case=> _ <- <- <-. rewrite (mk_env_or1_is_bit_blast_or1 Henv_hd).
    by rewrite (IH _ _ _ _ _ _ Henv_tl).
Qed.

Lemma mk_env_or_is_bit_blast_or E g ls1 ls2 E' g' cs lrs :
  mk_env_or E g ls1 ls2 = (E', g', cs, lrs) ->
  bit_blast_or g ls1 ls2 = (g', cs, lrs).
Proof. exact: mk_env_or_zip_is_bit_blast_or_zip. Qed.

Lemma mk_env_or_zip_newer_gen E g lsp E' g' cs lrs :
  mk_env_or_zip E g lsp = (E', g', cs, lrs) -> (g <=? g')%positive.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - case=> _ <- _ _. exact: Pos.leb_refl.
  - dcase (mk_env_or1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_or_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> _ <- _ _. apply: (pos_leb_trans (mk_env_or1_newer_gen Henv_hd)).
    exact: (IH _ _ _ _ _ _ Henv_tl).
Qed.

Lemma mk_env_or_newer_gen E g ls1 ls2 E' g' cs lrs :
  mk_env_or E g ls1 ls2 = (E', g', cs, lrs) -> (g <=? g')%positive.
Proof. exact: mk_env_or_zip_newer_gen. Qed.

Lemma mk_env_or_zip_newer_res E g lsp E' g' cs lrs :
  mk_env_or_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_lits g' lrs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> _ <- _ <- _ _.
  - dcase (mk_env_or1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_or_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> _ <- _ <-. move=> /andP [Hnew1hd Hnew1tl] /andP [Hnew2hd Hnew2tl].
    move: (mk_env_or1_newer_gen Henv_hd) => Hnewg1.
    move: (mk_env_or_zip_newer_gen Henv_tl) => Hnewg2.
    move: (mk_env_or1_newer_res Henv_hd Hnew1hd Hnew2hd)=> Hnew.
    rewrite newer_than_lits_cons.
    apply/andP; split; first by t_auto_newer.
    by rewrite (IH _ _ _ _ _ _ Henv_tl); t_auto_newer.
Qed.

Lemma mk_env_or_newer_res E g ls1 ls2 E' g' cs lrs :
  mk_env_or E g ls1 ls2 = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_lits g' lrs.
Proof.
  rewrite /mk_env_or => Henv Hnewtt Hnew1 Hnew2.
  apply: (mk_env_or_zip_newer_res Henv); by t_auto_newer.
Qed.

Lemma mk_env_or_zip_newer_cnf E g lsp E' g' cs lrs :
  mk_env_or_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_cnf g' cs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> _ <- <- _ _ _.
  - dcase (mk_env_or1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_or_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> _ <- <- _. move=> /andP [Hnew1hd Hnew1tl] /andP [Hnew2hd Hnew2tl].
    move: (mk_env_or1_newer_gen Henv_hd) => Hnewg1.
    move: (mk_env_or_zip_newer_gen Henv_tl) => Hnewg2.
    move: (mk_env_or1_newer_cnf Henv_hd Hnew1hd Hnew2hd) => Hnew1.
    rewrite newer_than_cnf_catrev. apply/andP; split; first by t_auto_newer.
    apply: (IH _ _ _ _ _ _ Henv_tl); by t_auto_newer.
Qed.

Lemma mk_env_or_newer_cnf E g ls1 ls2 E' g' cs lrs :
  mk_env_or E g ls1 ls2 = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_or => Henv Hnewtt Hnew1 Hnew2.
  apply: (mk_env_or_zip_newer_cnf Henv); by t_auto_newer.
Qed.

Lemma mk_env_or_zip_preserve E g lsp E' g' cs lrs :
  mk_env_or_zip E g lsp = (E', g', cs, lrs) -> env_preserve E E' g.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> <- _ _ _.
  - dcase (mk_env_or1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_or_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> <- _ _ _. move: (mk_env_or1_preserve Henv_hd) => Hpre_hd.
    move: (IH _ _ _ _ _ _ Henv_tl) => Hpre_tl.
    move: (mk_env_or1_newer_gen Henv_hd) => Hnewg1. by t_auto_preserve.
Qed.

Lemma mk_env_or_preserve E g ls1 ls2 E' g' cs lrs :
  mk_env_or E g ls1 ls2 = (E', g', cs, lrs) -> env_preserve E E' g.
Proof. exact: mk_env_or_zip_preserve. Qed.

Lemma mk_env_or_zip_sat E g lsp E' g' cs lrs :
  mk_env_or_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  interp_cnf E' cs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> <- _ <- _ _ _.
  - dcase (mk_env_or1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_or_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> <- _ <- _. move=> /andP [Hnew1hd Hnew1tl] /andP [Hnew2hd Hnew2tl].
    rewrite interp_cnf_catrev.
    move: (mk_env_or1_newer_cnf Henv_hd Hnew1hd Hnew2hd) => Hnew1.
    move: (mk_env_or1_newer_gen Henv_hd) => Hnewg1.
    move: (mk_env_or1_sat Henv_hd Hnew1hd Hnew2hd) => Hcs_hd.
    move: (mk_env_or1_preserve Henv_hd) => Hpre_hd.
    move: (mk_env_or_zip_preserve Henv_tl) => Hpre_tl. apply/andP; split.
    (* interp_cnf E_tl cs_hd *)
    - rewrite (env_preserve_cnf Hpre_tl); last by t_auto_newer. assumption.
    - apply: (IH _ _ _ _ _ _ Henv_tl); by t_auto_newer.
Qed.

Lemma mk_env_or_sat E g ls1 ls2 E' g' cs lrs :
  mk_env_or E g ls1 ls2 = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_or => Henv Hnewtt Hnew1 Hnew2.
  apply: (mk_env_or_zip_sat Henv); by t_auto_newer.
Qed.

Lemma mk_env_or1_env_equal E1 E2 g l1 l2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_or1 E1 g l1 l2 = (E1', g1', cs1, lr1) ->
  mk_env_or1 E2 g l1 l2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_or1 => Heq. case ((l1 == lit_tt) || (l2 == lit_tt)).
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - case (l1 == lit_ff).
    + case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
    + case (l2 == lit_ff).
      * case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
      * dcase (gen g) => [[g' r] Hg]. case=> ? ? ? ?; case=> ? ? ? ?; subst.
        repeat split. rewrite (env_equal_interp_lit l1 Heq) (env_equal_interp_lit l2 Heq).
        apply: env_equal_upd. assumption.
Qed.

Lemma mk_env_or_zip_env_equal E1 E2 g lsp E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_or_zip E1 g lsp = (E1', g1', cs1, lrs1) ->
  mk_env_or_zip E2 g lsp = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  elim: lsp E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2
  => [| [l1 l2] lsp IH] //= E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 Heq.
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - dcase (mk_env_or1 E1 g l1 l2) => [[[[E_hd1 g_hd1] cs_hd1] lrs_hd1] Hvhd1].
    dcase (mk_env_or1 E2 g l1 l2) => [[[[E_hd2 g_hd2] cs_hd2] lrs_hd2] Hvhd2].
    move: (mk_env_or1_env_equal Heq Hvhd1 Hvhd2) => [Heq' [? [? ?]]]; subst.
    dcase (mk_env_or_zip E_hd1 g_hd2 lsp) => [[[[E_tl1 g_tl1] cs_tl1] lrs_tl1] Hvtl1].
    dcase (mk_env_or_zip E_hd2 g_hd2 lsp) => [[[[E_tl2 g_tl2] cs_tl2] lrs_tl2] Hvtl2].
    move: (IH _ _ _ _ _ _ _ _ _ _ _ Heq' Hvtl1 Hvtl2) => [Heq'' [? [? ?]]]; subst.
    case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.

Lemma mk_env_or_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_or E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_or E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof. exact: mk_env_or_zip_env_equal. Qed.


Require Import List Arith Bool.
Require Import MirrorShard.Expr MirrorShard.Env.
Require Import MirrorShard.Prover.
Require Import Word.
Require Import sep.Array IL.

Set Implicit Arguments.
Set Strict Implicit.

Local Notation pcT := (tvType 0).
Local Notation stT := (tvType 1).
Local Notation wordT := (tvType 0).
Local Notation natT := (tvType 4).
Local Notation listWT := (tvType 5).

Local Notation wltF := 4.
Local Notation natToWF := 5.
Local Notation lengthF := 6.
Local Notation selF := 7.
Local Notation updF := 8.

Section ArrayBoundProver.
  Variable types' : list type.
  Definition types := Array.types types'.
  Variable funcs' : functions types.
  Definition funcs := Array.funcs funcs'.

  Fixpoint deupd (e : expr types) : expr types :=
    match e with
      | Func updF (e' :: _ :: _ :: nil) => deupd e'
      | _ => e
    end.

  Definition factIn (e : expr types) : option (expr types * expr types) :=
    match e with
      | Func wltF (i :: Func natToWF (Func lengthF (a :: nil) :: nil) :: nil) =>
        Some (i, deupd a)
      | _ => None
    end.

  Definition boundSummary := list (expr types * expr types).

  Definition boundLearn1 (summ : boundSummary) (e : expr types) : boundSummary :=
    match factIn e with
      | None => summ
      | Some fact => fact :: summ
    end.

  Fixpoint boundLearn (summ : boundSummary) (es : list (expr types)) : boundSummary :=
    match es with
      | nil => summ
      | e :: es => boundLearn1 (boundLearn summ es) e
    end.

  Definition boundSummarize := boundLearn nil.

  Fixpoint hypMatches (fact : expr types * expr types) (summ : boundSummary) : bool :=
    match summ with
      | nil => false
      | (i, a) :: summ' => (expr_seq_dec i (fst fact) && expr_seq_dec a (snd fact)) || hypMatches fact summ'
    end.

  Definition boundProve (summ : boundSummary) (goal : expr types) :=
    match factIn goal with
      | None => false
      | Some fact => hypMatches fact summ
    end.

  Fixpoint size (e : expr types) : nat :=
    match e with
      | Const _ _ => O
      | Var _ => O
      | UVar _ => O
      | Func _ es => fold_left plus (map size es) 1
      | Equal _ e1 e2 => size e1 + size e2
      | Not e1 => size e1
    end.

  Lemma plus_monotone : forall ls n, (fold_left plus ls n >= n)%nat.
    induction ls; simpl; intuition.
    specialize (IHls (n + a)); omega.
  Qed.

  Lemma deupd_correct : forall uvars vars sz (e : expr types),
    (size e <= sz)%nat
    -> match exprD funcs uvars vars e listWT with
         | None => True
         | Some ev =>
           match exprD funcs uvars vars (deupd e) listWT with
             | None => False
             | Some dv => length dv = length ev
           end
       end.
    induction sz; destruct e; simpl size; simpl deupd; simpl exprD; intuition eauto; try discriminate;
      try solve [ destruct (equiv_dec t listWT); auto
        | match goal with
            | [ |- match ?E with Some _ => _ | None => _ end ] => destruct E; auto
          end ].

    specialize (plus_monotone (map size l) 1); omega.

    Lemma repr_nth_error : forall A (v : A) r ls n,
      nth_error r.(footprint) n = Some (Some v)
      -> nth_error (repr r ls) n = Some v.
      destruct r; simpl; induction footprint; simpl; intuition.
      destruct n; simpl in *; discriminate.
      destruct n; simpl in *.
      injection H; clear H; intros; subst; reflexivity.
      eapply IHfootprint in H; clear IHfootprint.
      destruct a; eauto.
    Qed.

    do 8 (destruct f; [ t | ]).
    destruct f; [ | t ].

    replace (nth_error funcs 8) with (Some (upd_r types'))
      by (unfold funcs, Array.funcs; erewrite repr_nth_error; reflexivity).
    simpl.
    do 3 (destruct l; [ t | ]).
    destruct l; [ | t ].
    simpl.
    specialize (IHsz e).
    simpl in H.
    assert (size e <= sz)%nat by omega; intuition.
    destruct (exprD funcs uvars vars e listWT); auto.
    destruct (exprD funcs uvars vars (deupd e) listWT); try tauto.
    destruct (exprD funcs uvars vars e0 wordT); auto.
    destruct (exprD funcs uvars vars e1 wordT); auto.
    Require Import Arrays.
    rewrite upd_length; assumption.
  Qed.

  Ltac duh' := match goal with
                 | [ |- match ?E with Some _ => _ | _ => _ end ] => destruct E
               end; try tauto.

  Ltac duh := solve [ repeat duh' ].

  Lemma factIn_correct : forall uvars vars (e : expr types),
    match exprD funcs uvars vars e tvProp with
      | None => True
      | Some P => match factIn e with
                    | None => True
                    | Some (i, a) =>
                      exists iv, exprD funcs uvars vars i wordT = Some iv
                        /\ exists av, exprD funcs uvars vars a listWT = Some av
                          /\ (P = (iv < $(length av)))
                  end
    end.
    destruct e; simpl factIn; simpl exprD; intuition; try duh.
    do 5 (destruct f; try duh).
    do 3 (destruct l; try duh).

    Focus 2.
    destruct (nth_error funcs 4); auto.
    destruct (equiv_dec (Range s) tvProp); auto.
    destruct s; simpl in e2.
    hnf in e2; subst.

    simpl applyD.
    duh'.
    destruct e0; auto.
    do 6 (destruct f; auto).
    destruct l0; auto.
    destruct e0; auto.
    do 7 (destruct f; auto).
    do 2 (destruct l1; auto).
    destruct l0; auto.

    replace (nth_error funcs 4) with (Some (ILEnv.wlt_r types))
      by (unfold funcs, Array.funcs; erewrite repr_nth_error; reflexivity).
    match goal with
      | [ |- match ?E with None => _ | Some _ => _ end ] =>
        let E' := eval simpl in E in change E with E'
    end.
    case_eq (exprD funcs uvars vars e wordT); intuition.
    case_eq (exprD funcs uvars vars e0 wordT); intuition.
    destruct e0; auto.
    do 6 (destruct f; auto).
    destruct l; auto.
    destruct e0; auto.
    do 7 (destruct f; auto).
    do 2 (destruct l0; auto).
    destruct l; auto.
    simpl in H0.
    specialize (deupd_correct uvars vars (sz := size e0) e0).
    assert (size e0 <= size e0)%nat by auto; intuition.
    destruct (exprD funcs uvars vars e0 listWT); try discriminate.
    destruct (exprD funcs uvars vars (deupd e0) listWT); try tauto.
    do 2 esplit; eauto.
    do 2 esplit; eauto.
    injection H0; clear H0; intros; subst.
    rewrite H3.
    reflexivity.
  Qed.

  Section vars.
    Variables uvars vars : env types.

    Definition pairValid (p : expr types * expr types) :=
      exists i, exprD funcs uvars vars (fst p) wordT = Some i
        /\ exists a, exprD funcs uvars vars (snd p) listWT = Some a
          /\ i < $(length a).

    Definition boundValid (summ : boundSummary) :=
      List.Forall pairValid summ.

    Theorem boundLearn1Correct : forall sum,
      boundValid sum
      -> forall hyp, Provable funcs uvars vars hyp
        -> boundValid (boundLearn1 sum hyp).
    Proof.
      unfold Provable, boundLearn1, boundValid; intros.
      specialize (factIn_correct uvars vars hyp).
      destruct (exprD funcs uvars vars hyp tvProp); try tauto.
      destruct (factIn hyp); intuition.
      destruct p.
      do 2 destruct H1.
      do 2 destruct H2.
      subst.
      unfold pairValid.
      constructor; eauto.
    Qed.

    Hint Resolve boundLearn1Correct.

    Theorem boundLearnCorrect : forall sum,
      boundValid sum
      -> forall hyps, AllProvable funcs uvars vars hyps
        -> boundValid (boundLearn sum hyps).
    Proof.
      induction hyps; simpl; intuition.
    Qed.

    Theorem boundSummarizeCorrect : forall hyps,
      AllProvable funcs uvars vars hyps
      -> boundValid (boundSummarize hyps).
      intros; apply boundLearnCorrect; hnf; auto.
    Qed.

    Lemma hypMatchesCorrect : forall p sum,
      boundValid sum
      -> hypMatches p sum = true
      -> pairValid p.
      induction sum as [ | [ ] ]; simpl; intuition.
      apply orb_prop in H0; intuition.
      apply andb_prop in H1; intuition.
      apply expr_seq_dec_correct in H0.
      apply expr_seq_dec_correct in H2.
      subst.
      inversion H; auto.
      inversion H; auto.
    Qed.
  End vars.

  Hint Resolve boundLearnCorrect boundSummarizeCorrect.

  Theorem boundProverCorrect : ProverCorrect funcs boundValid boundProve.
  Proof.
    eapply ProverCorrect_ProverCorrect'.
    hnf; intros.
    unfold boundProve in H0.
    hnf.
    specialize (factIn_correct uvars vars goal).
    destruct H1.
    rewrite H1 in *.
    destruct (factIn goal); try discriminate.
    eapply hypMatchesCorrect in H0; eauto.
    destruct H0.
    destruct p.
    destruct H0.
    destruct H2.
    destruct H2.
    intro.
    destruct H4.
    destruct H4.
    destruct H5.
    destruct H5.
    subst.
    unfold fst, snd in *.
    congruence.
  Qed.

  Hint Resolve boundProverCorrect.

  Lemma boundValid_weaken : forall (u g : env types) (f : boundSummary)
    (ue ge : list (sigT (tvarD types))),
    boundValid u g f -> boundValid (u ++ ue) (g ++ ge) f.
    induction 1; simpl; intuition; constructor; auto.
    hnf in H; hnf.
    do 2 destruct H.
    do 2 destruct H1.
    eauto 10 using exprD_weaken.
  Qed.

  Hint Resolve boundValid_weaken.

  Definition boundProver : ProverT types :=
    {| Facts := boundSummary
      ; Summarize := boundSummarize
      ; Learn := boundLearn
      ; Prove := boundProve |}.

  Definition boundProver_correct : ProverT_correct boundProver funcs.
    eapply Build_ProverT_correct with (Valid := boundValid); eauto.
  Qed.

End ArrayBoundProver.

Definition BoundProver : ProverPackage :=
{| ProverTypes := Array.types_r
 ; ProverFuncs := Array.funcs_r
 ; Prover_correct := boundProver_correct
|}.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section RefineRel.

  Record relate_RData (hadt: RData) (ladt: RData) :=
    mkrelate_RData {
            id_rdata: hadt = ladt;
            repl_eq: repl ladt = fun l s => replay 1 l s;
            valid_o: ValidOracle 1 (oracle ladt)
        }.

End RefineRel.


Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relations.

Require Import compcert.exportclight.Clightdefs.
Require Import compcert.cfrontend.Ctypes. (*NEW*)
Require Import compcert.lib.Axioms.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.lib.Maps.
Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Memdata.
Require Import compcert.common.Memtype.
Require Import compcert.common.Memory.
Require Export VST.sepcomp.Address.

Lemma range_dec: forall a b c: Z, {a <= b < c}+{~(a <= b < c)}.
Proof. intros. destruct (zle a b). destruct (zlt b c). left; split; auto.
  right;  omega. right; omega.
Qed.

Require Export VST.msl.eq_dec.

Instance EqDec_ident: EqDec ident := ident_eq.

Instance EqDec_byte: EqDec byte := Byte.eq_dec.

Instance EqDec_type: EqDec type := type_eq.
Instance EqDec_int: EqDec int := Int.eq_dec.
Instance EqDec_int64: EqDec int64 := Int64.eq_dec.
Instance EqDec_float: EqDec float := Float.eq_dec.
Instance EqDec_float32: EqDec float32 := Float32.eq_dec.

Instance EqDex_ptr : EqDec ptrofs := Ptrofs.eq_dec. (*NEW*)

Instance EqDec_memval: EqDec memval.
Proof.
 hnf; repeat decide equality; apply eq_dec.
Defined.

Instance EqDec_val: EqDec val.
Proof.
hnf. decide equality; apply eq_dec.
Defined.

Instance EqDec_quantity: EqDec quantity.
Proof.
hnf. decide equality.
Defined.

Definition access_at (m: mem) (loc: address) (k: perm_kind): option permission :=
   PMap.get (fst loc) (Mem.mem_access m) (snd loc) k.

Lemma perm_access: forall m b ofs k p,
    Mem.perm m b ofs k p <-> (Mem.perm_order'' (access_at m (b,ofs) k) (Some p)).
Proof. reflexivity. Qed.

Lemma access_perm: forall m b ofs k p,
  access_at m (b, ofs) k = Some p ->
  Mem.perm m b ofs k p.
Proof.
intros.
unfold Mem.perm, Mem.perm_order'.
unfold access_at in H. simpl in H.
rewrite H; auto.
constructor.
Qed.

Lemma access_cur_max: forall m a,
           Mem.perm_order'' (access_at m a Max)  (access_at m a Cur).
Proof.
 destruct a as [b z].
 destruct (access_at m (b,z) Cur) eqn:Hc.
 rewrite <- perm_access.
 apply (Mem.perm_cur_max m b z).
 rewrite perm_access. rewrite Hc. constructor.
 destruct (access_at m (b, z) Max); constructor.
Qed.

Lemma invalid_noaccess: forall m b ofs k,
     ~Mem.valid_block m b -> access_at m (b, ofs) k = None.
Proof. intros; apply Mem.nextblock_noaccess. assumption. Qed.

Lemma access_empty: forall a k, access_at Mem.empty a k = None.
Proof.
  intros. unfold access_at, Mem.empty; simpl. rewrite PMap.gi. reflexivity.
Qed.

Transparent Mem.alloc.

Theorem alloc_access_other:
  forall m1 lo hi m2 b, Mem.alloc m1 lo hi = (m2, b) ->
  forall b' ofs k,
  b'<>b \/ (ofs < lo \/ ofs >= hi) ->
  access_at m1 (b', ofs) k = access_at m2 (b', ofs) k.
Proof.
 intros.
pose proof (Mem.nextblock_noaccess m1 b ofs k).
pose proof (Mem.alloc_result _ _ _ _ _ H).
unfold access_at; inversion H; clear H; subst; simpl.
destruct (eq_block b' (Mem.nextblock m1)).
destruct H0; try contradiction.
subst b'.
rewrite PMap.gss.
destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; apply H1; apply Plt_strict.
rewrite PMap.gso by auto. auto.
Qed.

Theorem alloc_access_same:
  forall m1 lo hi m2 b, Mem.alloc m1 lo hi = (m2, b) ->
  forall ofs k,
  lo <= ofs < hi -> access_at m2 (b,ofs) k = Some Freeable.
Proof.
 intros.
 inversion H; clear H; subst. unfold access_at; simpl.
 rewrite PMap.gss.
destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
Qed.

Opaque Mem.alloc.
Transparent Mem.free.

Lemma access_free:
  forall m1 b lo hi,
  (forall ofs, lo <= ofs < hi -> access_at m1 (b,ofs) Cur = Some Freeable) ->
  { m2: mem | Mem.free m1 b lo hi = Some m2 }.
Proof.
 intros.
 unfold Mem.free.
 destruct (Mem.range_perm_dec m1 b lo hi Cur Freeable).
 eauto.
 contradiction n; clear n.
 hnf; intros. unfold Mem.perm. unfold access_at in H.
 simpl in H; rewrite H by auto. constructor.
Qed.

Lemma free_access:
  forall m1 b lo hi m2, Mem.free m1 b lo hi = Some m2 ->
  (forall ofs, lo <= ofs < hi ->
      access_at m1 (b,ofs) Cur = Some Freeable /\ access_at m2 (b,ofs) Max = None).
Proof.
 intros.
 unfold Mem.free in H.
 destruct (Mem.range_perm_dec m1 b lo hi Cur Freeable); inversion H; clear H; subst.
 specialize (r _ H0).
 hnf in r.
 unfold access_at. simpl.
 destruct ((Mem.mem_access m1) !! b ofs Cur); try contradiction.
 assert (p=Freeable) by (destruct p; inversion r; auto). subst p.
 split; auto.
 simpl. rewrite PMap.gss.
 destruct (zle lo ofs), (zlt ofs hi); try omega. reflexivity.
Qed.

Lemma free_access_other:
  forall m1 bf lo hi m2, Mem.free m1 bf lo hi = Some m2 ->
  forall b ofs k,
  b <> bf \/ ofs < lo \/ hi <= ofs ->
  access_at m1 (b,ofs) k = access_at m2 (b,ofs) k.
Proof.
 intros.
 unfold Mem.free in H.
 destruct (Mem.range_perm_dec m1 bf lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 destruct (eq_block b bf).
 subst bf; rewrite PMap.gss.
 destruct H0. contradiction H; auto.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 rewrite PMap.gso by auto. reflexivity.
Qed.

Opaque Mem.free.

Lemma access_drop_1:
  forall m b lo hi p m', Mem.drop_perm m b lo hi p = Some m' ->
  (forall ofs, lo <= ofs < hi ->
     forall k,
     access_at m (b, ofs) k = Some Freeable /\ access_at m' (b, ofs) k = Some p).
Proof.
 intros.
 unfold Mem.drop_perm in H.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 rewrite PMap.gss.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 split; auto.
 specialize (r _ H0). hnf in r. destruct ( (Mem.mem_access m) !! b ofs Cur) eqn:?; try contradiction.
 assert (p0=Freeable) by (destruct p0; inv r; auto). subst.
 pose proof (Mem.access_max m b ofs).
 rewrite Heqo in H.
 destruct k; auto.
 destruct ((Mem.mem_access m) !! b ofs Max); inv H; auto.
Qed.

Lemma access_drop_2:
  forall m b lo hi p,
  (forall ofs, lo <= ofs < hi -> access_at m (b,ofs) Cur = Some Freeable) ->
  { m' | Mem.drop_perm m b lo hi p = Some m' }.
Proof.
 intros.
 unfold Mem.drop_perm.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable).
 eauto.
 contradiction n; hnf; intros.
 specialize (H _ H0).
 unfold access_at in *.  hnf. simpl in *; rewrite H. constructor.
Qed.

Lemma access_drop_3:
  forall m b lo hi p m', Mem.drop_perm m b lo hi p = Some m' ->
  forall b' ofs k, b' <> b \/ ofs < lo \/ hi <= ofs ->
    access_at m (b', ofs) k = access_at m' (b',ofs) k.
Proof.
 intros.
 unfold Mem.drop_perm in H.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 destruct (eq_block b' b).
 subst. rewrite PMap.gss.
 destruct H0.
 contradiction H; auto.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 rewrite PMap.gso by auto.
 auto.
Qed.

Lemma storebytes_access:
 forall m1 b ofs bytes m2 (STORE: Mem.storebytes m1 b ofs bytes = Some m2),
  access_at m1 = access_at m2.
Proof.
intros.
apply extensionality ;intros [b' z].
apply extensionality ;intro k.
apply Mem.storebytes_access in STORE.
unfold access_at; f_equal; auto.
Qed.

Lemma store_access:
 forall chunk m1 b ofs v m2 (STORE: Mem.store chunk m1 b ofs v = Some m2),
  access_at m1 = access_at m2.
Proof.
intros.
apply extensionality; intros [b' z'].
apply extensionality ;intro k.
unfold access_at. apply Mem.store_access in STORE. rewrite STORE; auto.
Qed.

Lemma perm_order'_dec_fiddle:
  forall y x, y = Some x ->
     proj_sumbool (Mem.perm_order'_dec y Nonempty) = true.
Proof.
intros. subst. simpl.
unfold Mem.perm_order_dec. destruct x; reflexivity.
Qed.

Lemma access_at_valid_pointer:
  forall m b ofs p, access_at m (b,ofs) Cur = Some p ->
   Mem.valid_pointer m b ofs = true.
Proof.
intros.
unfold access_at, Mem.valid_pointer in *.
simpl in *.
apply perm_order'_dec_fiddle with p.
auto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Ring_tac BinList Ring_polynom InitialRing.
Require Export Field_theory.

 (* syntaxification *)
 Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv :=
 let rec mkP t :=
    let f :=
    match Cst t with
    | InitialRing.NotConstant =>
        match t with
        | (radd ?t1 ?t2) =>
          fun _ =>
          let e1 := mkP t1 in
          let e2 := mkP t2 in constr:(FEadd e1 e2)
        | (rmul ?t1 ?t2) =>
          fun _ =>
          let e1 := mkP t1 in
          let e2 := mkP t2 in constr:(FEmul e1 e2)
        | (rsub ?t1 ?t2) =>
          fun _ =>
          let e1 := mkP t1 in
          let e2 := mkP t2 in constr:(FEsub e1 e2)
        | (ropp ?t1) =>
          fun _ => let e1 := mkP t1 in constr:(FEopp e1)
        | (rdiv ?t1 ?t2) =>
          fun _ =>
          let e1 := mkP t1 in
          let e2 := mkP t2 in constr:(FEdiv e1 e2)
        | (rinv ?t1) =>
          fun _ => let e1 := mkP t1 in constr:(FEinv e1)
        | (rpow ?t1 ?n) =>
          match CstPow n with
          | InitialRing.NotConstant =>
            fun _ =>
            let p := Find_at t fv in
            constr:(@FEX C p)
          | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c)
          end
        | _ =>
          fun _ =>
          let p := Find_at t fv in
          constr:(@FEX C p)
        end
    | ?c => fun _ => constr:(FEc c)
    end in
    f ()
 in mkP t.

Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
 let rec TFV t fv :=
  match Cst t with
  | InitialRing.NotConstant =>
      match t with
      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
      | (opp ?t1) => TFV t1 fv
      | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
      | (inv ?t1) => TFV t1 fv
      | (pow ?t1 ?n) =>
        match CstPow n with
        | InitialRing.NotConstant =>
            AddFvTail t fv
        | _ => TFV t1 fv
        end
      | _ => AddFvTail t fv
      end
  | _ => fv
  end
 in TFV t fv.

(* packaging the field structure *)

(* TODO: inline PackField into field_lookup *)
Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post :=
  let FLD :=
    match type of L1 with
    | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
                                      ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
        (fun proj =>
           proj Cst_tac Pow_tac pre post
             req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
    | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
    end in
  F FLD.

Ltac get_FldPre FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       pre).

Ltac get_FldPost FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       post).

Ltac get_L1 FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       L1).

Ltac get_SimplifyEqLemma FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       L2).

Ltac get_SimplifyLemma FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       L3).

Ltac get_L4 FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       L4).

Ltac get_CondLemma FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       cond_ok).

Ltac get_FldEq FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       req).

Ltac get_FldCarrier FLD :=
  let req := get_FldEq FLD in
  relation_carrier req.

Ltac get_RingFV FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       FV Cst_tac Pow_tac radd rmul rsub ropp rpow).

Ltac get_FFV FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).

Ltac get_RingMeta FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow).

Ltac get_Meta FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).

Ltac get_Hyp_tac FLD :=
  FLD ltac:
      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
           L1 L2 L3 L4 cond_ok =>
       let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
       fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).

Ltac get_FEeval FLD :=
  let L1 := get_L1 FLD in
  match type of L1 with
  | context
    [(@FEeval
      ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
       constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow)
  | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)"
  end.

(* simplifying the non-zero condition... *)

Ltac fold_field_cond req :=
  let rec fold_concl t :=
    match t with
      ?x /\ ?y =>
        let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
    | req ?x ?y -> False => constr:(~ req x y)
    | _ => t
    end in
  let ft := fold_concl Get_goal in
  change ft.

Ltac simpl_PCond FLD :=
  let req := get_FldEq FLD in
  let lemma := get_CondLemma FLD in
  try apply lemma;
  protect_fv "field_cond";
  fold_field_cond req;
  try exact I.

Ltac simpl_PCond_BEURK FLD :=
  let req := get_FldEq FLD in
  let lemma := get_CondLemma FLD in
  apply lemma;
  protect_fv "field_cond";
  fold_field_cond req.

(* Rewriting (field_simplify) *)
Ltac Field_norm_gen f n FLD lH rl :=
  let mkFV := get_RingFV FLD in
  let mkFFV := get_FFV FLD in
  let mkFE :=  get_Meta FLD in
  let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in
  let lemma_tac fv kont :=
    let lemma := get_SimplifyLemma FLD in
    (* reify equations of the context *)
    let lpe := get_Hyp_tac FLD fv lH in
    let vlpe := fresh "hyps" in
    pose (vlpe := lpe);
    let prh := proofHyp_tac lH in
    (* compute the normal form of the reified hyps *)
    let vlmp := fresh "hyps'" in
    let vlmp_eq := fresh "hyps_eq" in
    let mk_monpol := get_MonPol lemma in
    compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
    (* partially instantiate the lemma *)
    let lem := fresh "f_rw_lemma" in
    (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq)
     || fail "type error when building the rewriting lemma");
    (* continuation will call main_tac for all reified terms *)
    kont lem;
    (* at the end, cleanup *)
    (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in
  (* each instance of the lemma is simplified then passed to f *)
  let main_tac H := protect_fv "field" in H; f H in
  (* generate and use equations for each expression *)
  ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl;
  try simpl_PCond FLD.

Ltac Field_simplify_gen f FLD lH rl :=
  get_FldPre FLD ();
  Field_norm_gen f ring_subst_niter FLD lH rl;
  get_FldPost FLD ().

Ltac Field_simplify :=
  Field_simplify_gen ltac:(fun H => rewrite H).

Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
  let G := Get_goal in
  field_lookup (PackField Field_simplify) [] rl G.

Tactic Notation (at level 0)
  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
  let G := Get_goal in
  field_lookup (PackField Field_simplify) [lH] rl G.

Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=
  let G := Get_goal in
  let t := type of H in
  let g := fresh "goal" in
  set (g:= G);
  revert H;
  field_lookup (PackField Field_simplify) [] rl t;
  intro H;
  unfold g;clear g.

Tactic Notation "field_simplify"
    "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):=
  let G := Get_goal in
  let t := type of H in
  let g := fresh "goal" in
  set (g:= G);
  revert H;
  field_lookup (PackField Field_simplify) [lH] rl t;
  intro H;
  unfold g;clear g.

(*
Ltac Field_simplify_in hyp:=
   Field_simplify_gen ltac:(fun H => rewrite H in hyp).

Tactic Notation (at level 0)
  "field_simplify" constr_list(rl) "in" hyp(h) :=
  let t := type of h in
  field_lookup (Field_simplify_in h) [] rl t.

Tactic Notation (at level 0)
  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
  let t := type of h in
  field_lookup (Field_simplify_in h) [lH] rl t.
*)

(** Generic tactic for solving equations *)

Ltac Field_Scheme Simpl_tac n lemma FLD lH :=
  let req := get_FldEq FLD in
  let mkFV := get_RingFV FLD in
  let mkFFV := get_FFV FLD in
  let mkFE := get_Meta FLD in
  let Main_eq t1 t2 :=
    let fv := FV_hypo_tac mkFV req lH in
    let fv := mkFFV t1 fv in
    let fv := mkFFV t2 fv in
    let lpe := get_Hyp_tac FLD fv lH in
    let prh := proofHyp_tac lH in
    let vlpe := fresh "list_hyp" in
    let fe1 := mkFE t1 fv in
    let fe2 := mkFE t2 fv in
    pose (vlpe := lpe);
    let nlemma := fresh "field_lemma" in
    (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
     || fail "field anomaly:failed to build lemma");
    ProveLemmaHyps nlemma
      ltac:(fun ilemma =>
              apply ilemma
               || fail "field anomaly: failed in applying lemma";
              [ Simpl_tac | simpl_PCond FLD]);
    clear nlemma;
    subst vlpe in
  OnEquation req Main_eq.

(* solve completely a field equation, leaving non-zero conditions to be
   proved (field) *)

Ltac FIELD FLD lH rl :=
  let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
  let lemma := get_L1 FLD in
  get_FldPre FLD ();
  Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
  try exact I;
  get_FldPost FLD().

Tactic Notation (at level 0) "field" :=
  let G := Get_goal in
  field_lookup (PackField FIELD) [] G.

Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
  let G := Get_goal in
  field_lookup (PackField FIELD) [lH] G.

(* transforms a field equation to an equivalent (simplified) ring equation,
   and leaves non-zero conditions to be proved (field_simplify_eq) *)
Ltac FIELD_SIMPL FLD lH rl :=
  let Simpl := (protect_fv "field") in
  let lemma := get_SimplifyEqLemma FLD in
  get_FldPre FLD ();
  Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
  get_FldPost FLD ().

Tactic Notation (at level 0) "field_simplify_eq" :=
  let G := Get_goal in
  field_lookup (PackField FIELD_SIMPL) [] G.

Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=
  let G := Get_goal in
  field_lookup (PackField FIELD_SIMPL) [lH] G.

(* Same as FIELD_SIMPL but in hypothesis *)

Ltac Field_simplify_eq n FLD lH :=
  let req := get_FldEq FLD in
  let mkFV := get_RingFV FLD in
  let mkFFV := get_FFV FLD in
  let mkFE := get_Meta FLD in
  let lemma := get_L4 FLD in
  let hyp := fresh "hyp" in
  intro hyp;
  OnEquationHyp req hyp ltac:(fun t1 t2 =>
      let fv := FV_hypo_tac mkFV req lH in
      let fv := mkFFV t1 fv in
      let fv := mkFFV t2 fv in
      let lpe := get_Hyp_tac FLD fv lH in
      let prh := proofHyp_tac lH in
      let fe1 := mkFE t1 fv in
      let fe2 := mkFE t2 fv in
      let vlpe := fresh "vlpe" in
      ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh)
         ltac:(fun ilemma =>
             match type of ilemma with
             | req _ _ ->  _ -> ?EQ =>
               let tmp := fresh "tmp" in
               assert (tmp : EQ);
               [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD]
               | protect_fv "field" in tmp; revert tmp ];
               clear hyp
             end)).

Ltac FIELD_SIMPL_EQ FLD lH rl :=
  get_FldPre FLD ();
  Field_simplify_eq Ring_tac.ring_subst_niter FLD lH;
  get_FldPost FLD ().

Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
  let t := type of H in
  generalize H;
  field_lookup (PackField FIELD_SIMPL_EQ) [] t;
  [ try exact I
  | clear H;intro H].

Tactic Notation (at level 0)
  "field_simplify_eq" "[" constr_list(lH) "]"  "in" hyp(H) :=
  let t := type of H in
  generalize H;
  field_lookup (PackField FIELD_SIMPL_EQ) [lH] t;
  [ try exact I
  |clear H;intro H].

(* More generic tactics to build variants of field *)

(* This tactic reifies c and pass to F:
   - the FLD structure gathering all info in the field DB
   - the atom list
   - the expression (FExpr)
 *)
Ltac gen_with_field F c :=
  let MetaExpr FLD _ rl :=
    let R := get_FldCarrier FLD in
    let mkFFV := get_FFV FLD in
    let mkFE  := get_Meta FLD in
    let csr :=
      match rl with
      | List.cons ?r _ => r
      | _ => fail 1 "anomaly: ill-formed list"
      end in
    let fv := mkFFV csr (@List.nil R) in
    let expr := mkFE csr fv in
    F FLD fv expr in
  field_lookup (PackField MetaExpr) [] (c=c).

(* pushes the equation expr = ope(expr) in the goal, and
   discharge it with field *)
Ltac prove_field_eqn ope FLD fv expr :=
  let res := ope expr in
  let expr' := fresh "input_expr" in
  pose (expr' := expr);
  let res' := fresh "result" in
  pose (res' := res);
  let lemma := get_L1 FLD in
  let lemma :=
    constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in
  let ty := type of lemma in
  let lhs := match ty with
    forall _, ?lhs=_ -> _ => lhs
    end in
  let rhs := match ty with
    forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs
    end in
  let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in
  let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in
  compute_assertion lhs_eq lhs' lhs;
  compute_assertion rhs_eq rhs' rhs;
  let H := fresh "fld_eqn" in
  refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _));
    (* main goal *)
    [intro H;protect_fv "field" in H; revert H
    (* ring-nf(lhs') = ring-nf(rhs') *)
    | vm_compute; reflexivity || fail "field cannot prove this equality"
    (* denominator condition *)
    | simpl_PCond FLD];
  clear lhs_eq rhs_eq; subst lhs' rhs'.

Ltac prove_with_field ope c :=
  gen_with_field ltac:(prove_field_eqn ope) c.

(* Prove an equation x=ope(x) and rewrite with it *)
Ltac prove_rw ope x :=
  prove_with_field ope x;
  [ let H := fresh "Heq_maple" in
    intro H; rewrite H; clear H
  |..].

(* Apply ope (FExpr->FExpr) on an expression *)
Ltac reduce_field_expr ope kont FLD fv expr :=
  let evfun := get_FEeval FLD in
  let res := ope expr in
  let c := (eval simpl_field_expr in (evfun fv res)) in
  kont c.

(* Hack to let a Ltac return a term in the context of a primitive tactic *)
Ltac return_term x := generalize (refl_equal x).
Ltac get_term :=
  match goal with
  | |- ?x = _ -> _ => x
  end.

(* Turn an operation on field expressions (FExpr) into a reduction
   on terms (in the field carrier). Because of field_lookup,
   the tactic cannot return a term directly, so it is returned
   via the conclusion of the goal (return_term). *)
Ltac reduce_field_ope ope c :=
  gen_with_field ltac:(reduce_field_expr ope return_term) c.

(* Adding a new field *)

Ltac ring_of_field f :=
  match type of f with
  | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
  end.

Ltac coerce_to_almost_field set ext f :=
  match type of f with
  | almost_field_theory _ _ _ _ _ _ _ _ _ => f
  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
  end.

Ltac field_elements set ext fspec pspec sspec dspec rk :=
  let afth := coerce_to_almost_field set ext fspec in
  let rspec := ring_of_field fspec in
  ring_elements set ext rspec pspec sspec dspec rk
  ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec).

Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
  let get_lemma :=
    match pspec with None => fun x y => x | _ => fun x y => y end in
  let simpl_eq_lemma := get_lemma
       Field_simplify_eq_correct       Field_simplify_eq_pow_correct in
  let simpl_eq_in_lemma := get_lemma
       Field_simplify_eq_in_correct   Field_simplify_eq_pow_in_correct in
  let rw_lemma := get_lemma
       Field_rw_correct                    Field_rw_pow_correct in
  field_elements set ext fspec pspec sspec dspec rk
   ltac:(fun afth ext_r morph p_spec s_spec d_spec =>
     match morph with
     | _ =>
       let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in
       match p_spec with
       | mkhypo ?pp_spec =>
         let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
         match s_spec with
         | mkhypo ?ss_spec =>
           let field_ok3 := constr:(field_ok2 _ ss_spec) in
           match d_spec with
           | mkhypo ?dd_spec =>
             let field_ok := constr:(field_ok3 _ dd_spec) in
             let mk_lemma lemma :=
              constr:(lemma _ _ _  _ _ _  _ _ _ _
                   set ext_r inv_m afth
                   _ _ _  _ _ _  _ _ _ morph
                   _ _ _ pp_spec _ ss_spec _ dd_spec) in
             let field_simpl_eq_ok := mk_lemma simpl_eq_lemma  in
             let field_simpl_ok := mk_lemma rw_lemma in
             let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in
             let cond1_ok :=
                constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in
             let cond2_ok :=
               constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in
             (fun f =>
               f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
                  cond1_ok cond2_ok)
           | _ => fail 4 "field: bad coefficiant division specification"
           end
         | _ => fail 3 "field: bad sign specification"
         end
       | _ => fail 2 "field: bad power specification"
       end
     | _ => fail 1 "field internal error : field_lemmas, please report"
     end).


From lrust.lang Require Export notation.
From lrust.lang Require Import heap proofmode.
From iris.prelude Require Import options.

Definition memcpy : val :=
  rec: "memcpy" ["dst";"len";"src"] :=
    if: "len" ≤ #0 then #☠
    else "dst" <- !"src";;
         "memcpy" ["dst" +ₗ #1 ; "len" - #1 ; "src" +ₗ #1].

Notation "e1 <-{ n } ! e2" :=
  (memcpy (@cons expr e1%E
          (@cons expr (Lit n)
          (@cons expr e2%E nil))))
  (at level 80, n at next level, format "e1  <-{ n }  ! e2") : expr_scope.

Notation "e1 <-{ n ',Σ' i } ! e2" :=
  (e1 <-{Σ i} () ;; e1+ₗ#1 <-{n} !e2)%E
  (at level 80, n, i at next level,
   format "e1  <-{ n ,Σ  i }  ! e2") : expr_scope.

Lemma wp_memcpy `{!lrustGS Σ} E l1 l2 vl1 vl2 q (n : Z):
  Z.of_nat (length vl1) = n → Z.of_nat (length vl2) = n →
  {{{ l1 ↦∗ vl1 ∗ l2 ↦∗{q} vl2 }}}
    #l1 <-{n} !#l2 @ E
  {{{ RET #☠; l1 ↦∗ vl2 ∗ l2 ↦∗{q} vl2 }}}.
Proof.
  iIntros (Hvl1 Hvl2 Φ) "(Hl1 & Hl2) HΦ".
  iLöb as "IH" forall (n l1 l2 vl1 vl2 Hvl1 Hvl2). wp_rec. wp_op; case_bool_decide; wp_if.
  - iApply "HΦ". assert (n = O) by lia; subst.
    destruct vl1, vl2; try discriminate. by iFrame.
  - destruct vl1 as [|v1 vl1], vl2 as [|v2 vl2], n as [|n|]; try (discriminate || lia).
    revert Hvl1 Hvl2. intros [= Hvl1] [= Hvl2]; rewrite !heap_mapsto_vec_cons. subst n.
    iDestruct "Hl1" as "[Hv1 Hl1]". iDestruct "Hl2" as "[Hv2 Hl2]".
    Local Opaque Zminus.
    wp_read; wp_write. do 3 wp_op. iApply ("IH" with "[%] [%] Hl1 Hl2"); [lia..|].
    iIntros "!> [Hl1 Hl2]"; iApply "HΦ"; by iFrame.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export LegacyField_Compl.
Require Export LegacyField_Theory.
Require Export LegacyField_Tactic.
Declare ML Module "legacy_field_plugin".

(* Command declarations are moved to the ML side *)


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal23.

From lfind Require Import LFind.
Lemma lfind_state  (l2:lst):@eq natural (len l2) (len (append l2 Nil)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal23_lem_47_lem3/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (l2:lst) :=
 let lfind_var := "l2:" ++ "(" ++ show l2 ++ ")"
 in let lfind_v := print l2 lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


(** Meta-theoretical consequences of the erasure *)

From Coq Require Import Utf8 List Nat Lia.
Require Import Equations.Prop.DepElim.
Require Import Equations.Prop.Classes.
From Equations Require Import Equations.
Require Import Util SIRTT MLTT Erasure.
Import ListNotations.

Set Default Goal Selector "!".

(** We lift termination of MLTT to SIRTT *)

Definition MLTT_SN :=
  ∀ Σ Γ t A,
    Σ ;; Γ ⊢ t : A →
    Acc MLTT.scored t.

Definition SIRTT_SN :=
  ∀ Γ t A,
    scoping_context Level.R Γ → (* TODO Need scoping above? Maybe would make more sense to ask wf? *)
    Γ ⊢[ Level.R ] t : A →
    Acc SIRTT.scored t.

Lemma relative_SN :
  MLTT_SN → SIRTT_SN.
Proof.
  intros h. intros Γ t A hΓ ht.
  eapply erase_typing in ht as ht'. 2: auto.
  eapply h in ht'.
  eapply SIRTT.typed_scoped in ht.
  remember (trans Γ t) as u eqn:e.
  induction ht' as [? h1 h2] in Γ, t, e, ht |- *. subst.
  constructor. intros u [hu].
  eapply erase_cored in hu as hu'. 2: eauto.
  pose proof (sq hu') as hh.
  eapply h2 in hh. 3: reflexivity.
  2:{ eapply scoping_cored. all: eauto. }
  auto.
Qed.

Print Assumptions relative_SN.

(** We also lift non-confusion *)

Definition MLTT_NoConf :=
  ∀ u v hu hv,
    head u = Some hu →
    head v = Some hv →
    u ≡ v →
    hu = hv.

Definition SIRTT_NoConf :=
  ∀ Γ u v hu hv,
    SIRTT.head u = Some hu →
    SIRTT.head v = Some hv →
    Γ ⊢[ Level.R ] u ≡ v →
    SIRTT.scoping Γ Level.R u →
    SIRTT.scoping Γ Level.R v →
    hu = hv.

Lemma relative_NoConf :
  MLTT_NoConf → SIRTT_NoConf.
Proof.
  intros h Γ u v hu hv eu ev hc hsu hsv.
  eapply erase_conv in hc. 2,3: auto.
  eapply h in hc. 2,3: eapply erasure_head ; eauto.
  apply trans_head_inj in hc.
  assumption.
Qed.

Print Assumptions relative_NoConf.


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 A B D T Bprime MB Bprimeprime Bprimeprimeprime : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ A T /\ (wd_ B D /\ (wd_ B T /\ (wd_ D T /\ (wd_ D Bprime /\ (wd_ B Bprime /\ (wd_ MB B /\ (wd_ MB T /\ (wd_ MB Bprime /\ (wd_ Bprime Bprimeprime /\ (wd_ MB Bprimeprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ Bprimeprimeprime T /\ (wd_ T Bprimeprime /\ (wd_ B Bprimeprime /\ (wd_ A Bprimeprimeprime /\ (wd_ T Bprime /\ (col_ B Bprime Bprimeprimeprime /\ (col_ A B Bprimeprimeprime /\ (col_ T Bprimeprimeprime Bprime /\ (col_ Bprime MB Bprimeprime /\ (col_ B MB T /\ (col_ Bprime B D /\ col_ T D A))))))))))))))))))))))))) -> col_ B T Bprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Implicit Arguments.
Unset Strict Implicit.

Require Extraction.

Require Import String Ascii QArith.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import dyadic.

Class Showable (T : Type) :=
  mkShowable { to_string : T -> string }.

Definition eprint_natchar : forall (T : Type) (n : N), T -> T := fun T n t => t.
(** Raises an exception if [n >= 256]. *)
Extract Constant eprint_natchar =>
 "fun n s ->
    Printf.eprintf ""%c"" (Char.chr (Big.to_int n));
    flush stderr;
    s".

Definition eprint_Z : forall (T : Type) (z : Z), T -> T := fun T z t => t.
Extract Constant eprint_Z =>
 "fun z s ->
    Printf.eprintf ""%f"" float_of_int (Big.to_int z);
    flush stderr;
    s".

Definition eprint_ZdivPos :
  forall (T : Type) (n : Z) (p : positive), T -> T := fun T z p t => t.
Extract Constant eprint_ZdivPos =>
 "fun n p s ->
    (* let num = float_of_int (Big.to_int n) in *)
    (* let den = float_of_int (Big.to_int p) in *)
    (* Printf.eprintf ""%F [%F / %F]"" (num /. den) num den; *)
    Printf.eprintf ""%s, %s"" (Big.to_string n) (Big.to_string p);
    (* Printf.eprintf ""%F"" (num /. den); *)
    flush stderr;
    s".

Definition eprint_nat (T : Type) (n : nat) (t : T) : T :=
  eprint_Z (Z.of_nat n) t.

Definition eprint_ascii (T : Type) (c : ascii) (t : T) : T :=
  eprint_natchar (N_of_ascii c) t.

Lemma eprint_ascii_id T c (t : T) : eprint_ascii c t = t.
Proof. auto. Qed.

Fixpoint eprint_string (T : Type) (s : string) (t : T) : T :=
  match s with
  | EmptyString => t
  | String c s' =>
    let t' := eprint_ascii c t
    in eprint_string s' t'
  end.

Lemma eprint_string_id T s (t : T) : eprint_string s t = t.
Proof. induction s; auto. Qed.

Definition eprint_showable A T `{Showable A} (a : A) (t : T) : T :=
  eprint_string (to_string a) t.

Definition eprint_comma T (t : T) := eprint_string "," t.

Definition nl : ascii := "010".
Definition cr : ascii := "013".

Definition newline : string := String nl (String cr EmptyString).

Definition eprint_newline T (t : T) := eprint_string newline t.

Definition eprint_Q T (q : Q) (t : T) : T :=
  match q with
  | Qmake n d =>
    eprint_ZdivPos n d t
  end.

Lemma eprint_Q_id T q (t : T) : eprint_Q q t = t.
Proof. unfold eprint_Q; destruct q; auto. Qed.

Section PrintQvector.
  Variable A : Type.
  Context `{Showable A}.

  Fixpoint print_Qvector T (l : list (A*Q)) (t : T) : T :=
    match l with
    | nil => t
    | cons (a, w) l' =>
      let t1 := eprint_string (to_string a) t in
      let t2 := eprint_string ", " t1 in
      let t3 := eprint_Q w t2 in
      let t4 := eprint_newline t3 in
      print_Qvector l' t4
    end.

  Lemma print_Qvector_id T l (t : T) : print_Qvector l t = t.
  Proof.
    elim: l t => //=; case => a q l IH t; rewrite IH.
    rewrite /eprint_newline eprint_string_id.
    by rewrite eprint_Q_id 2!eprint_ascii_id eprint_string_id.
  Qed.
End PrintQvector.

Section PrintDvector.
  Variable A : Type.
  Context `{Showable A}.

  Definition print_Dvector T (l : list (A*D)) (t : T) : T :=
    print_Qvector
      (map (fun p => (p.1, D_to_Q p.2)) l)
      t.

  Lemma print_Dvector_id T l (t : T) : print_Dvector l t = t.
  Proof. by rewrite /print_Dvector print_Qvector_id. Qed.
End PrintDvector.

Instance showable_list {A : Type} `{Showable A} : Showable (list A) :=
  mkShowable
    (fix F l :=
       match l with
       | nil => EmptyString
       | cons x l' =>
         append (to_string x)
                (append newline
                        (F l'))
       end).
Local Open Scope nat_scope.
Instance showable_nat : Showable nat :=
  mkShowable
    (fun n => match n with
     | O => "0"
     | 1%nat => "1"
     | 2%nat => "2"
     | 3%nat => "3"
     | 4%nat => "4"
     | 5%nat => "5"
     | 6%nat => "6"
     | 7%nat => "7"
     | 8%nat => "8"
     | 9%nat => "9"
     | 10%nat => "10"
     | _ => "<nat > 10>"
     end)%string.

Instance showable_N : Showable N.t :=
  mkShowable (fun n => to_string (N.to_nat n)).


Require Import FcEtt.sigs.

Require Export FcEtt.ett_inf_cs.
Require Export FcEtt.ett_ind.
Require Import FcEtt.imports.
Require Import FcEtt.tactics.

Require Import FcEtt.ett_par.

Module fc_unique (wf : fc_wf_sig) (subst : fc_subst_sig) <: fc_unique_sig.
Import wf subst.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(**** The typing relation for FC produces unique types. ****)

Hint Resolve AnnCtx_uniq.
Hint Rewrite tm_subst_tm_tm_var co_subst_co_co_var.

(* Automatically apply the IH of typing_unique on the specified tm/coercion *)
Ltac apply_ind a :=
  match goal with
  | H : (forall (A2 : tm), AnnTyping ?G a A2 ?R -> ?B = A2), Y : AnnTyping ?G a ?C ?R |- _  =>
    apply H in Y; inversion Y
  | H : forall A B, AnnDefEq ?G ?D a A B ?R -> ?A1 = A /\ ?B1 = B, Y : AnnDefEq ?G ?D a ?A2 ?B2 ?R |- _ =>
    apply H in Y; split_hyp; subst
  | H : ∀ q1 q2 : constraint, AnnIso ?G ?D a q1 q2 → ?phi1 = q1 ∧ ?phi2 = q2,
    Y : AnnIso ?G ?D a ?q1 ?q2 |- _ =>
apply H in Y; split_hyp; subst

end.

(* Apply induction in the case where we need a "fresh" variable. *)
Ltac apply_ind_var c a :=
      match goal with
        | H7 : ∀ c : atom,
            ¬ c `in` ?L0
                   → AnnTyping ?G (open_tm_wrt_co a (g_Var_f c)) ?B ?R,
          H0 : ∀ c : atom,
            ¬ c `in` ?L
             → ∀ A2 : tm,
          AnnTyping ?G (open_tm_wrt_co a (g_Var_f c)) A2 ?R → ?C = A2 |- _ =>
  specialize H7 with c; apply H0 in H7; eauto
       | H8 : ∀ x : atom,
       ¬ x `in` ?L0
       → AnnDefEq ?G ?D (open_co_wrt_tm a (a_Var_f x)) ?B0 ?B5 ?R,
        H0 : ∀ x : atom,
       ¬ x `in` ?L
       → ∀ a1 b1 : tm,
         AnnDefEq ?G ?D (open_co_wrt_tm a (a_Var_f x)) a1 b1 ?R
         → ?B1 = a1 ∧ ?B2  = b1 |- _ =>
  specialize H8 with c; edestruct (H0 c); eauto
  end.

(* For working with PiCong and AbsCong. Look for hypotheses that introduce new
   equations about the bodies of the terms. (Should be used after induction
   hypothesis)  *)
Ltac equate_bodies x :=
      match goal with
        H11 : ∀ x : atom,
          ¬ x `in` ?L0 → open_tm_wrt_tm ?B4 (a_Var_f x) = open_tm_wrt_tm ?B2 ?C,
    e : ∀ x : atom, ¬ x `in` ?L → open_tm_wrt_tm ?B3 (a_Var_f x) =
                                  open_tm_wrt_tm ?B2 ?C
    |- _ =>
        let FR := fresh in
        let FR2 := fresh in
        specialize H11 with x;
        assert (FR: ¬ x `in` L0); eauto; apply H11 in FR;
        specialize e with x;
        assert (FR2 : ¬ x `in` L); eauto; apply e in FR2;
        rewrite -FR in FR2;
        apply open_tm_wrt_tm_inj in FR2; try fsetdec_fast
        end.

(* Find matching assumptions about binds, produce an equality EQ between their sorts. *)
Ltac resolve_binds_unique :=
  let EQ := fresh in
  let h  := fresh in
  match goal with
  |   b : binds ?c ?A ?G,  H4 : binds ?c ?B ?G  |- _  =>
      assert (EQ : uniq G); eauto using AnnCtx_uniq,uniq_an_toplevel;
      move: (binds_unique _ _ _ _ _ b H4 EQ) => h; inversion h
  end.

Lemma unique_mutual :
  (forall G a A1 R, AnnTyping G a A1 R -> forall {A2}{R'}, AnnTyping G a A2 R' -> A1 = A2) /\
  (forall G phi, AnnPropWff G phi -> True) /\
  (forall G D g p1 p2, AnnIso G D g p1 p2 -> forall {q1 q2}, AnnIso G D g q1 q2 -> p1 = q1 /\ p2 = q2) /\
  (forall G D g a b R, AnnDefEq G D g a b R -> forall {a1 b1}, AnnDefEq G D g a1 b1 R -> a = a1 /\ b = b1) /\
  (forall G, AnnCtx G -> True).
Proof.
  apply ann_typing_wff_iso_defeq_mutual.
  all: intros. all: try inversion H2; subst; try solve [try inversion H0; subst; basic_solve'; subst].
  - remember a_Star as star.
    induction H0; eauto.
    all: inversion Heqstar.
  - remember (a_Var_f x) as vx. induction H0; eauto.
    all: inversion Heqvx. subst. assert (Tm A R = Tm A0 R0).
    eapply binds_unique; eauto. inversion H2; auto.
  - remember (a_Pi rho A R B) as pi. induction H1.
    all: inversion Heqpi; auto.
  - remember (a_Abs rho A R a) as abs. induction H1.
    all: inversion Heqabs; auto. subst. check. autotype. f_equal.
    pick fresh x.
    eapply open_tm_wrt_tm_inj with (x1 := x); auto.
  - apply_ind b. done.
  - autotype.
    apply_ind a. firstorder.
  - f_equal.
    pick fresh c.
    apply_ind_var c a.
    eapply open_tm_wrt_co_inj; autotype.
  - apply_ind a1. done.
  - move: (binds_unique _ _ _ _ _ b H4 uniq_an_toplevel) => E. inversion E. auto.
  - autotype; apply_ind g1; apply_ind g2; autotype.
  - autotype. apply_ind g. autotype.
  - ann_invert_clear. apply_ind g. auto.
  - repeat ann_invert_clear. apply_ind g. auto.
  - ann_invert_clear.
    resolve_binds_unique. auto.
  - ann_invert_clear. auto.
  - ann_invert_clear.
    edestruct H2; eauto.
  - ann_invert_clear.
    apply_ind g1. apply_ind g2. apply_ind g2. auto.
  - inversion H4. clear a0.
    apply_ind g1.
    pick fresh x.
    apply_ind_var x g2.
    apply open_tm_wrt_tm_inj in H5.
    apply open_tm_wrt_tm_inj in H6.
    subst.
    equate_bodies x.
    all: fsetdec_fast.

  - (* abs_cong *) (* FIXME: could be prettier *)
    inversion H4. subst.
    apply_ind g1.
    pick fresh x.
    have xL : x `notin` L by fsetdec.
    have xL0 : x `notin` L0 by clear xL; fsetdec.
    move: (H0 x xL _ _ (H9 x xL0)) => [eq1 eq2].
    apply open_tm_wrt_tm_inj in eq1.
    apply open_tm_wrt_tm_inj in eq2.
    split; first by congruence.
    suff: b3 = b5 by move=> ->.
    apply: open_tm_wrt_tm_inj.
    Focus 3.
    erewrite (H10 x xL0).
    erewrite (e x xL).
    congruence.
    all: try fsetdec_fast.
  - repeat ann_invert_clear.
    apply_ind g1.
    apply_ind g2.
    auto. admit.
  - repeat ann_invert_clear.
    apply_ind g. admit. (*
    split; congruence. *)
  - repeat ann_invert_clear.
    (* apply_ind seems to have a problem on this one *)
    move: (H0 _ _ H7) => [-> ->].
    move: (H _ _ H6) => [? ?].
    split; congruence.
  - (* ipi_cong *)
    match goal with
      [ H3 : AnnDefEq ?G ?D (g_CPiCong ?g1 ?g3) ?a3 ?b1 |- _ ] => inversion H3
    end.
    match goal with
      [ H : ∀ q1 q2 : constraint, AnnIso ?G ?D ?g1 q1 q2 → ?phi1 = q1 ∧ ?phi2 = q2,
        H7 : AnnIso ?G ?D ?g1 phi0 phi3 |- _ ] =>
      move: (H _ _ H7) => [h0 h1]; subst
    end.
    pick fresh x.
    match goal with
      [ H8 : ∀ c : atom, ¬ c `in` ?L0 → open_tm_wrt_co B4 (g_Var_f c) =
                                        open_tm_wrt_co B5 (g_Cast (g_Var_f c) (g_Sym ?g1)) |- _ ] =>
      move: (H8 x ltac:(auto)) => h0; clear H8
    end.
    match goal with
      [ H0 : ∀ c : atom, ¬ c `in` ?L → ∀ a1 b1 : tm,
              AnnDefEq ([(c, Co ?phi0)] ++ ?G) ?D (open_co_wrt_co ?g3 (g_Var_f c)) a1 b1
              → open_tm_wrt_co B1 (g_Var_f c) = ?a1 ∧ open_tm_wrt_co B2 (g_Var_f c) = ?b1,
       H7 : ∀ c : atom,
       ¬ c `in` ?L0
       → AnnDefEq ([(c, Co ?phi0)] ++ ?G) ?D (open_co_wrt_co ?g3 (g_Var_f c)) (open_tm_wrt_co B0 (g_Var_f c))
           (open_tm_wrt_co B5 (g_Var_f c)) |- _ ] =>
      move: (H0 x ltac:(auto) _ _ (H7 x ltac:(auto))) => [h1 h2]; clear H7
    end.
    move: (e x ltac:(auto)) => h3. clear e.
    split; f_equal.
    apply open_tm_wrt_co_inj with (c1 := x); auto.
    apply open_tm_wrt_co_inj with (c1 := x); auto.
    rewrite h0.
    rewrite h3.
    f_equal.
    apply open_tm_wrt_co_inj with (c1 := x); auto.
  - (* cabs_cong *)
    inversion H5. subst.
    pick fresh x.
    assert (FrL0: x `notin` L0). auto.
    assert (FrL: x `notin` L). auto.
    move: (H11 x FrL0) => h0. clear H11.
    edestruct H. eauto. subst.
    move: (H0 x FrL _ _ (H10 x FrL0)) => [h1 h2].
    split; f_equal; auto.
    eapply open_tm_wrt_co_inj with (c1 := x); auto.
    eapply open_tm_wrt_co_inj with (c1 := x); auto.
    rewrite h0.
    move: (e x FrL) => h3.
    rewrite h3.
    f_equal.
    apply open_tm_wrt_co_inj with (c1 := x); auto.
  - inversion H5. subst.
    edestruct H...
    autotype.
    autotype.
  - inversion H2. subst.
    apply H in H8. destruct H8 as [h0 h1].
    inversion h0. inversion h1...
    autotype.
  - apply H0 in H9.
    split_hyp. invert_syntactic_equality.
    auto.
  - inversion H0. subst. apply H in H4.
    split_hyp. invert_syntactic_equality. auto.
Qed.

Definition AnnTyping_unique := first unique_mutual.
Definition AnnDefEq_unique  := fourth unique_mutual.
Definition AnnIso_unique    := third unique_mutual.

(* These two tactics look for terms in the context that
   are typed with two different types and automatically applies
   the uniqueness lemma.

   The first tactic uses subst to resolve the equalities. The second
   tries to only eliminate equations between variables.

 *)

Ltac resolve_unique_subst  :=
  match goal with
  |   _ : AnnTyping ?G ?a ?A,  H :AnnTyping ?G ?a ?B  |- _  =>
      assert (A = B); try (eapply (first unique_mutual); eauto 1); subst; clear H
  |   H1 : AnnDefEq ?G ?D ?g ?A1 ?B1,  H2 :AnnDefEq ?G ?D ?g ?A2 ?B2  |- _  =>
      destruct (fourth unique_mutual _ _ _ _ _ H1 _ _ H2); subst; clear H2
  end.

Ltac resolve_unique_nosubst  :=
  match goal with
  |   H1 : AnnTyping ?G ?a ?A,  H2 :AnnTyping ?G ?a ?B  |- _  =>
      assert (A = B); [ eapply (first unique_mutual);
                          [eapply H1 | eapply H2]|]; subst B; clear H2
  |   H1 : AnnDefEq ?G ?D ?g ?A1 ?B1,  H2 :AnnDefEq ?G ?D ?g ?A2 ?B2  |- _  =>
      destruct (fourth unique_mutual _ _ _ _ _ H1 _ _ H2);
      try subst A2; try subst B2; try subst A1; try subst B1;
      clear H2
  end.

(* Coerced values and values are terminal *)
Lemma no_reduction_mutual :
  (forall a, CoercedValue a -> forall G b, not (head_reduction G a b)) /\
  (forall a, Value a -> forall G b, not (head_reduction G a b)).
Proof.
  apply CoercedValue_Value_mutual; simpl.
  all: intros.
  all: intros NH; inversion NH; subst.
  all: try solve [eapply H; eauto].
  all: try solve [inversion v].
  all: try solve [inversion p].

  - pick fresh x.
    move: (H x ltac:(auto)) => h0.
    move: (H5 x ltac:(auto)) => h5.
    eapply h0; eauto.
Qed.
Lemma no_Value_reduction : forall a, Value a -> forall G b, not (head_reduction G a b).
Proof. eapply no_reduction_mutual. Qed.
Lemma no_CoercedValue_reduction : forall a, CoercedValue a -> forall G b, not (head_reduction G a b).
Proof. eapply no_reduction_mutual. Qed.

(* The reduction relation is deterministic *)
Lemma head_reduction_deterministic :
  forall G a a1, head_reduction G a a1 -> forall a2, head_reduction G a a2 -> a1 = a2.
Proof.
  intros G a a1 H.
  induction H; intros a2 h0.
  all: inversion h0; subst.
  (* already equal *)
  all: auto.
  (* follows by induction *)
  all: try solve [erewrite IHhead_reduction; eauto].

  (* impossible case, reduction of value *)
  all: try solve [(have: False by eapply no_Value_reduction; eauto); done].

  (* impossible case, reduction of coerced value *)
  all: try match goal with
    [ H4 : Value ?a0, H0: head_reduction _ (a_Conv ?a0 ?g) ?a' |- _ ] =>
    (have CV: CoercedValue (a_Conv a0 g) by eauto using AnnDefEq_lc3);
      (have: False by eapply no_CoercedValue_reduction; eauto); done
  end.

  all: try ((have: False by eapply (@no_Value_reduction (a_CAbs phi b)); eauto); done).

  - pick fresh x.
    move: (H7 x ltac:(auto)) => h7.
    move: (H1 x ltac:(auto)) => h1.
    apply h1 in h7.
    apply open_tm_wrt_tm_inj in h7; eauto. rewrite h7. auto.
  - resolve_binds_unique. auto.
Qed.

End fc_unique.