Require Import Coq.omega.Omega.
Require Import Examples.PreAutoSep Examples.Wrap Examples.Conditional.

Import DefineStructured.

Set Implicit Arguments.

(** Simple notation for parsing streams of machine words *)

Inductive pattern0 :=
| Const_ (_ : W)
(* Match this exact word. *)
| Var_ (_ : string)
(* Match anything and stash it in this local variable. *).

Definition pattern := list pattern0.
(* Match a prefix of the stream against these individual word patterns. *)

Definition Const w : pattern := Const_ w :: nil.
Definition Var x : pattern := Var_ x :: nil.

Coercion Const : W >-> pattern.
Coercion Var : string >-> pattern.

Fixpoint matches (p : pattern) (ws : list W) : Prop :=
  match p, ws with
    | nil, _ => True
    | Const_ w :: p', w' :: ws' => w = w' /\ matches p' ws'
    | Var_ _ :: p', _ :: ws' => matches p' ws'
    | _, _ => False
  end.

Fixpoint binds (p : pattern) (ws : list W) : list (string * W) :=
  match p, ws with
    | Const_ _ :: p', _ :: ws' => binds p' ws'
    | Var_ s :: p', w :: ws' => (s, w) :: binds p' ws'
    | _, _ => nil
  end.

Section Parse.
  Hint Extern 1 (Mem _ = Mem _) =>
    eapply scratchOnlyMem; [ | eassumption ];
      simpl; intuition congruence.
  Hint Extern 1 (Mem _ = Mem _) =>
    symmetry; eapply scratchOnlyMem; [ | eassumption ];
      simpl; intuition congruence.

  Hint Resolve evalInstrs_app sepFormula_Mem.

  Hint Extern 2 (interp ?specs2 (![ _ ] (?stn2, ?st2))) =>
    match goal with
      | [ _ : interp ?specs1 (![ _ ] (?stn1, ?st1)) |- _ ] =>
        solve [ equate specs1 specs2; equate stn1 stn2; equate st1 st2; step auto_ext ]
    end.

  Variable stream : string.
  (* Name of local variable containing an array to treat as the stream of words *)
  Variable size : string.
  (* Name of local variable containing the stream length in words *)
  Variable pos : string.
  (* Name of local variable containing the current stream position in words *)

  Variable p : pattern.
  (* We will try to match a prefix of the stream against this pattern. *)

  Variable imports : LabelMap.t assert.
  Hypothesis H : importsGlobal imports.
  Variable modName : string.

  Variables Then Else : cmd imports modName.
  (* Code to run when a single pattern matches or fails, respectively. *)

  Variable ns : list string.
  (* Local variable names *)

  (* Does the pattern match? *)
  Fixpoint guard (p : pattern) (offset : nat) : bexp :=
    match p with
      | nil =>
        Test Rv Le (variableSlot size ns)
        (* Is there enough space left in the stream? *)
      | Const_ w :: p' =>
        And (guard p' (S offset))
        (Test (LvMem (Indir Rp (4 * offset))) IL.Eq w)
      | Var_ _ :: p' => guard p' (S offset)
    end.

  (* Once we know that the pattern matches, we set the appropriate pattern variables with this function. *)
  Fixpoint reads (p : pattern) (offset : nat) : list instr :=
    match p with
      | nil => nil
      | Const_ _ :: p' => reads p' (S offset)
      | Var_ x :: p' => Assign (variableSlot x ns) (LvMem (Indir Rp (4 * offset))) :: reads p' (S offset)
    end.

  Fixpoint suffix (n : nat) (ws : list W) : list W :=
    match n with
      | O => ws
      | S n' => match ws with
                  | nil => nil
                  | w :: ws' => suffix n' ws'
                end
    end.

  Lemma suffix_remains : forall n ws,
    (n < length ws)%nat
    -> suffix n ws = selN ws n :: suffix (S n) ws.
    induction n; destruct ws; simpl; intuition.
    rewrite IHn; auto.
  Qed.

  Fixpoint patternBound (p : pattern) : Prop :=
    match p with
      | nil => True
      | Const_ _ :: p' => patternBound p'
      | Var_ x :: p' => In x ns /\ patternBound p'
    end.

  Fixpoint okVarName (x : string) (p : pattern) : Prop :=
    match p with
      | nil => True
      | Const_ _ :: p' => okVarName x p'
      | Var_ x' :: p' => if string_dec x x' then False else okVarName x p'
    end.

  Definition ThenPre (pre : assert) : assert :=
    (fun stn_st => let (stn, st) := stn_st in
      Ex st', pre (stn, st')
      /\ (AlX, Al V, Al ws, Al r,
        ![ ^[array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st' Sp)] * #0] (stn, st')
        /\ [| sel V size = length ws |]
        ---> [| matches p (suffix (wordToNat (sel V pos)) ws)
          /\ exists st'', Mem st'' = Mem st'
            /\ Regs st'' Sp = Regs st' Sp
            /\ evalInstrs stn st'' (map (fun p => Assign (variableSlot (fst p) ns) (RvImm (snd p)))
              (binds p (suffix (wordToNat (sel V pos)) ws))
              ++ Binop (variableSlot pos ns) (variableSlot pos ns) Plus (length p)
              :: nil) = Some st |]))%PropX.

  Definition ElsePre (pre : assert) : assert :=
    (fun stn_st => let (stn, st) := stn_st in
      Ex st', pre (stn, st')
      /\ (AlX, Al V, Al ws, Al r,
        ![ ^[array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp)] * #0] (stn, st')
        /\ [| sel V size = length ws |]
        ---> [| ~matches p (suffix (wordToNat (sel V pos)) ws) |])
      /\ [| Regs st Sp = Regs st' Sp /\ Mem st = Mem st' |])%PropX.

  (* Here's the raw parsing command, which we will later wrap with nicer VCs. *)
  Definition Parse1_ : cmd imports modName := fun pre =>
    Seq_ H (Straightline_ _ _ (Binop Rv (variableSlot pos ns) Plus (length p)
      :: Binop Rp 4 Times (variableSlot pos ns)
      :: Binop Rp (variableSlot stream ns) Plus Rp
      :: nil))
    (Cond_ _ H _ (guard p O)
      (Seq_ H
        (Straightline_ _ _ (reads p O
          ++ Binop (variableSlot pos ns) (variableSlot pos ns) Plus (length p)
          :: nil))
        (Seq_ H
          (Structured.Assert_ _ _ (ThenPre pre))
          Then))
      (Seq_ H
        (Structured.Assert_ _ _ (ElsePre pre))
        Else))
    pre.

  Hint Rewrite wordToN_nat wordToNat_natToWord_idempotent using assumption : N.
  Require Import Coq.Arith.Arith.

  Hint Resolve goodSize_weaken.

  Opaque mult.

  Lemma bexpTrue_bound : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> forall p' offset, bexpTrue (guard p' offset) stn st
      -> Regs st Rv <= sel V size.
    clear H; induction p' as [ | [ ] ]; simpl; intuition eauto.

    prep_locals; evaluate auto_ext; tauto.
  Qed.

  Lemma bexpSafe_guard : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> sel V size = $ (length ws)
    -> forall p' offset,
      Regs st Rv = $ (offset + wordToNat (sel V pos) + length p')
      -> goodSize (offset + wordToNat (sel V pos) + Datatypes.length p')
      -> bexpSafe (guard p' offset) stn st.
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    prep_locals; evaluate auto_ext.

    apply IHp'.
    rewrite H4; f_equal; omega.
    eauto.

    replace (evalCond (LvMem (Rp + 4 * offset)%loc) IL.Eq w stn st)
      with (evalCond (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))) IL.Eq w stn st)
        in *.
    assert (goodSize (length ws)) by eauto.
    assert (natToW (offset + wordToNat (sel V pos)) < $ (length ws)).
    specialize (bexpTrue_bound _ H H0 H1 _ _ H6).
    rewrite H3, H4.
    intros.
    apply wle_goodSize in H9; auto; eauto.

    prep_locals; evaluate auto_ext.

    unfold evalCond; simpl.
    rewrite H2.
    match goal with
      | [ |- match ReadWord _ _ ?X with None => _ | _ => _ end
        = match ReadWord _ _ ?Y with None => _ | _ => _ end ] => replace Y with X; auto
    end.
    rewrite mult_comm; rewrite natToW_times4.
    rewrite natToW_plus.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    apply IHp'; eauto.
    rewrite H4; f_equal; omega.
  Qed.

  Lemma bexpTrue_matches : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> forall p' offset, bexpTrue (guard p' offset) stn st
      -> Regs st Rv = $ (offset + wordToNat (sel V pos) + length p')
      -> (offset + wordToNat (sel V pos) <= length ws)%nat
      -> sel V size = $ (length ws)
      -> goodSize (offset + wordToNat (sel V pos) + length p')
      -> matches p' (suffix (offset + wordToNat (sel V pos)) ws).
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    specialize (bexpTrue_bound _ H H0 H1 _ _ H8).
    rewrite H4; intros.
    replace (evalCond (LvMem (Rp + 4 * offset)%loc) IL.Eq w stn st)
      with (evalCond (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))) IL.Eq w stn st)
        in *.
    rewrite H6 in H3.
    eapply wle_goodSize in H3.
    rewrite suffix_remains in * by auto.
    assert (natToW (offset + wordToNat (sel V pos)) < natToW (length ws))
      by (apply lt_goodSize; eauto).
    prep_locals; evaluate auto_ext.

    split.
    subst.
    unfold Array.sel.
    rewrite wordToNat_natToWord_idempotent; auto.
    change (goodSize (offset + wordToNat (sel V pos))); eauto.
    change (S (offset + wordToNat (sel V pos))) with (S offset + wordToNat (sel V pos)).
    apply IHp'; auto.
    rewrite H4; f_equal; omega.
    eauto.
    eauto.
    eauto.

    unfold evalCond; simpl.
    rewrite H2.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    specialize (bexpTrue_bound _ H H0 H1 _ _ H3).
    rewrite H4; intros.
    rewrite H6 in H8.
    eapply wle_goodSize in H8.
    rewrite suffix_remains in * by auto.
    change (S (offset + wordToNat (sel V pos))) with (S offset + wordToNat (sel V pos)).
    apply IHp'; auto.
    rewrite H4; f_equal; omega.
    eauto.
    eauto.
    eauto.
  Qed.

  Lemma suffix_none : forall n ls,
    (n >= length ls)%nat
    -> suffix n ls = nil.
    induction n; destruct ls; simpl; intuition.
  Qed.

  Lemma bexpFalse_not_matches : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> sel V size = $ (length ws)
    -> forall p' offset, bexpFalse (guard p' offset) stn st
      -> Regs st Rv = $ (offset + wordToNat (sel V pos) + length p')
      -> (offset + wordToNat (sel V pos) <= length ws)%nat
      -> goodSize (offset + wordToNat (sel V pos) + length p')
      -> ~matches p' (suffix (offset + wordToNat (sel V pos)) ws).
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    prep_locals; evaluate auto_ext.
    rewrite H3 in *.
    apply lt_goodSize' in H13.
    omega.
    eauto.
    eauto.

    destruct (le_lt_dec (length ws) (offset + wordToNat (sel V pos))).
    rewrite suffix_none in *; auto.
    rewrite suffix_remains in * by auto.
    assert (natToW (offset + wordToNat (sel V pos)) < natToW (length ws))
      by (apply lt_goodSize; eauto).
    prep_locals; evaluate auto_ext.
    eapply IHp'; eauto.
    rewrite H5; f_equal; omega.

    specialize (bexpTrue_bound _ H H0 H1 _ _ H4).
    rewrite H5; intros.
    destruct (le_lt_dec (length ws) (offset + wordToNat (sel V pos))).
    rewrite suffix_none in *; auto.
    rewrite suffix_remains in * by auto.
    replace (evalCond (LvMem (Rp + 4 * offset)%loc) IL.Eq w stn st)
      with (evalCond (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))) IL.Eq w stn st)
        in *.
    assert (natToW (offset + wordToNat (sel V pos)) < natToW (length ws))
      by (apply lt_goodSize; eauto).
    prep_locals; evaluate auto_ext.
    subst.
    apply H16.
    unfold Array.sel.
    rewrite wordToNat_natToWord_idempotent; auto.
    change (goodSize (offset + wordToNat (sel V pos))); eauto.

    unfold evalCond; simpl.
    rewrite H2.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    destruct (le_lt_dec (length ws) (offset + wordToNat (sel V pos))).
    rewrite suffix_none in *; auto.
    rewrite suffix_remains in * by auto.
    intuition; subst.
    eapply IHp'; eauto.
    rewrite H5; f_equal; omega.
  Qed.

  Transparent evalInstrs.
  Opaque evalInstr.

  Lemma reads_nocrash : forall specs stn ws r fr,
    ~In "rp" ns
    -> forall p' offset st V, patternBound p'
      -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
      -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
      -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
      -> okVarName stream p'
      -> okVarName pos p'
      -> evalInstrs stn st (reads p' offset) = None
      -> False.
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    eapply IHp'; eauto.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.

    destruct (string_dec stream s); try tauto.
    destruct (string_dec pos s); try tauto.

    case_eq (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc))); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *
      end.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $ (length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.
    intros.
    eapply IHp'.
    eauto.
    instantiate (1 := s0).
    step auto_ext.
    reflexivity.
    repeat rewrite sel_upd_ne by congruence.
    assumption.
    instantiate (1 := S offset).
    repeat rewrite sel_upd_ne by congruence.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.
    assumption.
    assumption.
    assumption.
    Transparent evalInstr.
    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $ (length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.

    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.
  Qed.

  Opaque evalInstr.

  Lemma reads_exec' : forall specs stn ws r fr,
    ~In "rp" ns
    -> forall p' offset st st' V, patternBound p'
      -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
      -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
      -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
      -> okVarName stream p'
      -> okVarName pos p'
      -> evalInstrs stn st (reads p' offset) = Some st'
      -> exists V',
        interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V' r (Regs st Sp) * fr] (stn, st'))
        /\ Regs st' Sp = Regs st Sp.
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    injection H6; intros; subst.
    eauto.

    eapply IHp'; eauto.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.

    destruct (string_dec stream s); try tauto.
    destruct (string_dec pos s); try tauto.

    case_eq (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc))); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *
      end.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $ (length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.
    intros.
    eapply (IHp' _ _ _ (upd V s (Array.sel ws (offset + wordToNat (sel V pos))))) in H13.
    rewrite <- H1.
    rewrite sel_upd_ne in H13 by congruence.
    assumption.
    eauto.
    step auto_ext.
    reflexivity.
    rewrite H10.
    repeat rewrite sel_upd_ne by congruence.
    W_eq.
    repeat rewrite sel_upd_ne by congruence.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.
    assumption.
    assumption.
    Transparent evalInstr.
    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $ (length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.

    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.
  Qed.

  Lemma reads_exec : forall stn st p' offset st',
    evalInstrs stn st (reads p' offset) = Some st'
    -> ~In "rp" ns
    -> forall specs ws r fr V, patternBound p'
      -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
      -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
      -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
      -> okVarName stream p'
      -> okVarName pos p'

      -> exists V',
        interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V' r (Regs st Sp) * fr] (stn, st'))
        /\ Regs st' Sp = Regs st Sp.
    eauto using reads_exec'.
  Qed.

  Opaque evalInstrs.

  Lemma unify_V : forall specs stn st ws V r sp fr ws' V' r' fr',
    interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r sp * fr] (stn, st))
    -> sel V size = length ws
    -> sel V' size = length ws'
    -> interp specs (![array ws' (sel V' stream) * locals ("rp" :: ns) V' r' sp * fr'] (stn, st)
       ---> [| forall x, In x ns -> sel V' x = sel V x |])%PropX.
    clear H; intros.
    assert (Hlocals : exists FR, interp specs (![array (toArray ("rp" :: ns) V) sp * FR] (stn, st)))
      by (eexists; unfold locals in H; step auto_ext); destruct Hlocals as [ FR Hlocals ].
    assert (Hlocals' : exists FR', himp specs
      (array ws' (sel V' stream) * locals ("rp" :: ns) V' r' sp * fr')%Sep
      (array (toArray ("rp" :: ns) V') sp * FR')%Sep)
      by (eexists; unfold locals; step auto_ext); destruct Hlocals' as [ FR' Hlocals' ].
    eapply Imply_trans; try (rewrite sepFormula_eq; apply Hlocals').
    simpl.
    replace ((array (V' "rp" :: toArray ns V') sp * FR')%Sep stn (memoryIn (Mem st)))
      with (![array (V' "rp" :: toArray ns V') sp * FR'] (stn, st))%PropX
        by (rewrite sepFormula_eq; reflexivity).
    eapply Imply_trans.
    eapply array_equals; eauto.
    simpl; repeat rewrite length_toArray in *; apply inj_imply; intuition.
    injection H3; clear H3; intros.
    eauto using toArray_sel.
  Qed.

  Lemma unify_ws : forall specs stn st ws V r sp fr ws' V' r' fr' streamV,
    interp specs (![array ws streamV * locals ("rp" :: ns) V r sp * fr] (stn, st))
    -> length ws' = length ws
    -> interp specs (![array ws' streamV * locals ("rp" :: ns) V' r' sp * fr'] (stn, st)
       ---> [| ws' = ws |])%PropX.
    clear H; intros.
    assert (Hlocals : interp specs (![array ws streamV * (locals ("rp" :: ns) V r sp * fr)] (stn, st)))
       by step auto_ext.
    assert (Hlocals' : himp specs
      (array ws' streamV * locals ("rp" :: ns) V' r' sp * fr')%Sep
      (array ws' streamV * (locals ("rp" :: ns) V' r' sp * fr'))%Sep)
      by step auto_ext.
    eapply Imply_trans; try (rewrite sepFormula_eq; apply Hlocals').
    simpl.
    replace ((array ws' streamV * (locals ("rp" :: ns) V' r' sp * fr'))%Sep stn
      (memoryIn (Mem st)))
      with (![array ws' streamV * (locals ("rp" :: ns) V' r' sp * fr')] (stn, st))%PropX
        by (rewrite sepFormula_eq; reflexivity).
    eapply Imply_trans.
    eapply array_equals; eauto.
    apply inj_imply; intuition.
  Qed.

  Transparent mult.

  Theorem unify : forall specs stn st ws V r sp fr ws' V' r' fr',
    interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r sp * fr] (stn, st))
    -> sel V size = length ws
    -> In stream ns
    -> In size ns
    -> In pos ns
    -> interp specs (![array ws' (sel V' stream) * locals ("rp" :: ns) V' r' sp * fr'] (stn, st)
       /\ [| sel V' size = length ws' |]
       ---> [| ws' = ws /\ sel V' stream = sel V stream /\ sel V' size = sel V size /\ sel V' pos = sel V pos |])%PropX.
    intros.
    apply Imply_I.
    eapply Inj_E; [ eapply And_E2; apply Env; simpl; eauto | ]; intro.
    eapply Inj_E.
    eapply Imply_E.
    apply interp_weaken; eapply unify_V; eauto.
    eapply And_E1; apply Env; simpl; eauto.
    intro.
    apply Inj_E with (goodSize (length ws')).
    rewrite sepFormula_eq; unfold sepFormula_def, starB, star.
    eapply Exists_E; [ eapply And_E1; apply Env; simpl; eauto | cbv beta; intro ].
    eapply Exists_E; [ apply Env; simpl; left; eauto | cbv beta; intro ].
    eapply Exists_E; [ eapply And_E1; eapply And_E2; apply Env; simpl; left; eauto | cbv beta; intro ].
    eapply Exists_E; [ apply Env; simpl; left; eauto | cbv beta; intro ].
    eapply Imply_E.
    apply interp_weaken; apply containsArray_goodSizex'.
    Focus 2.
    eapply And_E1; eapply And_E2; apply Env; simpl; eauto.
    eauto.
    intro.
    repeat rewrite H6 in * by assumption.
    eapply Inj_E.
    eapply Imply_E.
    apply interp_weaken; eapply unify_ws.
    eassumption.
    2: eapply And_E1; apply Env; simpl; eauto.
    apply natToW_inj; congruence || eauto.
    intro.
    apply Inj_I; intuition.
  Qed.

  Theorem splessReads : forall p' offset,
    spless (reads p' offset).
    induction p' as [ | [ ] ]; simpl; intuition.
  Qed.

  Hint Resolve splessReads.

  Opaque evalInstr mult.
  Transparent evalInstrs.

  Lemma simplify_reads : forall st' ws r fr stn specs p' offset st V,
    interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> evalInstrs stn st (reads p' offset) = Some st'
    -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
    -> patternBound p'
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> okVarName stream p'
    -> okVarName pos p'
    -> goodSize (offset + wordToNat (sel V pos) + length p')
    -> evalInstrs stn st (map (fun p0 =>
      Assign
      (LvMem (Sp + S (S (S (S (variablePosition ns (fst p0))))))%loc)
      (RvImm (snd p0))) (binds p' (suffix (offset + wordToNat (sel V pos)) ws))) = Some st'.
    clear H; induction p' as [ | [ ] ]; simpl; intuition;
      rewrite suffix_remains by auto;
        change (S (offset + wordToNat (sel V pos))) with (S offset + wordToNat (sel V pos)); eauto; simpl.

    match goal with
      | [ _ : match ?E with None => _ | _ => _ end = _ |- _ ] => case_eq E; intros
    end; match goal with
           | [ H : _ = _ |- _ ] => rewrite H in *
         end; try discriminate.

    destruct (string_dec stream s); try tauto.
    destruct (string_dec pos s); try tauto.
    assert (evalInstrs stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc) :: nil) = Some s0)
      by (simpl; rewrite H2; reflexivity).
    clear H2.
    replace (evalInstrs stn st
      (Assign (variableSlot s ns)
        (LvMem (Rp + 4 * offset)%loc) :: nil))
      with (evalInstrs stn st
         (Assign (variableSlot s ns)
            (LvMem (Imm (sel V stream ^+ $4 ^* $ (offset + wordToNat (sel V pos))))) :: nil)) in H10.
    assert (natToW (offset + wordToNat (sel V pos)) < $ (length ws)) by (apply lt_goodSize; eauto).
    prep_locals.
    generalize dependent H0; evaluate auto_ext; intro.
    case_eq (evalInstrs stn s0 (Assign Rv (variableSlot s ns) :: nil)); intros; prep_locals; evaluate auto_ext.
    rewrite sel_upd_eq in H17 by auto.
    unfold evalInstrs in H10, H15.
    repeat (match goal with
              | [ _ : match ?E with None => _ | _ => _ end = _ |- _ ] => case_eq E; intros
            end; match goal with
                   | [ H : _ = _ |- _ ] => rewrite H in *
                 end; try discriminate).
    unfold variablePosition in H19, H20; fold variablePosition in H19, H20.
    destruct (string_dec "rp" s); try congruence.
    simpl in *.
    replace (evalInstr stn st
      (Assign (LvMem (Sp + S (S (S (S (variablePosition ns s)))))%loc)
        (selN ws (offset + wordToNat (sel V pos))))) with (Some s3).
    change (match ws with
              | nil => nil
              | _ :: ws' => suffix (offset + wordToNat (sel V pos)) ws'
            end) with (suffix (S offset + wordToNat (sel V pos)) ws).
    replace (sel V pos) with (sel (upd V s (Array.sel ws (offset + wordToNat (sel V pos)))) pos).
    injection H10; clear H10; intros; subst.
    injection H15; clear H15; intros; subst.
    eapply IHp'.
    rewrite sel_upd_ne by auto.
    apply sepFormula_Mem with s1.
    step auto_ext.
    assert (evalInstrs stn s0
      (Assign Rv (LvMem (Sp + S (S (S (S (variablePosition ns s)))))%loc) :: nil) =
      Some s1).
    simpl; rewrite H19; reflexivity.
    symmetry; eapply scratchOnlyMem; [ | eassumption ].
    simpl; intuition congruence.
    assumption.
    rewrite sel_upd_ne; auto.
    assumption.
    assumption.
    repeat rewrite sel_upd_ne by auto; assumption.
    assumption.
    assumption.
    repeat rewrite sel_upd_ne by auto; eauto.
    repeat rewrite sel_upd_ne by auto; reflexivity.
    rewrite <- H20.

    injection H15; clear H15; intros; subst.
    injection H10; clear H10; intros; subst.
    assert (evalInstrs stn s0
      (Assign Rv (LvMem (Sp + S (S (S (S (variablePosition ns s)))))%loc) :: nil) =
      Some s1) by (simpl; rewrite H19; reflexivity).
    eapply sepFormula_Mem in H18.
    2: symmetry; eapply scratchOnlyMem; eauto; simpl; intuition.
    change (S (S (S (S (variablePosition ns s))))) with (4 + variablePosition ns s) in *.
    prep_locals.
    evaluate auto_ext.
    rewrite sel_upd_eq in H22 by auto.
    unfold Array.sel in H22.
    unfold natToW in H22; rewrite wordToNat_natToWord_idempotent in H22.
    generalize H19 H20 H22; clear; intros.
    Transparent evalInstr.

    apply evalAssign_rhs.
    simpl.
    unfold evalInstr, evalRvalue, evalLvalue, evalLoc in *.

    match goal with
      | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
        match E with
          | context[match _ with None => _ | _ => _ end] => fail 1
          | _ => destruct E; try discriminate
        end
    end.
    match goal with
      | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
        match E with
          | context[match _ with None => _ | _ => _ end] => fail 1
          | _ => case_eq E; intros; match goal with
                                      | [ H : _ = _ |- _ ] => rewrite H in *
                                    end; try discriminate
        end
    end.
    injection H20; clear H20; intros; subst; simpl Regs in *; simpl Mem in *.
    match goal with
      | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
        match E with
          | context[match _ with None => _ | _ => _ end] => fail 1
          | _ => case_eq E; intros; match goal with
                                      | [ H : _ = _ |- _ ] => rewrite H in *
                                    end; try discriminate
        end
    end.
    injection H19; clear H19; intros; subst; simpl Mem in *; simpl Regs in *.
    eapply ReadWriteEq in H.
    rewrite H in H0.
    rewrite <- H22.
    unfold rupd; simpl.
    assumption.

    change (goodSize (offset + wordToNat (sel V pos))); eauto.

    generalize H4; clear; intros.
    simpl.
    rewrite H4.
    match goal with
      | [ |- match match ?E1 with None => _ | _ => _ end with None => _ | _ => _ end
        = match match ?E2 with None => _ | _ => _ end with None => _ | _ => _ end ] =>
      replace E2 with E1; auto
    end.
    f_equal.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW; rewrite natToWord_wordToNat.
    W_eq.
  Qed.

  Opaque evalInstrs.

  Lemma Rv_preserve : forall rv posV len,
    rv = posV ^+ $ (len)
    -> rv = natToW (0 + wordToNat posV + len).
    simpl; intros; subst.
    rewrite natToW_plus.
    f_equal.
    symmetry; apply natToWord_wordToNat.
  Qed.

  Lemma guard_says_safe : forall stn st specs V ws r fr,
    bexpTrue (guard p 0) stn st
    -> Regs st Rv = sel V pos ^+ $ (length p)
    -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> sel V size = $ (length ws)
    -> goodSize (wordToNat (sel V pos) + Datatypes.length p)
    -> (0 + wordToNat (sel V pos) + length p <= length ws)%nat.
    simpl; intros.
    apply wle_goodSize.
    rewrite natToW_plus.
    unfold natToW; rewrite natToWord_wordToNat.
    rewrite <- H1.
    rewrite <- H5.
    eapply bexpTrue_bound; eauto.
    eauto.
    eauto.
  Qed.

  Opaque variablePosition.

  Hint Resolve Rv_preserve bexpSafe_guard guard_says_safe bexpFalse_not_matches simplify_reads.
  Hint Immediate sym_eq.

  Ltac wrap := wrap0; post; wrap1.

  Definition Parse1 : cmd imports modName.
    refine (Wrap _ H _ Parse1_
      (fun pre x => Postcondition (Then (ThenPre pre)) x
        \/ Postcondition (Else (ElsePre pre)) x)%PropX
      (fun pre =>
        In stream ns
        :: In size ns
        :: In pos ns
        :: (~In "rp" ns)
        :: patternBound p
        :: okVarName stream p
        :: okVarName pos p
        :: (forall stn st specs,
          interp specs (pre (stn, st))
          -> interp specs (ExX, Ex V, Ex ws, Ex r,
            ![ ^[array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp)] * #0] (stn, st)
            /\ [| sel V size = length ws
              /\ goodSize (wordToNat (sel V pos) + length p)
              /\ (wordToNat (sel V pos) <= length ws)%nat |]))%PropX
        :: VerifCond (Then (ThenPre pre))
        ++ VerifCond (Else (ElsePre pre)))
      _ _); abstract (wrap;
        try match goal with
              | [ H : context[reads] |- _ ] => generalize dependent H
            end; evaluate auto_ext; intros; eauto;
        repeat match goal with
                 | [ H : evalInstrs _ _ (_ ++ _) = None |- _ ] =>
                   apply evalInstrs_app_fwd_None in H; destruct H as [ | [ ? [ ? ] ] ]; intuition
                 | [ H : evalInstrs _ _ (_ ++ _) = Some _ |- _ ] =>
                   apply evalInstrs_app_fwd in H; destruct H as [ ? [ ] ]
                 | [ H : evalInstrs _ _ (reads _ _) = Some _ |- _ ] =>
                   edestruct (reads_exec _ _ H) as [V' [ ] ]; eauto; evaluate auto_ext
               end;
        try match goal with
              | [ |- exists x, _ /\ _ ] => eexists; split; [ solve [ eauto ] | try split; intros ];
                try (autorewrite with sepFormula; simpl; eapply Imply_trans; [
                  eapply unify; eauto
                  | apply inj_imply; intuition; subst; simpl in * ] )
              | _ => solve [ eapply reads_nocrash; eauto ]
            end;
        repeat match goal with
                 | _ => solve [ eauto ]
                 | [ H : _ = _ |- _ ] => rewrite H in *
                 | [ |- context[suffix ?N _] ] =>
                   match N with
                     | 0 + _ => fail 1
                     | _ =>
                       change N with (0 + N)
                   end
                 | [ H : matches ?a (suffix ?b ?c) |- False ] =>
                   assert (~matches a (suffix (0 + b) c)); try tauto; clear H
                 | [ _ : evalInstrs _ ?x (reads _ _) = Some _ |- _ ] => exists x; split; eauto
                 | _ => solve [ eapply bexpTrue_matches; eauto ]
               end).
  Defined.

End Parse.

Definition ParseOne (stream size pos : string) (p : pattern) (Then Else : chunk) : chunk := fun ns res =>
  Structured nil (fun _ _ H => Parse1 stream size pos p H (toCmd Then _ H ns res) (toCmd Else _ H ns res) ns).

Infix "++" := (fun p1 p2 : pattern => app p1 p2) : pattern_scope.
Delimit Scope pattern_scope with pattern.

Notation "'Match1' stream 'Size' size 'Position' pos 'Pattern' p { c1 } 'else' { c2 }" :=
  (ParseOne stream size pos p%pattern c1 c2)
  (no associativity, at level 95, stream at level 0, size at level 0, pos at level 0, p at level 0) : SP_scope.

Ltac parse0 := try solve [ intuition congruence ].

Ltac especialize H :=
  repeat match type of H with
           | forall x : ?T, _ =>
             let v := fresh in evar (v : T); let v' := eval unfold v in v in clear v; specialize (H v')
         end.

Ltac parse1 solver :=
  match goal with
    | [ H : forall (a : _ -> _), _ |- _ ] =>
      especialize H; post;
      match goal with
        | [ H : interp ?specs (?P ---> ?Q)%PropX |- _ ] =>
          let H' := fresh in assert (H' : interp specs P) by (propxFo; step auto_ext || solver);
            specialize (Imply_sound H H'); clear H H'; intro H
      end; propxFo; autorewrite with StreamParse in *; simpl in *

    | [ H : interp _ (![ _ ] _) |- _ ] => eapply Wrap.sepFormula_Mem in H; [ | eassumption ]
  end.

Ltac reveal_slots :=
  repeat match goal with
           | [ H : evalInstrs _ _ _ = _ |- _ ] =>
             progress unfold variableSlot in H; simpl in H
         end.

Hint Rewrite roundTrip_0 sel_upd_eq sel_upd_ne using congruence : StreamParse.

Hint Extern 1 (_ <= _)%nat => omega : StreamParse.

Ltac parse2 := autorewrite with StreamParse; auto with StreamParse.

Definition ParseOne' stream size pos (pr : pattern * chunk) :=
  ParseOne stream size pos (fst pr) (snd pr).

Notation "'Case' p c 'end'" := (p%pattern, c)
  (no associativity, at level 0, p at level 0, c at level 95, only parsing) : Case_scope.
Delimit Scope Case_scope with Case_.

Notation "'Match' stream 'Size' size 'Position' pos { case1 ;; .. ;; caseN }" :=
  (fun c : chunk => ParseOne' stream size pos case1%Case_ (..
    (ParseOne' stream size pos caseN%Case_
      c) ..))
  (no associativity, at level 95, stream at level 0, size at level 0, pos at level 0,
    case1 at next level, caseN at next level) : SP_scope.

Notation "'Default' { c }" := c (at level 0, c at level 95, no associativity, only parsing) : SP_scope.


Require Import Software.Language.DynamicBinding.
Require Import Software.Language.State.
Require Import Software.Language.ExecutionProp.
Require Import Software.Language.Syntax.
Require Import Software.Language.Value.
Import ObjectOrientedNotations.

Section Specs.
Open Scope oo_scope.

Variable exec_step : exec_step_relation.
Variable wf : term -> state -> Prop.

Notation "t1 '/' st1 '==>' t2 '/' st2" := (exec_step (Cexec_state t1 st1) (Cexec_state t2 st2))
  (at level 40, st1 at level 39, t2 at level 39, format "'[' t1 / st1 '==>' t2 / st2 ']'").

Notation "t1 '/' st1 '==>*' t2 '/' st2" := (multi exec_step (Cexec_state t1 st1) (Cexec_state t2 st2))
  (at level 40, st1 at level 39, t2 at level 39, format "'[' t1 / st1 '==>*' t2 / st2 ']'").

Definition deterministic_off : Prop :=
  forall x st,
  wf x st ->
  term_deterministic exec_step (x # "off"|()|) st.

Definition terminates_off : Prop :=
  forall x st,
  wf x st ->
  term_terminates exec_step (x # "off"|()|) st.

Definition preserves_wf_off : Prop :=
  forall x v st st',
  wf x st ->
  value v ->
  (x # "off"|()|) / st ==>* v / st' ->
  wf x st'.

Definition returns_tbool_off : Prop :=
  forall x v st st',
  wf x st ->
  value v ->
  (x # "off"|()|) / st ==>* v / st' ->
  exists b, v = (tbool b).

Definition perserves_off_off : Prop :=
  forall x st,
  wf x st ->
  term_preserves_term exec_step (x # "off"|()|) st (x # "off"|()|).

Definition perserves_off_after : Prop :=
  forall x st,
  wf x st ->
  term_preserves_term exec_step (x # "off"|()|) st (x # "after"|()|).

Definition perserves_off_item : Prop :=
  forall x st,
  wf x st ->
  term_preserves_term exec_step (x # "off"|()|) st (x # "item"|()|).

Definition off__no_side_effects : Prop :=
  forall x st,
  wf x st ->
    exists b st',
       (x # "off"|()|) / st ==>* tbool b / st'
    /\ states_eq_wrt exec_step (x # "off"|()|) st st'
    /\ states_eq_wrt exec_step (x # "after"|()|) st st'
    /\ states_eq_wrt exec_step (x # "item"|()|) st st'.

End Specs.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (plus (mult (Zero) (Zero)) (Zero)) (mult (Zero) (Succ (Zero)))).
Admitted.
QuickChick lfind_hyp_test.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import coqutil.Byte.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Tactics.Tactics.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Scalars.
Require Import bedrock2.Syntax.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Common.Arrays.ByteBounds.
Require Import Crypto.Bedrock.Field.Common.Arrays.MakeAccessSizes.
Require Import Crypto.Bedrock.Field.Common.Arrays.MakeListLengths.
Require Import Crypto.Bedrock.Field.Common.Arrays.MaxBounds.
Require Import Crypto.Bedrock.Field.Common.Names.MakeNames.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Func.
Require Import Crypto.Bedrock.Field.Translation.Func.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.UnsaturatedSolinas.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Language.API.
Require Import Coq.Lists.List. (* after SeparationLogic *)

Existing Instances rep.Z rep.listZ_mem.

Import Language.Compilers.
Import Associational Positional.

Require Import Crypto.Util.Notations.
Import Types.Notations ListNotations.
Import QArith_base.
Local Open Scope Z_scope.

Local Coercion Z.of_nat : nat >-> Z.
Local Coercion inject_Z : Z >-> Q.
Local Coercion Z.pos : positive >-> Z.

Declare Scope sep_scope.
Local Delimit Scope sep_scope with sep.
Local Infix "*" := sep : sep_scope.

Ltac apply_correctness_in H :=
  match type of H with
  | context [UnsaturatedSolinas.carry_mul] =>
    apply UnsaturatedSolinas.carry_mul_correct in H
  | context [UnsaturatedSolinas.carry_square] =>
    apply UnsaturatedSolinas.carry_square_correct in H
  | context [UnsaturatedSolinas.carry] =>
    apply UnsaturatedSolinas.carry_correct in H
  | context [UnsaturatedSolinas.add] =>
    apply UnsaturatedSolinas.add_correct in H
  | context [UnsaturatedSolinas.sub] =>
    apply UnsaturatedSolinas.sub_correct in H
  | context [UnsaturatedSolinas.opp] =>
    apply UnsaturatedSolinas.opp_correct in H
  | context [UnsaturatedSolinas.selectznz] =>
    eapply Primitives.selectznz_correct in H
  | context [UnsaturatedSolinas.to_bytes] =>
    apply UnsaturatedSolinas.to_bytes_correct in H
  | context [UnsaturatedSolinas.from_bytes] =>
    apply UnsaturatedSolinas.from_bytes_correct in H
  | context [UnsaturatedSolinas.carry_scmul_const] =>
    apply UnsaturatedSolinas.carry_scmul_const_correct in H
  | context [UnsaturatedSolinas.encode] =>
    apply UnsaturatedSolinas.encode_correct in H
  | context [UnsaturatedSolinas.zero] =>
    apply UnsaturatedSolinas.zero_correct in H
  | context [UnsaturatedSolinas.one] =>
    apply UnsaturatedSolinas.one_correct in H
  end.

Section __.
  Context {p : Types.parameters}
          {inname_gen outname_gen : nat -> string}
          (n : nat) (s : Z) (c : list (Z * Z)).
  Local Notation is_correct :=
    (@is_correct p inname_gen outname_gen).
  Local Notation loose_bounds :=
    (UnsaturatedSolinasHeuristics.loose_bounds n s c).
  Local Notation tight_bounds :=
    (UnsaturatedSolinasHeuristics.tight_bounds n s c).
  Local Notation bit_range := {|ZRange.lower := 0; ZRange.upper := 1|}.
  Local Notation saturated_bounds :=
    (Primitives.saturated_bounds n Semantics.width).
  Local Notation prime_bytes_bounds :=
    (UnsaturatedSolinas.prime_bytes_bounds s).
  Local Notation n_bytes := (UnsaturatedSolinas.n_bytes s).
  Local Notation M := (UnsaturatedSolinas.m s c).
  Definition weight :=
    (ModOps.weight
       (Qnum (inject_Z (Z.log2_up M) / inject_Z (Z.of_nat n)))
       (QDen (inject_Z (Z.log2_up M) / inject_Z (Z.of_nat n)))).
  Local Notation eval := (eval weight n).

  (* Note: annoyingly, prime_bytes_bounds and saturated_bounds are option types,
     unlike loose_bounds or tight_bounds, so we have to refer to the values they
     wrap in Some whenever we want to use them with list_Z_bounded_by *)
  Local Notation prime_bytes_bounds_value :=
    (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
         (prime_bytes_upperbound_list s)).
  Local Notation saturated_bounds_value :=
    (Primitives.saturated_bounds_list n Semantics.width).

  Ltac select_access_size bounds :=
    lazymatch bounds with
    | saturated_bounds => constr:(access_size.word)
    | Some loose_bounds => constr:(access_size.word)
    | Some tight_bounds => constr:(access_size.word)
    | prime_bytes_bounds => constr:(access_size.one)
    | ?b => fail "unable to select access size for bound" b
    end.

  Ltac select_length bounds :=
    lazymatch bounds with
    | saturated_bounds => constr:(n)
    | Some loose_bounds => constr:(n)
    | Some tight_bounds => constr:(n)
    | prime_bytes_bounds => constr:(n_bytes)
    | ?b => fail "unable to select array length for bound" b
    end.

  Ltac sizes_from_bounds := map_bounds_listonly select_access_size.
  Ltac lengths_from_bounds := map_bounds_listonly select_length.

  Ltac prove_operation_correctness :=
    intros;
    let Hcorrect :=
        lazymatch goal with H : _ = ErrorT.Success _ |- _ => H end in
    apply_correctness_in Hcorrect; [ | eassumption .. ];
    fold weight in *; specialize_to_args Hcorrect;
    postcondition_from_correctness.

  Ltac make_operation out :=
    let inbounds := (eval cbv beta in (Pipeline.arg_bounds_of_pipeline out)) in
    let outbounds := (eval cbv beta in (Pipeline.out_bounds_of_pipeline out)) in
    let t := lazymatch goal with |- operation ?t => t end in
    let insizes := sizes_from_bounds inbounds in
    let outsizes := sizes_from_bounds outbounds in
    let inlengths := lengths_from_bounds inbounds in
    let outlengths := lengths_from_bounds outbounds in
    eapply (Build_operation
              t inbounds insizes outsizes inlengths outlengths)
    with (pipeline_out:=out)
         (check_args_ok:=
            check_args n s c machine_wordsize (ErrorT.Success tt)
            = ErrorT.Success tt).

  Definition carry_mul
    : operation (type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.carry_mul n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition carry_square
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.carry_square n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition carry
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.carry n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition add
    : operation (type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.add n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition sub
    : operation (type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.sub n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition opp
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.opp n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition selectznz
    : operation (type_Z -> type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.selectznz n Semantics.width).
    prove_operation_correctness.
    Unshelve.
    { apply Semantics.width. }
    { apply (UnsaturatedSolinasHeuristics.limbwidth n s c). }
  Defined.

  Definition to_bytes
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.to_bytes n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition from_bytes
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.from_bytes n s c Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition carry_scmul_const (x : Z)
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (UnsaturatedSolinas.carry_scmul_const n s c Semantics.width x).
    prove_operation_correctness.
  Defined.

  Definition spec_of_carry_mul name : spec_of name :=
    fun functions =>
      forall wx wy px py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := carry_mul in
        let args := (map word.unsigned wx, (map word.unsigned wy, tt)) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: py ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat
                      n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_carry_square name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := carry_square in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_carry name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := carry in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_add name : spec_of name :=
    fun functions =>
      forall wx wy px py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := add in
        let args := (map word.unsigned wx, (map word.unsigned wy, tt)) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: py ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_sub name : spec_of name :=
    fun functions =>
      forall wx wy px py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := sub in
        let args := (map word.unsigned wx, (map word.unsigned wy, tt)) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: py ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_opp name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := opp in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_selectznz name : spec_of name :=
    fun functions =>
      forall wc wx px wy py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := selectznz in
        let args := (word.unsigned wc,
                     (map word.unsigned wx, (map word.unsigned wy, tt))) in
        let c := word.unsigned wc in
        ZRange.is_bounded_by_bool c bit_range = true ->
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: wc :: px :: py ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_to_bytes name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := to_bytes in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (EncodedBignum n_bytes pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (EncodedBignumSuchThat
                      n_bytes pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_from_bytes name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := from_bytes in
        let args := (map byte.unsigned wx, tt) in
        op.(precondition) args ->
        (EncodedBignum n_bytes px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat
                      n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_carry_scmul_const (z : Z) (name : string)
    : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := carry_scmul_const z in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px ::  nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Hint Unfold carry_mul carry_square carry add sub opp selectznz
       to_bytes from_bytes carry_scmul_const : defs.
  Hint Unfold
       spec_of_carry_mul
       spec_of_carry_square
       spec_of_carry
       spec_of_add
       spec_of_sub
       spec_of_opp
       spec_of_selectznz
       spec_of_to_bytes
       spec_of_from_bytes
       spec_of_carry_scmul_const : specs.

  Section Proofs.
    Context {ok : Types.ok}.
    Existing Instance semantics_ok.

    (* loose_bounds_ok could be proven in parameterized form, but is a pain
      and is easily computable with parameters plugged in. So for now, leaving
      as a precondition. *)
    Context
      (loose_bounds_ok :
         ZRange.type.option.is_tighter_than
           (t:=type_listZ) (Some loose_bounds)
           (Some (max_bounds n)) = true).

    Context (inname_gen_varname_gen_ok : disjoint inname_gen varname_gen)
            (outname_gen_varname_gen_ok : disjoint outname_gen varname_gen)
            (outname_gen_inname_gen_ok : disjoint outname_gen inname_gen).
    Context (inname_gen_unique : unique inname_gen)
            (outname_gen_unique : unique outname_gen).

    Lemma relax_to_max_bounds x :
      list_Z_bounded_by loose_bounds x ->
      list_Z_bounded_by (max_bounds n) x.
    Proof. apply relax_list_Z_bounded_by; auto. Qed.

    Lemma relax_to_byte_bounds x :
      list_Z_bounded_by prime_bytes_bounds_value x ->
      list_Z_bounded_by (byte_bounds n_bytes) x.
    Proof.
      cbv [prime_bytes_bounds prime_bytes_upperbound_list].
      intros; eapply relax_to_bounded_upperbounds;
        eauto using ByteBounds.partition_bounded_by; [ ].
      apply Forall_repeat. reflexivity.
    Qed.

    Lemma bounded_by_loose_bounds_length x :
      list_Z_bounded_by loose_bounds x -> length x = n.
    Proof.
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      autorewrite with distr_length in *; lia.
    Qed.

    Lemma bounded_by_saturated_bounds_length x :
      list_Z_bounded_by saturated_bounds_value x -> length x = n.
    Proof.
      cbv [saturated_bounds max_bounds].
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      rewrite length_saturated_bounds_list in *. lia.
    Qed.

    Lemma bounded_by_prime_bytes_bounds_length x :
      list_Z_bounded_by prime_bytes_bounds_value x -> length x = n_bytes.
    Proof.
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      cbv [prime_bytes_bounds prime_bytes_upperbound_list] in *.
      rewrite map_length, length_partition in *. lia.
    Qed.

    Lemma bounded_by_byte_bounds_length x :
      list_Z_bounded_by (byte_bounds n_bytes) x -> length x = n_bytes.
    Proof. eapply byte_bounds_range_iff. Qed.

    (* TODO: maybe make a generalized prove_bounds tactic that takes a list of
    bounds? *)
    Ltac assert_bounds x :=
      match goal with
      | H: list_Z_bounded_by ?bs x |- _ => idtac
      | _ => assert (list_Z_bounded_by tight_bounds x) by prove_bounds_direct
      | _ => assert (list_Z_bounded_by loose_bounds x) by prove_bounds_direct
      | _ => assert (list_Z_bounded_by prime_bytes_bounds x) by prove_bounds_direct
      | _ => assert (list_Z_bounded_by (max_bounds n) x) by prove_bounds_direct
      | _ => assert (list_Z_bounded_by (byte_bounds n_bytes) x) by prove_bounds_direct
      | _ => fail "could not determine known bounds of" x
      end.
    (* looks for the following combinations of tighter/looser bounds:
       - tight_bounds/saturated_bounds
       - tight_bounds/loose_bounds
       - loose_bounds/saturated_bounds
       - prime_bytes_bounds/byte_bounds
    *)
    Ltac prove_bounds :=
      match goal with |- list_Z_bounded_by ?bs ?x => assert_bounds x end;
      match goal with
      | H : list_Z_bounded_by ?b1 ?x |- list_Z_bounded_by ?b2 ?x =>
        first [ unify b1 b2; apply H
              | unify b1 tight_bounds; unify b2 saturated_bounds_value;
                apply relax_to_max_bounds, relax_correct; apply H
              | unify b1 tight_bounds; unify b2 loose_bounds;
                apply relax_correct; apply H
              | unify b1 loose_bounds; unify b2 saturated_bounds_value;
                apply relax_to_max_bounds; apply H
              | unify b1 prime_bytes_bounds_value; unify b2 (byte_bounds n_bytes);
                apply relax_to_byte_bounds; apply H ]
      end.

    (* special for to_bytes, because bounds are not included in the
       postcondition as with all other operations *)
    Ltac assert_to_bytes_bounds :=
      match goal with
      | H : postcondition ?op _ ?e |- _ =>
        unify op to_bytes;
        assert (list_Z_bounded_by (byte_bounds n_bytes) e)
          by (cbn [fst snd postcondition to_bytes] in H;
              rewrite H by prove_bounds;
              apply ByteBounds.partition_bounded_by)
      end.

    Ltac prove_output_length :=
      ssplit;
      match goal with
      | |- length _ = n =>
        apply bounded_by_loose_bounds_length; prove_bounds
      | |- length _ = n =>
        apply bounded_by_saturated_bounds_length; prove_bounds
      | |- length _ = n_bytes =>
        apply bounded_by_byte_bounds_length; prove_bounds
      | |- length _ = n_bytes =>
        apply bounded_by_prime_bytes_bounds_length; prove_bounds
      | |- n = length _ =>
        symmetry; prove_output_length
      | |- n_bytes = length _ =>
        symmetry; prove_output_length
      | |- ?x => fail "could not prove output length :" x
      end.

    Ltac setup :=
      autounfold with defs specs;
      begin_proof;
      match goal with
        H1 : precondition _ _, H2 : precondition _ _ -> _ |- _ =>
        specialize (H2 H1); autounfold with defs in H1;
        cbn [precondition] in H1; cleanup
      end;
      try assert_to_bytes_bounds;
      assert_output_length prove_output_length.

    Ltac prove_length :=
      lazymatch goal with
      | H : map _ ?x = ?y |- length ?x = length ?y =>
        rewrite <-H, !map_length; congruence
      | H : length ?x = ?n |- length (map _ ?x) = ?n =>
        rewrite map_length; solve [apply H]
      | |- length ?x = length ?y =>
        rewrite ?map_length in *; congruence
      | _ => idtac
      end.

    Ltac use_translate_func_correct Rout arg_ptrs out_array_ptrs :=
      apply_translate_func_correct Rout arg_ptrs out_array_ptrs;
      [ post_sufficient;
        cbv [Bignum EncodedBignum] in *; sepsimpl;
        prove_length; canonicalize_arrays; ecancel_assumption
      | .. ].

    Ltac solve_lists_reserved out_array_ptrs :=
      exists_all_placeholders out_array_ptrs;
      cbv [Bignum EncodedBignum] in *; sepsimpl;
        lazymatch goal with
        | |- length _ = _ => prove_length
        | |- WeakestPrecondition.get _ _ _ =>
          eexists; rewrite ?map.get_put_diff by eauto;
          rewrite map.get_put_same; solve [eauto]
        | |- sep _ _ _ => canonicalize_arrays; ecancel_assumption
        end.

    Ltac prove_is_correct Rout :=
      let args := lazymatch goal with
                  | H : postcondition _ ?args _ |- _ => args end in
      let arg_ptrs := get_bedrock2_arglist args in
      let all_ptrs := lazymatch goal with
                      | |- call _ _ _ _ ?in_ptrs _ => in_ptrs end in
      let out_ptrs := get_out_array_ptrs arg_ptrs all_ptrs in
      use_translate_func_correct Rout arg_ptrs out_ptrs;
      solve_translate_func_subgoals prove_bounds prove_output_length;
      [ repeat next_argument; [ .. | reflexivity ];
        cbv [Bignum EncodedBignum] in *; sepsimpl;
        canonicalize_arrays; ecancel_assumption
      | setup_lists_reserved; solve_lists_reserved out_ptrs ].

    Context (check_args_ok :
               check_args n s c Semantics.width (ErrorT.Success tt)
               = ErrorT.Success tt).

    Lemma carry_mul_correct name :
      is_correct
        (UnsaturatedSolinas.carry_mul n s c Semantics.width)
        carry_mul (spec_of_carry_mul name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma carry_square_correct name :
      is_correct
        (UnsaturatedSolinas.carry_square n s c Semantics.width)
        carry_square (spec_of_carry_square name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma carry_correct name :
      is_correct
        (UnsaturatedSolinas.carry n s c Semantics.width)
        carry (spec_of_carry name).
    Proof. setup. prove_is_correct Rout. Qed.

    Lemma add_correct name :
      is_correct
        (UnsaturatedSolinas.add n s c Semantics.width)
        add (spec_of_add name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma sub_correct name :
      is_correct
        (UnsaturatedSolinas.sub n s c Semantics.width)
        sub (spec_of_sub name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma opp_correct name :
      is_correct
        (UnsaturatedSolinas.opp n s c Semantics.width)
        opp (spec_of_opp name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma selectznz_correct name :
      is_correct
        (UnsaturatedSolinas.selectznz n Semantics.width)
        selectznz (spec_of_selectznz name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma to_bytes_correct name :
      is_correct
        (UnsaturatedSolinas.to_bytes n s c Semantics.width)
        to_bytes (spec_of_to_bytes name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma from_bytes_correct name :
      is_correct
        (UnsaturatedSolinas.from_bytes n s c Semantics.width)
        from_bytes (spec_of_from_bytes name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma carry_scmul_const_correct (x : Z) name :
      is_correct
        (UnsaturatedSolinas.carry_scmul_const n s c Semantics.width x)
        (carry_scmul_const x) (spec_of_carry_scmul_const x name).
    Proof. setup; prove_is_correct Rout. Qed.
  End Proofs.
End __.
Hint Unfold carry_mul carry_square carry add sub opp selectznz
     to_bytes from_bytes carry_scmul_const : defs.
Hint Unfold
     spec_of_carry_mul
     spec_of_carry_square
     spec_of_carry
     spec_of_add
     spec_of_sub
     spec_of_opp
     spec_of_selectznz
     spec_of_to_bytes
     spec_of_from_bytes
     spec_of_carry_scmul_const : specs.


Require Import String.
Require Import Lia.
Require Import List.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import Coq.Vectors.VectorEq.
Require Import Coq.Arith.Bool_nat.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export RelationClasses.
Require Export Morphisms.
Require Import Program.
From ST Require Import EVarsScratchwork.
From ST Require Import Vector.
From ST Require Export Logic.V Logic.Term.
From ST Require Export SoftType.Radix SoftType.Attribute SoftType.Adjective SoftType.SoftType SoftType.JudgementType.
From ST Require Export SoftType.LocalContext.
Import ListNotations.
Import VectorNotations.
Open Scope string_scope.

(** ** Global Contexts

We now can track definitions of terms, types, etc., using a [GlobalContext].
This is encoded as just a list of [JudgementType] and the relevant local
variables as found in a [LocalContext].
*)
Definition GlobalContext := list (LocalContext * JudgementType).

Definition list_evars_gc_def (d : LocalContext * JudgementType) :=
match d with
  | (lc, T) => insert_merge (list_evars lc) (list_evars T)
  end.

Global Instance EnumerateEVarsGlobalContext : EnumerateEVars GlobalContext := {
list_evars gc := List.fold_left (fun l' => fun d =>
  insert_merge (list_evars_gc_def d)  l')
 gc []%list
}.

Theorem list_evars_global_context_sorted : forall (gc : GlobalContext),
  sorted (list_evars gc).
Proof.
  intros.
  unfold list_evars; unfold EnumerateEVarsGlobalContext.
  apply insert_merge_list_fold_sorted. apply sorted_nil.
Qed.

(** Judgements of the form [t : T] are where we define new constant terms. *)
Fixpoint gc_defines_term (gc : GlobalContext) (n : name) : Prop :=
  match gc with
  | List.cons (lc, Esti (Fun nm _) T) tl => (n = nm) \/ gc_defines_term tl n
  | _ => False
  end.

Fixpoint gc_defines_type (gc : GlobalContext) (n : name) : Prop :=
  match gc with
  | List.cons (lc, Subtype T1 T2) tl => (type_is_named T1 n) \/ (type_is_named T2 n) \/ (gc_defines_type  tl n)
  | List.cons (lc, Inhabited T) tl =>(type_is_named T n) \/ (gc_defines_type  tl n)
  | _ => False
  end.

Fixpoint gc_defines_attr (gc : GlobalContext) (n : name) : Prop :=
  match gc with
  | List.cons (lc, HasAttribute (Attr _ a args) T) tl => (a = n) \/ (gc_defines_attr tl n)
  | _ => False
  end.

(* This is what *I* would want, as a user of the system... *)
Fixpoint gc_contains_generous (Γ : GlobalContext) (def : (LocalContext * JudgementType)) : Prop :=
  match Γ,def with
  | List.cons (lc, J') Γ', (subcontext, J) => ((lc_is_subcontext subcontext lc) /\ J = J') \/ gc_contains_generous Γ' def
  | List.nil, _ => False
  end.

(* This is what I want, when proving properties of the system... *)
Definition gc_contains (Γ : GlobalContext) (def : (LocalContext * JudgementType)) : Prop :=
  List.In def Γ.


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 P Q A B Bprime Cprime : Universe, ((wd_ P Q /\ (wd_ P A /\ (wd_ P Bprime /\ (wd_ P Cprime /\ (wd_ B Bprime /\ (wd_ B Cprime /\ (wd_ A B /\ (wd_ A Bprime /\ (wd_ B P /\ (col_ P Q A /\ (col_ P Q Bprime /\ (col_ P Q Cprime /\ (col_ B B Bprime /\ col_ A B B))))))))))))) -> col_ P Bprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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