From st.STLCmuVS Require Import lang tactics typing.
From st.STLCmu Require Import types.

Local Open Scope expr_no_st_scope.
Local Open Scope types_no_st_scope.

Definition FixArrow (f : expr) : expr :=
  Unfold (Fold (Lam ((f.[ren (+1)]) (Lam ((Unfold (Var 1)) (Var 1) (Var 0))))))
    (Fold (Lam (f.[ren (+1)] (Lam ((Unfold (Var 1)) (Var 1) (Var 0)))))).

Lemma FixArrow_subst e σ : (FixArrow e).[σ] = FixArrow e.[σ].
Proof. rewrite /FixArrow. by asimpl. Qed.

Lemma help τ1 τ2 : (TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]) ⟶ τ1 ⟶ τ2)%Tₙₒ = (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]).[TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)])%Tₙₒ/].
Proof. by asimpl. Qed.

Lemma FixArrow_typed Γ τ1 τ2 f : (Γ ⊢ₙₒ f : TArrow (TArrow τ1 τ2) (TArrow τ1 τ2))
  -> (Γ ⊢ₙₒ FixArrow f : TArrow τ1 τ2).
Proof.
  intro df. apply App_typed with (τ1 := (TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]))%Tₙₒ).
  rewrite help. apply Unfold_typed. apply Fold_typed. apply Lam_typed. apply App_typed with (τ1 := TArrow τ1 τ2). asimpl.
  change ([ TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]) ] ++ Γ ⊢ₙₒ f.[ren (+ length [ TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]) ])] : ((τ1 ⟶ τ2) ⟶ τ1 ⟶ τ2)%Tₙₒ). by apply context_weakening.
  asimpl. apply Lam_typed. eapply App_typed. econstructor. erewrite help. apply Unfold_typed. by constructor. by constructor. by constructor.
  apply Fold_typed. apply Lam_typed. apply App_typed with (τ1 := TArrow τ1 τ2). asimpl.
  change ([ TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]) ] ++ Γ ⊢ₙₒ f.[ren (+ length [ TRec (TVar 0 ⟶ τ1.[ren (+1)] ⟶ τ2.[ren (+1)]) ])] : ((τ1 ⟶ τ2) ⟶ τ1 ⟶ τ2)%Tₙₒ). by apply context_weakening.
  asimpl. apply Lam_typed. eapply App_typed. econstructor. erewrite help. apply Unfold_typed. by constructor. by constructor. by constructor.
Qed.

Lemma FixArrow_eval f : nsteps STLCmuVS_step 2 (FixArrow f) (f (Lam ((FixArrow f).[ren (+1)] %0)))%Eₙₒ.
Proof. do 2 (eapply nsteps_l; first auto_STLCmuVS_step; asimpl). by apply nsteps_O. Qed.

Definition Rec (e : {bind 2 of expr}) : val :=
  LamV ((FixArrow (Lam (Lam e))).[ren (+1)] %0)%Eₙₒ.

(* Definition Rec (e : {bind 2 of expr}) : expr := *)
(*   Lam ((FixArrow (Lam (Lam e.[upn 0 (ren (lookup_n (swap_list 1 1)))]))).[ren (+1)] %0)%Eₙₒ. *)

Lemma Rec_typed Γ e τ1 τ2 : (τ1 :: TArrow τ1 τ2 :: Γ ⊢ₙₒ e : τ2)
  -> (Γ ⊢ₙₒ Rec e : TArrow τ1 τ2).
Proof.
  constructor. apply App_typed with (τ1 := τ1). apply context_weakening1. apply FixArrow_typed. constructor. by constructor. by constructor.
  (* cut ([] ++ [τ1] ++ [TArrow τ1 τ2] ++ Γ ⊢ₙₒ e.[upn (length ([] : list type)) (ren (lookup_n (swap_list (length [τ1]) (length [TArrow τ1 τ2]))))] : τ2). by asimpl. *)
  (* apply context_swap_typed. by simpl. by constructor. *)
Qed.

Global Opaque FixArrow.

Lemma Rec_subst (e : {bind 2 of expr}) σ : (of_val $ Rec e).[σ] = of_val $ Rec (e.[ids 0 .: ids 1 .: σ >> ren (+2)]).
Proof.
  asimpl. rewrite !FixArrow_subst. by asimpl.
Qed.

Lemma App_Rec_nsteps e1 e2 v2 :
   to_val e2 = Some v2 →
   nsteps STLCmuVS_step 5 (App (Rec e1) e2) e1.[e2, (of_val $ Rec e1)/].
Proof.
  intros.
  eapply nsteps_l. auto_STLCmuVS_step. simplify_custom.
  change 4 with (2 + 2)%nat.
  eapply nsteps_trans. apply (nsteps_STLCmuVS_step_ctx (fill_item (AppLCtx _))). apply FixArrow_eval.
  rewrite FixArrow_subst. asimpl.
  eapply nsteps_l. auto_STLCmuVS_step. simplify_custom.
  rewrite FixArrow_subst. asimpl.
  eapply nsteps_l. auto_STLCmuVS_step. simplify_custom.
  rewrite FixArrow_subst. asimpl.
  rewrite (of_to_val _ _ H) /Rec.
  apply nsteps_O.
Qed.

Global Opaque Rec.

(* Lemma App_Rec_nsteps e1 e2 v2 : *)
(*    to_val e2 = Some v2 → *)
(*    nsteps STLCmuVS_step 5 (App (Rec e1) e2) e1.[(Rec e1), e2/]. *)
(* Proof. *)
(*   intros. *)
(*   eapply nsteps_l. auto_STLCmuVS_step. simplify_custom. *)
(*   change 4 with (2 + 2)%nat. *)
(*   eapply nsteps_trans. apply (nsteps_STLCmuVS_step_ctx (fill_item (AppLCtx _))). apply FixArrow_eval. *)
(*   rewrite FixArrow_subst. asimpl. *)
(*   eapply nsteps_l. auto_STLCmuVS_step. simplify_custom. *)
(*   rewrite FixArrow_subst. asimpl. *)
(*   eapply nsteps_l. auto_STLCmuVS_step. simplify_custom. *)
(*   rewrite FixArrow_subst. asimpl. *)

(* Lemma FixArrow_eval f : nsteps STLCmuVS_step 2 (FixArrow f) (f (Lam ((FixArrow f).[ren (+1)] %0)))%Eₙₒ. *)
(* Proof. do 2 (eapply nsteps_l; first auto_STLCmuVS_step; asimpl). by apply nsteps_O. Qed. *)

(* Definition FixLamBodyHelp (e : expr) := Lam ((Lam (e.[(%0 ())%Eₙₒ .: ren (+1)].[ren (+1)]))). *)

(* Definition FixLam (e : expr) := *)
(*   (Lam ((FixArrow (FixLamBodyHelp e)).[ren (+1)] %0) ())%Eₙₒ. *)

(* Lemma FixLam_eval e : nsteps STLCmuVS_step 5 (FixLam e) (e.[FixLam e/]). *)
(* Proof. *)
(*   eapply nsteps_l. apply head_prim_step. auto_head_step. *)
(*   cut (nsteps STLCmuVS_step 4 ((FixArrow (FixLamBodyHelp e)) ()) e.[FixLam e/])%Eₙₒ. asimpl. *)
(*   rewrite /FixArrow. by asimpl. *)
(*   assert (4 = (2 + 2)%nat) as ->. done. *)
(*   eapply nsteps_trans. *)
(*   eapply (nsteps_congruence (fill [AppLCtx ()%Eₙₒ])). intros. apply STLCmuVS_step_ctx. apply ectx_lang_ctx. apply H. *)
(*   apply FixArrow_eval. *)
(*   eapply nsteps_l. auto_STLCmuVS_step. asimpl. *)
(*   eapply nsteps_l. auto_STLCmuVS_step. asimpl. *)
(*   rewrite /FixLam /FixLamBodyHelp. asimpl. apply nsteps_O. *)
(* Qed. *)

(* Lemma small_help Γ e τ i : *)
(*   Γ ⊢ₙₒ e : τ → (alter (fun τ => TArrow TUnit τ) i Γ) ⊢ₙₒ e.[upn i ((%0 ())%Eₙₒ .: ren (+1))] : τ. *)
(* Proof. *)
(*   generalize dependent i. *)
(*   generalize dependent τ. *)
(*   generalize dependent Γ. *)
(*   induction e; intros; simpl. *)
(*   - destruct (iter_up_cases x i ((%0)%Eₙₒ ()%Eₙₒ .: ren (+1))) as [[-> lt] | [j [-> ->]]]. *)
(*     + inversion_clear H. constructor. rewrite list_lookup_alter_ne. auto. lia. *)
(*     + inversion_clear H. destruct j. asimpl. *)
(*       econstructor. econstructor. rewrite list_lookup_alter. *)
(*       assert ((i + 0)%nat = i) as eq. lia. rewrite eq in H0. *)
(*       by simplify_option_eq. *)
(*       econstructor. *)
(*       asimpl. constructor. rewrite list_lookup_alter_ne. *)
(*       assert ((i + S j)%nat = S (i + j)%nat) as eq. lia. by rewrite eq in H0. lia. *)
(*   - simpl. inversion_clear H. econstructor. eapply (IHe0 (τ1 :: Γ) τ (S i) H0). by eapply IHe. *)
(*   - simpl. inversion_clear H. econstructor. eapply (IHe (τ1 :: Γ) τ2 (S i) H0). *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe1. by eapply IHe2. *)
(*   - simpl. inversion_clear H; econstructor. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe1. by eapply IHe2. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe1. by eapply IHe2. by eapply IHe3. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe1. by eapply IHe2. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe1. by eapply IHe2. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(*       by eapply (IHe0 (τ1 :: Γ) τ (S i)). *)
(*       by eapply (IHe1 (τ2 :: Γ) τ (S i)). *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(*   - simpl. inversion_clear H. econstructor. by eapply IHe. *)
(* Qed. *)

(* Lemma FixLamBodyHelp_typed Γ e τ : τ :: Γ ⊢ₙₒ e : τ → Γ ⊢ₙₒ FixLamBodyHelp e : ((TUnit ⟶ τ) ⟶ TUnit ⟶ τ)%Tₙₒ. *)
(* Proof. *)
(*   intro H. *)
(*   apply Lam_typed. apply Lam_typed. change ([TUnit] ++ TUnit ⟶ τ :: Γ ⊢ₙₒ e.[%0 () .: ren (+1)].[ren (+1)] : τ). apply context_weakening. *)
(*   cut ((alter (fun τ => TArrow TUnit τ) 0 (τ :: Γ)) ⊢ₙₒ e.[upn 0 ((%0 ())%Eₙₒ .: ren (+1))] : τ). by asimpl. by apply small_help. *)
(* Qed. *)

(* Lemma FixLam_typed Γ e τ : τ :: Γ ⊢ₙₒ e : τ → Γ ⊢ₙₒ FixLam e : τ. *)
(* Proof. *)
(*   intro H. apply App_typed with (τ1 := TUnit). *)
(*   apply Lam_typed. apply App_typed with (τ1 := TUnit). *)
(*   change ([TUnit] ++ Γ ⊢ₙₒ (FixArrow (FixLamBodyHelp e)).[ren (+1)] : TArrow TUnit τ). apply context_weakening. *)
(*   apply FixArrow_typed. apply FixLamBodyHelp_typed. auto. by econstructor. constructor. *)
(* Qed. *)

(* Lemma FixLam_subst e σ : (FixLam e).[σ] = FixLam e.[up σ]. *)
(* Proof. rewrite /FixLam. by asimpl. Qed. *)

(* Global Opaque FixLam. *)
(* Global Opaque FixArrow. *)


(* Import ListNotations. *)
(* Local Open Scope logic. *)

Require Import HMAC_functional_prog.
Require Import SHA256.

Lemma mkKey_length l: length (HMAC_SHA256.mkKey l) = SHA256_.BlockSize.
Proof. intros. unfold HMAC_SHA256.mkKey.
  remember (Zlength l >? Z.of_nat SHA256_.BlockSize) as z.
  destruct z. apply zeroPad_BlockSize.
    rewrite length_SHA256'.
    apply Nat2Z.inj_le. simpl. omega.
  apply zeroPad_BlockSize.
    rewrite Zlength_correct in Heqz.
    apply Nat2Z.inj_le.
    specialize (Zgt_cases (Z.of_nat (Datatypes.length l)) (Z.of_nat SHA256.BlockSize)). rewrite <- Heqz. trivial.
Qed.


Require Import Verse.Word.
Require Import Verse.Types.Internal.
Require Import Verse.Types.
Require Import Verse.Language.Operators.
Require Import Verse.Semantics.

Module EmptyWord <: WORD_SEMANTICS.

  Definition wordDenote (n : nat) : Type := unit.

End EmptyWord.

Module EmptyConsts <: CONST_SEMANTICS EmptyWord.

  Definition constWordDenote n (w : StandardWord.wordDenote n) : EmptyWord.wordDenote n := tt.

End EmptyConsts.

Module EmptyOps <: OP_SEMANTICS (EmptyWord).

  Definition OpError := False.

  Definition wordOpDenote la ra n (o : op la ra) : arityDenote OpError la ra (EmptyWord.wordDenote n).
    destruct o; repeat constructor.
  Defined.

End EmptyOps.

Module EmptySemantics := CodeSemantics EmptyWord EmptyConsts EmptyOps.


From CoqMTL Require Export Control.Monad.

(** Haskell-style monad transformers. The categorical semantics is not yet
    clear to me (a monad morphism?, a natural transformation preserving the
    [Applicative]/[Monad] structure?).

    The laws are standard, taken from Haskell's standard library. *)
Class MonadTrans (T : (Type -> Type) -> Type -> Type) : Type :=
{
  is_monad : forall (M : Type -> Type), Monad M -> Monad (T M);
  lift :
    forall {M : Type -> Type} {_inst : Monad M} {A : Type},
      M A -> T M A;
  lift_pure :
    forall (M : Type -> Type) {_inst : Monad M} (A : Type) (x : A),
      lift (pure x) = pure x;
  lift_bind :
    forall
      {M : Type -> Type} {_inst : Monad M} (A B : Type)
      (x : M A) (f : A -> M B),
        lift (x >>= f) = lift x >>= (f .> lift)
}.

(** A tactic for dealing with functor instances specific to monad
    transformers. *)
Ltac mtrans := hs; try
match goal with
| |- fmap (fun x : ?A => ?e) = _ =>
      let x := fresh "x" in
      replace (fun x : A => e) with (@id A);
      [rewrite fmap_id | ext x; destruct x]; try reflexivity
| |- context [fmap ?f = fmap ?g .> fmap ?h] =>
      let x := fresh "x" in
      replace f with (g .> h);
      [rewrite fmap_comp | ext x; destruct x]; try reflexivity
| |- context [fmap ?f = fun _ => fmap ?g (fmap ?h _)] =>
      let x := fresh "x" in ext x;
      rewrite <- fmap_comp'; f_equal
end.

Lemma lift_constrA :
  forall
    (T : (Type -> Type) -> Type -> Type) (instT : MonadTrans T)
    (M : Type -> Type) (instM : Monad M)
    (A B : Type) (x : M A) (y : M B),
      @constrA (T M) (is_monad _ instM) _ _ (lift x) (lift y) =
      @lift T instT M instM B (x >> y).
Proof.
  intros.
    rewrite !constrA_spec.
    rewrite lift_bind. unfold compose. reflexivity.
Defined.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export terms2.

Lemma deq_nterm {p} :
  dec_consts p
  -> forall x y : @NTerm p,
       assert (no_seq x)
       -> {x = y} + {x <> y}.
Proof.
  introv dc.
  nterm_ind1 x as [v1 | o1 lbt1 Hind] Case; introv ns.

  - Case "vterm".
    destruct y as [v2 | o lbt2]; [  | right; intro Hc; inverts Hc].
    destruct (deq_nvar v1 v2); subst;
    [ left; auto; fail
    | right; intro Hc; inverts Hc; sp
    ].

  - Case "oterm".
    destruct y as [v2 | o2 lbt2]; [ right; intro Hc; inverts Hc | ].
    allsimpl.
    allrw assert_of_andb; repnd.
    destruct (opid_dec dc o1 o2); auto; subst; [  | right; intro Hc; inverts Hc;sp].
    assert ((lbt1=lbt2) + (lbt1 <> lbt2)) as Hbt.
    Focus 2.
    dorn Hbt; subst; [left; auto | right; intro Hc; inverts Hc;sp ]; fail.
    revert lbt2.
    induction lbt1.
    destruct lbt2; [left; auto | right; intro Hc; inverts Hc;sp ]; fail.
    destruct lbt2;  [ right; intro Hc; inverts Hc; fail | ].
    destruct a as [lv1 nt1]. destruct b as [lv2 nt2].
    lapply (IHlbt1);
      [ | introv Hin; apply Hind with (lv:=lv); eauto; right; auto].
    introv bdec.
    allsimpl.
    allrw assert_of_andb; repnd.
    autodimp bdec hyp.
    destruct (bdec lbt2); subst; [  | right; intro Hc; inverts Hc;sp;fail ].
    destruct (list_eq_dec deq_nvar lv1 lv2);
      subst; [ | right; intro Hc; inverts Hc;sp;fail ].
    destruct (Hind nt1 lv2 (injL(eq_refl _) ) nt2); auto; subst;
    [left; auto |  right; intro Hc; inverts Hc;sp ].
Defined.
Hint Immediate deq_nterm.

(*
Lemma map_removevars {p} :
  forall dc : dec_consts p,
  forall lvi lvr,
    map (@vterm p) (remove_nvars lvi lvr)
    = diff (deq_nterm dc) (map vterm lvi) (map vterm lvr).
Proof.
  intros. apply map_diff_commute.
  introv Hc. inverts Hc. auto.
Qed.
*)

(*
Lemma deq_bterm {p} : dec_consts p -> Deq (@BTerm p).
Proof.
  intros dc btx bty. destruct btx as [lvx ntx].
  destruct bty as [lvy nty].
  destruct (deq_nterm dc ntx nty);
  destruct (deq_list deq_nvar lvx lvy); subst;sp;
  right; introv Heq;
  inverts Heq; cpx.
Qed.
Hint Resolve deq_bterm.
*)


From Undecidability.PCP Require Import PCP_undec.
From Undecidability.Synthetic Require Import Undecidability ReducibilityFacts.
From Undecidability.FOL.Semantics.FiniteTarski Require Fragment Full DoubleNegation.
From Undecidability.FOL.Undecidability Require Import Reductions.FSATd_to_FSATdc Reductions.PCPb_to_FSAT.

Section Full.
  Import Full.
  Theorem FSAT_undec :
    undecidable FSAT.
  Proof.
    apply (undecidability_from_reducibility dPCPb_undec).
    exists (finsat_formula). intros x. apply FSAT_reduction.
  Qed.

  Theorem FSATd_undec :
    undecidable FSATd.
  Proof.
    apply (undecidability_from_reducibility dPCPb_undec).
    exists (finsat_formula). intros x. apply FSATd_reduction.
  Qed.

  Theorem FSATdc_undec :
    undecidable FSATdc.
  Proof.
   apply (undecidability_from_reducibility FSATd_undec).
   apply FSATd_to_FSATdc.reduction.
  Qed.
End Full.

Section Fragment.
  Import Fragment DoubleNegation.

  Theorem FSAT_undec_frag :
    undecidable FSAT.
  Proof.
    apply (undecidability_from_reducibility (FSAT_undec)).
    exists translate_form.
    intros k. split; intros (D & I & rho & (l & Hlist) & Hdec & H).
    - exists D, (full_tarski_tarski_interp I), rho; repeat split.
      + now exists l.
      + destruct I; apply Hdec.
      + rewrite <- (full_interp_inverse_1 I) in H.
        destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct in H.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        rewrite full_interp_inverse_1. intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'.
        1: now exists fP. 1: now exists fL. now exists fE.
    - exists D, (tarski_full_tarski_interp I), rho; repeat split.
      + now exists l.
      + destruct I; apply Hdec.
      + destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'; destruct I.
        1: now exists fP. 1: now exists fL. now exists fE.
  Qed.

  Theorem FSATd_undec_frag :
    undecidable FSATd.
  Proof.
    apply (undecidability_from_reducibility (FSATd_undec)).
    exists translate_form.
    intros k. split; intros (D & I & rho & (l & Hlist) & Hdisc & Hdec & H).
    - exists D, (full_tarski_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + rewrite <- (full_interp_inverse_1 I) in H.
        destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct in H.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        rewrite full_interp_inverse_1. intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'.
        1: now exists fP. 1: now exists fL. now exists fE.
    - exists D, (tarski_full_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'; destruct I.
        1: now exists fP. 1: now exists fL. now exists fE.
  Qed.

  Theorem FSATdc_undec_frag :
    undecidable FSATdc.
  Proof.
    apply (undecidability_from_reducibility FSATdc_undec).
    unshelve eexists translate_form_closed. 1-2: unfold Dec.dec; repeat decide equality.
    intros [k Hclosed]. split; intros (D & I & rho & (l & Hlist) & Hdisc & Hdec & H).
    - exists D, (full_tarski_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + rewrite <- (full_interp_inverse_1 I) in H.
        destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct in H.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        rewrite full_interp_inverse_1. intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'.
        1: now exists fP. 1: now exists fL. now exists fE.
    - exists D, (tarski_full_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'; destruct I.
        1: now exists fP. 1: now exists fL. now exists fE.
  Qed.
End Fragment.


(*! Frontend | Macros used in untyped programs !*)
Require Import Koika.Common Koika.Types Koika.Syntax Koika.TypedSyntax Koika.TypedSyntax Koika.Primitives.
Import PrimUntyped.

Section SyntaxMacros.
  Context {pos_t var_t fn_name_t reg_t ext_fn_t: Type}.

  Notation uaction := (uaction pos_t var_t fn_name_t reg_t ext_fn_t).

  Definition bits_of_ascii c : bits 8 :=
    match c with
    | Ascii.Ascii b0 b1 b2 b3 b4 b5 b6 b7 =>
      Ob~b7~b6~b5~b4~b3~b2~b1~b0
    end.

  Fixpoint array_of_bytes (s: string) : vect (bits 8) (String.length s) :=
    match s with
    | EmptyString => vect_nil
    | String c s => vect_cons (bits_of_ascii c) (array_of_bytes s)
    end.

  Fixpoint uprogn (aa: list uaction) :=
    match aa with
    | [] => UConst (tau := bits_t 0) Ob
    | [a] => a
    | a :: aa => USeq a (uprogn aa)
    end.

  Definition uskip : uaction :=
    UConst (tau := bits_t 0) Ob.

  Definition uinit (tau: type) : uaction :=
    let zeroes := UConst (tau := bits_t _) (Bits.zeroes (type_sz tau)) in
    UUnop (UConv (UUnpack tau)) zeroes.

  Definition ustruct_init (sig: struct_sig) (fields: list (string * uaction)) : uaction :=
    let empty := SyntaxMacros.uinit (struct_t sig) in
    let usubst f := UBinop (UStruct2 (USubstField f)) in
    List.fold_left (fun acc '(f, a) => (usubst f) acc a) fields empty.

  Fixpoint uswitch (var: uaction) (default: uaction)
           (branches: list (uaction * uaction)) : uaction :=
    match branches with
    | nil => default
    | (label, action) :: branches =>
      UIf (UBinop (UEq false) var label) action (uswitch var default branches)
    end.

  Fixpoint uswitch_nodefault (var: uaction)
           {nb} (branches: vect (uaction * uaction) (S nb)) : uaction :=
    let '(label, action) := vect_hd branches in
    match nb return vect _ (S nb) -> uaction with
    | 0 => fun _ => action
    | S nb => fun branches =>
               UIf (UBinop (UEq false) var label) action
                   (uswitch_nodefault var (vect_tl branches))
    end branches.

  Definition gen_branches label_sz bound (branch_bodies: index bound -> uaction)
    : vect (uaction * uaction) bound :=
    let label_of_index idx := UConst (tau := bits_t _) (Bits.of_index label_sz idx) in
    vect_map (fun idx => (label_of_index idx, branch_bodies idx))
             (all_indices bound).

  Fixpoint uswitch_stateful (var: uaction)
           {nb} (branches: vect (uaction * uaction) nb) : uaction :=
    match nb return vect _ nb -> uaction with
    | 0 => fun _ => uskip
    | S nb => fun branches =>
               let '(label, action) := vect_hd branches in
               USeq (UIf (UBinop (UEq false) var label)
                         action uskip)
                    (uswitch_stateful var (vect_tl branches))
    end branches.

  Fixpoint muxtree var_logsz bit_idx (var: var_t) {sz} (bodies: bits sz -> uaction) :=
    match sz return (bits sz -> uaction) -> uaction with
    | 0 =>
      fun bodies =>
        bodies Ob
    | S n =>
      fun bodies =>
      (* FIXME add a version of sel taking a compile-time constant? *)
      let bidx := UConst (tau := bits_t var_logsz) (Bits.of_nat var_logsz bit_idx) in
      UIf (UBinop (UBits2 USel) (UVar var) bidx)
          (muxtree var_logsz (S bit_idx) var (fun bs => bodies bs~1))
          (muxtree var_logsz (S bit_idx) var (fun bs => bodies bs~0))
    end bodies.

  Definition UCompleteMuxTree sz
             (var: var_t) (branch_bodies: bits sz -> uaction) :=
    muxtree (log2 sz) 0 var branch_bodies.

  Fixpoint ortree {sz} (bodies: bits sz -> uaction) :=
    match sz return (bits sz -> uaction) -> uaction with
    | 0 =>
      fun bodies =>
        bodies Ob
    | S n =>
      fun bodies =>
      (UBinop (UBits2 UOr)
              (ortree (fun bs => bodies bs~1))
              (ortree (fun bs => bodies bs~0)))
    end bodies.

  Definition UCompleteOrTree sz nbits
             (var: var_t) (branch_bodies: bits sz -> uaction) :=
    ortree
      (fun bs => UIf (UBinop (UEq false) (UConst (tau := bits_t sz) bs) (UVar var))
                  (branch_bodies bs)
                  (UConst (tau := bits_t nbits) Bits.zero)).

  Inductive switch_style :=
  | TreeSwitch
  | OrTreeSwitch (nbits: nat)
  | NestedSwitch
  | SequentialSwitchTt
  | SequentialSwitch (tau: type) (output_var: var_t).

  Definition UCompleteSwitch (style: switch_style) sz
             (var: var_t) (branch_bodies: index (pow2 sz) -> uaction) :=
    let branches bodies :=
        gen_branches sz (pow2 sz) bodies in
    match style with
    | TreeSwitch =>
      UCompleteMuxTree sz var (fun bs => branch_bodies (Bits.to_index_safe bs))
    | OrTreeSwitch nbits =>
      UCompleteOrTree sz nbits var (fun bs => branch_bodies (Bits.to_index_safe bs))
    | NestedSwitch =>
      uswitch_nodefault (UVar var) (branches branch_bodies)
    | SequentialSwitchTt =>
      uswitch_stateful (UVar var) (branches branch_bodies)
    | SequentialSwitch output_type output_var =>
      let branch_bodies idx := UAssign output_var (branch_bodies idx) in
      UBind output_var
            (uinit output_type)
            (USeq (uswitch_stateful (UVar var) (branches branch_bodies))
                  (UVar output_var))
    end.
End SyntaxMacros.

Module Display.
  Section Display.
    Notation var_t := string (only parsing).
    Notation fn_name_t := string (only parsing).
    Context {pos_t reg_t ext_fn_t: Type}.

    Notation uaction := (uaction pos_t var_t fn_name_t reg_t ext_fn_t).

    Inductive field : Type :=
    | Str (s: string)
    | Value (tau: type).

    Notation intfun := (InternalFunction var_t fn_name_t uaction).

    Definition empty_printer : InternalFunction var_t fn_name_t uaction :=
      {| int_name := "print";
         int_argspec := [];
         int_retSig := unit_t;
         int_body := USugar USkip |}.

    Definition display_utf8 s : uaction :=
      UUnop (UDisplay (UDisplayUtf8)) (USugar (UConstString s)).

    Definition nl_printer : InternalFunction var_t fn_name_t uaction :=
      {| int_name := "print_nl";
         int_argspec := [];
         int_retSig := unit_t;
         int_body := display_utf8 "\n" |}.

    Definition extend_printer f (offset: nat) (printer: intfun) : intfun :=
      let opts :=
          {| display_newline := false; display_strings := false; display_style := dFull |} in
      let display_value arg :=
          UUnop (UDisplay (UDisplayValue opts)) (UVar arg) in
      let '(Build_InternalFunction int_name int_argspec int_retSig int_body) :=
          printer in
      match f with
      | Str s =>
        {| int_name := int_name;
           int_argspec := int_argspec;
           int_retSig := int_retSig;
           int_body := (USeq (display_utf8 s) int_body) |}
      | Value tau =>
        let arg := String.append "arg" (show offset) in
        {| int_name := int_name;
           int_argspec := (arg, tau) :: int_argspec;
           int_retSig := unit_t;
           int_body := (USeq (display_value arg) int_body) |}
      end.

    Fixpoint make_printer (offset: nat) (fstring: list field) : intfun :=
      match fstring with
      | [] => empty_printer
      | f :: fstring => extend_printer f offset (make_printer (S offset) fstring)
      end.

    Definition Printer (fstring: list field) :=
      make_printer 0 fstring.

    Example example :=
      Eval compute in Printer [Str "x: "; Value (bits_t 16); Str "y: "; Value (bits_t 32)].
  End Display.
End Display.

Require Import Koika.LoweredSyntax.

Section LoweredSyntaxMacros.
  Context {pos_t var_t fn_name_t reg_t ext_fn_t: Type}.
  Context {CR: reg_t -> nat}
          {CSigma: ext_fn_t -> CExternalSignature}.

  Notation action := (action pos_t var_t CR CSigma).

  Fixpoint infix_action (infix: lsig) {sig sig': lsig} {tau} (a: action (sig ++ sig') tau)
    : action (sig ++ infix ++ sig') tau.
  Proof.
    remember (sig ++ sig'); destruct a; subst.
    - exact (Fail sz).
    - exact (Var k (minfix infix m)).
    - exact (Const cst).
    - exact (Assign k (minfix infix m) (infix_action infix _ _ _ a)).
    - exact (Seq (infix_action infix _ _ _ a1) (infix_action infix _ _ _ a2)).
    - exact (Bind k (infix_action infix _ _ _ a1) (infix_action infix (_ :: sig) sig' _ a2)).
    - exact (If (infix_action infix _ _ _ a1) (infix_action infix _ _ _ a2) (infix_action infix _ _ _ a3)).
    - exact (Read port idx).
    - exact (Write port idx (infix_action infix _ _ _ a)).
    - exact (Unop fn (infix_action infix _ _ _ a)).
    - exact (Binop fn (infix_action infix _ _ _ a1) (infix_action infix _ _ _ a2)).
    - exact (ExternalCall fn (infix_action infix _ _ _ a)).
    - exact (infix_action infix _ _ _ a).
  Defined.

  Definition prefix_action (prefix: lsig) {sig: lsig} {sz} (a: action sig sz)
    : action (prefix ++ sig) sz :=
    infix_action prefix (sig := []) a.

  Definition suffix_action (suffix: lsig) {sig: lsig} {sz} (a: action sig sz)
    : action (sig ++ suffix) sz.
  Proof. rewrite <- (capp_nil_r suffix); apply infix_action; rewrite (capp_nil_r sig); exact a. Defined.

  Definition lsig_of_tsig (sig: tsig var_t) : lsig :=
    List.map (fun k_tau => type_sz (snd k_tau)) sig.

  Fixpoint InternalCall'
           {sz: nat}
           {sig: lsig}
           {fn_sig: lsig}
           (args: context (fun sz => var_t * action sig sz)%type fn_sig)
           (fn_body: action (fn_sig ++ sig) sz)
    : action sig sz :=
    match args in context _ fn_sig
          return action (fn_sig ++ sig) sz ->
                 action sig sz with
    | CtxEmpty =>
      fun fn_body => fn_body
    | CtxCons sz (k, v) tl =>
      fun fn_body =>
        let fn_body := Bind k (prefix_action _ v) fn_body in
        InternalCall' tl fn_body
    end fn_body.

  Definition InternalCall
             {sz: nat}
             {sig: lsig}
             {fn_sig: lsig}
             (args: context (fun sz => var_t * action sig sz)%type fn_sig)
             (fn_body: action fn_sig sz)
    : action sig sz :=
    InternalCall' args (suffix_action sig fn_body).
End LoweredSyntaxMacros.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Bags Platform.Malloc Platform.ThreadQueue Platform.Misc.
Import W_Bag.

Set Implicit Arguments.

Module Type S.
  Variable world : Type.

  Variable evolve : world -> world -> Prop.
  Axiom evolve_refl : forall w, evolve w w.
  Axiom evolve_trans : forall w1 w2 w3, evolve w1 w2 -> evolve w2 w3 -> evolve w1 w3.

  Variable globalInv : bag -> world -> HProp.
End S.

Module Make(M : S).
Import M.

Module M'.
  Open Scope Sep_scope.

  Definition world := (bag * M.world)%type.
  Definition evolve (w1 w2 : world) :=
    fst w1 %<= fst w2
    /\ M.evolve (snd w1) (snd w2).

  Local Hint Resolve M.evolve_refl M.evolve_trans.

  Theorem evolve_refl : forall w, evolve w w.
    unfold evolve; auto.
  Qed.

  Theorem evolve_trans : forall w1 w2 w3, evolve w1 w2 -> evolve w2 w3 -> evolve w1 w3.
    unfold evolve; intuition eauto.
  Qed.

  Definition globalInv (w : world) (p : W) : hpropB (tq_args world :: nil) :=
    starB (fun p' stn sm => Var0 {| World := w; Pointer := p'; Settings := stn; Mem := sm |}) (fst w %- p) * ^[M.globalInv (fst w) (snd w)].
End M'.

Module Q := ThreadQueue.Make(M').
Import M' Q.

Module Type TQS.
  Parameter tqs' : world -> bag -> HProp.

  Axiom tqs'_eq : tqs' = fun w => starB (tq w).

  Parameter tqs : bag -> M.world -> HProp.

  Axiom tqs_eq : tqs = fun b w => tqs' (b, w) b.

  Definition tqs'_pick_this_one (_ : W) := tqs'.

  Axiom tqs'_empty_bwd : forall w, Emp ===> tqs' w empty.
  Axiom tqs'_add_bwd : forall w ts t, tqs' w ts * tq w t ===> tqs' w (ts %+ t).
  Axiom tqs'_del_fwd : forall w ts t, t %in ts -> tqs'_pick_this_one t w ts ===> tq w t * tqs' w (ts %- t).
  Axiom tqs'_del_bwd : forall w ts t, t %in ts -> tqs' w (ts %- t) * tq w t ===> tqs' w ts.

  Axiom tqs'_weaken : forall w w' b, evolve w w' -> tqs' w b ===>* tqs' w' b.
End TQS.

Module Tqs : TQS.
  Open Scope Sep_scope.

  Definition tqs' w := starB (tq w).

  Theorem tqs'_eq : tqs' = fun w => starB (tq w).
    auto.
  Qed.

  Definition tqs b w := tqs' (b, w) b.

  Theorem tqs_eq : tqs = fun b w => tqs' (b, w) b.
    auto.
  Qed.

  Definition tqs'_pick_this_one (_ : W) := tqs'.

  Theorem tqs'_empty_bwd : forall w, Emp ===> tqs' w empty.
    intros; apply starB_empty_bwd.
  Qed.

  Theorem tqs'_add_bwd : forall w ts t, tqs' w ts * tq w t ===> tqs' w (ts %+ t).
    intros; apply (starB_add_bwd (tq w)).
  Qed.

  Theorem tqs'_del_fwd : forall w ts t, t %in ts -> tqs'_pick_this_one t w ts ===> tq w t * tqs' w (ts %- t).
    intros; apply (starB_del_fwd (tq w)); auto.
  Qed.

  Theorem tqs'_del_bwd : forall w ts t, t %in ts -> tqs' w (ts %- t) * tq w t ===> tqs' w ts.
    intros; eapply Himp_trans; [ | apply (starB_del_bwd (tq w)); eauto ].
    eapply Himp_trans; [ apply Himp_star_comm | ].
    apply Himp_refl.
  Qed.

  Theorem tqs'_weaken : forall w w' b, evolve w w' -> tqs' w b ===>* tqs' w' b.
    intros; apply starB_weaken_weak; intros.
    apply tq_weaken; unfold evolve in *; simpl in *; intuition.
  Qed.
End Tqs.

Import Tqs.
Export Tqs.

Theorem tqs_empty_bwd : forall w, Emp ===> tqs empty w.
  intros; rewrite tqs_eq; apply tqs'_empty_bwd.
Qed.

Definition exitize_me a b c d := locals a b c d.

Lemma exitize_locals : forall xx yy ns vs res sp,
  exitize_me ("rp" :: xx :: yy :: ns) vs res sp ===> Ex vs', locals ("rp" :: "sc" :: "ss" :: nil) (upd vs' "ss" (sel vs yy)) (res + length ns) sp.
  unfold exitize_me, locals; intros.
  simpl; unfold upd; simpl.
  apply Himp_ex_c; exists (fun x => if string_dec x "rp" then vs "rp" else vs xx).
  eapply Himp_trans.
  eapply Himp_star_frame.
  eapply Himp_star_frame.
  apply Himp_refl.
  change (vs "rp" :: vs xx :: vs yy :: toArray ns vs)
    with (toArray (("rp" :: xx :: yy :: nil) ++ ns) vs).
  apply ptsto32m_split.
  apply Himp_refl.
  destruct (string_dec "rp" "rp"); intuition.
  destruct (string_dec "sc" "rp"); intuition.
  unfold array, toArray in *.
  simpl map in *.
  simpl length in *.

  Lemma switchedy : forall P Q R S : HProp,
    (P * (Q * R)) * S ===> P * (Q * (R * S)).
    sepLemma.
  Qed.

  eapply Himp_trans; [ apply switchedy | ].

  Lemma swatchedy : forall P Q R : HProp,
    P * (Q * R) ===> P * Q * R.
    sepLemma.
  Qed.

  eapply Himp_trans; [ | apply swatchedy ].
  apply Himp_star_frame.
  sepLemma; NoDup.
  apply Himp_star_frame.
  apply Himp_refl.
  eapply Himp_trans; [ | apply allocated_join ].
  apply Himp_star_frame.
  eapply Himp_trans; [ | apply allocated_shift_base ].
  apply ptsto32m_allocated.
  simpl.
  words.
  eauto.
  apply allocated_shift_base.
  rewrite map_length.
  repeat rewrite <- wplus_assoc.
  repeat rewrite <- natToW_plus.
  f_equal.
  f_equal.
  omega.
  rewrite map_length; omega.
  rewrite map_length; omega.
Qed.

Definition hints : TacPackage.
  prepare (tqs'_del_fwd, create_stack, exitize_locals) (tqs'_empty_bwd, tqs'_add_bwd).
Defined.

Definition starting (ts : bag) (w : M.world) (pc : W) (ss : nat) : HProp := fun s m =>
  (ExX (* pre *) : settings * state, Cptr pc #0
    /\ [| semp m |]
    /\ Al st : state, Al vs, Al ts', Al w',
      [| ts %<= ts' |]
      /\ [| M.evolve w w' |]
      /\ [| Regs st Sp <> 0 /\ freeable (Regs st Sp) (1 + ss) |]
      /\ ![ ^[locals ("rp" :: nil) vs ss (Regs st Sp) * tqs ts' w' * M.globalInv ts' w' * mallocHeap 0] ] (s, st)
      ---> #0 (s, st))%PropX.

Lemma starting_elim : forall specs ts w pc ss P stn st,
  interp specs (![ starting ts w pc ss * P ] (stn, st))
  -> (exists pre, specs pc = Some (fun x => pre x)
    /\ interp specs (![ P ] (stn, st))
    /\ forall st' vs ts' w', interp specs ([| ts %<= ts' |]
      /\ [| M.evolve w w' |]
      /\ [| Regs st' Sp <> 0 /\ freeable (Regs st' Sp) (1 + ss) |]
      /\ ![ locals ("rp" :: nil) vs ss (Regs st' Sp)
      * tqs ts' w' * M.globalInv ts' w' * mallocHeap 0 ] (stn, st')
    ---> pre (stn, st'))%PropX).
  cptr.
  generalize (split_semp _ _ _ H0 H); intros; subst; auto.
  rewrite <- sepFormula_eq; descend; step auto_ext.
  eauto.
  eauto.
  eauto.
  step auto_ext.
Qed.

Definition allocS : spec := SPEC reserving 14
  Al ts, Al w,
  PRE[_] tqs ts w * mallocHeap 0
  POST[R] tqs (ts %+ R) w * mallocHeap 0.

Definition isEmptyS : spec := SPEC("sc") reserving 4
  Al ts, Al w,
  PRE[V] [| V "sc" %in ts |] * tqs ts w * mallocHeap 0
  POST[_] tqs ts w * mallocHeap 0.

Definition spawnS : spec := SPEC("sc", "pc", "ss") reserving 18
  Al ts, Al w, Al w',
  PRE[V] [| V "sc" %in ts |] * [| V "ss" >= $2 |] * [| M.evolve w w' |]
    * tqs ts w * starting ts w' (V "pc") (wordToNat (V "ss") - 1) * mallocHeap 0
  POST[_] tqs ts w' * mallocHeap 0.

Definition exitS : spec := SPEC("sc", "ss") reserving 0
  Al ts, Al w, Al w',
  PREexit[V] [| V "ss" >= $3 |] * [| V "sc" %in ts |] * [| M.evolve w w' |]
    * tqs ts w * M.globalInv ts w' * mallocHeap 0.

Definition yieldS : spec := SPEC("enq", "deq") reserving 22
  Al ts, Al w, Al w',
  PRE[V] [| V "enq" %in ts |] * [| V "deq" %in ts |] * [| M.evolve w w' |]
    * tqs ts w * M.globalInv ts w' * mallocHeap 0
  POST[_] Ex ts', Ex w'', [| ts %<= ts' |] * [| M.evolve w' w'' |]
    * tqs ts' w'' * M.globalInv ts' w'' * mallocHeap 0.

Notation "'balias' name () [ p ] l 'end'" :=
  (let p' := p in
   let vars := nil in
    {| FName := name;
      FPrecondition := Precondition p' None;
      FBody := Goto l%SP;
      FVars := vars;
      FReserved := Reserved p' |})
  (no associativity, at level 95, name at level 0, p at level 0, only parsing) : SPfuncs_scope.

Local Notation "'PREy' [ vs ] pre" := (yieldInvariantCont (fun vs _ => pre%qspec%Sep))
  (at level 89).

Definition stackSize := 25.

Lemma stackSize_bound : natToW stackSize >= natToW 2.
  unfold stackSize; auto.
Qed.

Hint Immediate stackSize_bound.

Lemma stackSize_split : stackSize = length ("rp" :: "enq" :: "deq" :: "sp" :: nil) + 21.
  reflexivity.
Qed.

Opaque stackSize.

Definition localsInvariantYieldy (pre : vals -> W -> qspec) (rpStashed : bool) (adjustSp : W -> W)
  (ns : list string) (res : nat) : assert :=
  st ~> let sp := adjustSp st#Sp in
    [| sp <> 0 |] /\ [| freeable sp stackSize |]
    /\ Ex vs, qspecOut (pre (sel vs) st#Rv) (fun pre =>
        ![ locals ("rp" :: ns) vs res sp * pre ] st).

Local Notation "'PREyy' [ vs ] pre" := (localsInvariantYieldy (fun vs _ => pre%qspec%Sep))
  (at level 89).

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS],
                           "threadq"!"init" @ [Q.initS], "threadq"!"isEmpty" @ [Q.isEmptyS],
                           "threadq"!"spawn" @ [Q.spawnS], "threadq"!"spawnWithStack" @ [Q.spawnWithStackS],
                           "threadq"!"exit" @ [Q.exitS], "threadq"!"yield" @ [Q.yieldS] ]]
  bmodule "threadqs" {{
    bfunction "alloc"("r") [allocS]
      "r" <-- Call "threadq"!"init"()
      [Al ts, Al w,
        PRE[_, R] tq (ts, w) R * tqs ts w
        POST[R'] tqs (ts %+ R') w ];;
      Return "r"
    end with balias "isEmpty"() [isEmptyS]
      "threadq"!"isEmpty"
    end with balias "spawn"() [spawnS]
      "threadq"!"spawn"
    end with balias "exit"() [exitS]
      "threadq"!"exit"
    end with bfunction "yield"("enq", "deq", "sp") [yieldS]
      If ("enq" = "deq") {
        Call "threadq"!"yield"("enq")
        [PRE[_] Emp
         POST[_] Emp];;
        Return 0
      } else {
        "sp" <-- Call "malloc"!"malloc"(0, stackSize)
        [Al ts, Al w,
          PRE[V, R] [| V "enq" %in ts |] * [| V "deq" %in ts |] * [| V "enq" <> V "deq" |]
            * tqs ts w * M.globalInv ts w * mallocHeap 0
            * R =?> stackSize * [| R <> 0 |] * [| freeable R stackSize |]
          POST[_] Ex ts', Ex w', [| ts %<= ts' |] * [| M.evolve w w' |]
            * tqs ts' w' * M.globalInv ts' w' * mallocHeap 0];;

        Assert [Al ts, Al w,
          PRE[V] [| V "enq" %in ts |] * [| V "deq" %in ts |] * [| V "enq" <> V "deq" |]
            * tqs ts w * M.globalInv ts w * mallocHeap 0
            * Ex vs, locals ("rp" :: "enq" :: "deq" :: "sp" :: nil) vs 21 (V "sp")
            * [| V "sp" <> 0 |] * [| freeable (V "sp") stackSize |]
          POST[_] Ex ts', Ex w', [| ts %<= ts' |] * [| M.evolve w w' |]
            * tqs ts' w' * M.globalInv ts' w' * mallocHeap 0];;

        "sp"+0 *<- $[Sp+0];;
        "sp"+4 *<- "enq";;
        "sp"+8 *<- "deq";;
        "sp"+12 *<- Sp;;
        Sp <- "sp";;
        Call "threadq"!"spawnWithStack"("enq", $[Sp+0], "sp")
        [Al ts, Al w,
          PREyy[V] [| V "deq" %in ts |]
            * tqs ts w * M.globalInv ts w * mallocHeap 0];;

        "enq" <- "deq";;
        "deq" <- 25;;
        Goto "threadq"!"exit"
      }
   end
  }}.

Local Hint Extern 1 (@eq W _ _) => words.

Ltac t := abstract (sep hints; auto).

Local Hint Immediate M.evolve_refl.

Lemma eq_neq_0 : forall u v : W,
  u <> 0
  -> v = 0
  -> u = v
  -> False.
  congruence.
Qed.

Lemma freeable_cong : forall (u v : W) n,
  freeable v n
  -> v = u
  -> freeable u n.
  congruence.
Qed.

Ltac words_rewr := repeat match goal with
                            | [ H : _ = ?X |- _ ] =>
                              match X with
                                | natToW 0 => fail 1
                                | _ => rewrite H
                              end
                          end; words.

Hint Extern 1 (freeable _ _) => eapply freeable_cong; [ eassumption | words_rewr ].

Theorem ok : moduleOk m.
  vcgen.

  t.
  t.
  t.
  t.
  t.
  t.
  t.

  post; evaluate hints.
  rewrite tqs_eq in *.
  toFront ltac:(fun P => match P with
                           | tqs' _ _ => idtac
                         end) H6.
  eapply use_HimpWeak in H6; [ | apply (tqs'_weaken (w' := (x1 %+ Regs x0 Rv, x2))); (red; intuition) ].
  toFront ltac:(fun P => match P with
                           | tq _ _ => idtac
                         end) H6.
  eapply use_HimpWeak in H6; [ | apply (tq_weaken (w' := (x1 %+ Regs x0 Rv, x2))); (red; simpl; intuition) ].
  descend.
  step hints.
  step hints.
  descend; step hints.
  rewrite H5; step hints.
  simpl; auto.

  t.

  post; evaluate hints.
  rewrite tqs_eq in *.
  toFront ltac:(fun P => match P with
                           | tqs' _ _ => idtac
                         end) H4.
  change (tqs' (x, x0) x) with (tqs'_pick_this_one (sel x2 "sc") (x, x0) x) in H4.
  Hint Extern 1 (_ %in _) => eapply incl_mem; eassumption.
  Local Hint Extern 1 (himp _ _ _) => apply tqs'_del_bwd.
  t.

  t.

  post; evaluate hints.
  rewrite tqs_eq in *.
  toFront ltac:(fun P => match P with
                           | tqs' _ _ => idtac
                         end) H4.
  eapply use_HimpWeak in H4; [ | apply (tqs'_weaken (w' := (x, x1))); (red; intuition) ].
  change (tqs' (x, x1) x) with (tqs'_pick_this_one (sel x3 "sc") (x, x1) x) in H4.
  toFront ltac:(fun P => match P with
                           | starting _ _ _ _ => idtac
                         end) H4; apply starting_elim in H4; post.
  evaluate hints.
  descend.
  toFront_conc ltac:(fun P => match P with
                                | Q.starting _ _ _ _ => idtac
                              end); apply Q.starting_intro; descend.
  2: step hints.
  step hints.
  step hints.
  step hints.
  destruct w'; simpl in *.
  destruct H; simpl in *.
  eapply Imply_trans; [ | eapply (H4 _ _ b0 w) ]; clear H4.
  repeat (apply andR; [ apply injR; assumption | ]).
  repeat (apply andR; [ apply injR; auto | ]).

  Lemma switchy : forall P Q R S T R',
    R ===> R'
    -> P * Q * (R * S) * T ===> P * Q * R' * S * T.
    sepLemma.
  Qed.

  make_Himp.
  unfold ginv, globalInv.
  autorewrite with sepFormula; simpl.
  eapply Himp_trans; [ eapply switchy; apply starB_substH_fwd | ].
  unfold substH; simpl.
  match goal with
    | [ |- (_ * _ * ?P * _ * _ ===> _)%Sep ] =>
      replace P with (tqs' (b0, w) (b0 %- sel x3 "sc")) by (rewrite tqs'_eq; reflexivity)
  end.
  rewrite tqs_eq.

  hnf; intros; step hints.
  step hints.
  t.

  t.

  post; evaluate hints.
  rewrite tqs_eq in *.
  toFront ltac:(fun P => match P with
                           | tqs' _ _ => idtac
                         end) H4.
  eapply use_HimpWeak in H4; [ | apply (tqs'_weaken (w' := (x, x1))); (red; intuition) ].
  change (tqs' (x, x1) x) with (tqs'_pick_this_one (sel x2 "sc") (x, x1) x) in H4.
  evaluate hints.
  descend.
  eauto.
  step hints.
  unfold ginv, globalInv.
  autorewrite with sepFormula; simpl.
  make_Himp.

  eapply Himp_trans; [ | apply Himp_star_comm ].
  apply Himp_star_frame; try apply Himp_refl.
  eapply Himp_trans; [ | apply starB_substH_bwd ].
  unfold substH; simpl.
  match goal with
    | [ |- (?P ===> ?Q)%Sep ] =>
      replace P with Q; try apply Himp_refl
  end.
  rewrite tqs'_eq; reflexivity.

  t.
  t.
  t.
  t.
  t.

  post; evaluate hints.
  rewrite tqs_eq in *.
  toFront ltac:(fun P => match P with
                           | tqs' _ _ => idtac
                         end) H8.
  eapply use_HimpWeak in H8; [ | apply (tqs'_weaken (w' := (x0, x2))); (red; intuition) ].
  change (tqs' (x0, x2) x0) with (tqs'_pick_this_one (sel x4 "enq") (x0, x2) x0) in H8.
  evaluate hints.
  descend.
  step hints.
  unfold ginv, globalInv.
  autorewrite with sepFormula; simpl.
  make_Himp.

  Lemma swatchy : forall P Q Q' R S,
    Q' ===> Q
    -> P * (Q' * R * S) ===> P * (Q * R * S).
    sepLemma.
  Qed.

  eapply Himp_trans; [ | apply swatchy; apply starB_substH_bwd ].
  unfold substH; simpl.
  match goal with
    | [ |- (_ ===> _ * (?P * _ * _))%Sep ] =>
      replace P with (tqs' (x0, x2) (x0 %- sel x4 "enq"))
        by (rewrite tqs'_eq; instantiate (1 := (x0, x2)); reflexivity)
  end.
  sepLemma.
  step hints.
  descend; step hints.
  descend; step hints.
  step hints.
  descend; step hints.
  descend; step hints.
  descend; step hints.
  words.
  unfold ginv, globalInv.
  autorewrite with sepFormula; simpl.
  instantiate (1 := snd x9).
  instantiate (1 := fst x9).
  make_Himp.

  Lemma swotchy : forall P Q R S T U S',
    S ===> S'
    -> P * star Q (star R (star (S * T) U)) ===> P * Q * R * S' * T * U.
    sepLemma.
  Qed.

  eapply Himp_trans; [ apply swotchy; apply starB_substH_fwd | ].
  unfold substH; simpl.
  match goal with
    | [ |- (_ * _ * _ * ?P * _ * _ ===> _)%Sep ] =>
      replace P with (tqs' (fst x9, snd x9) (fst x9 %- sel x4 "enq"))
  end.
  sepLemma.
  destruct x9; destruct H19; simpl in *; auto.
  destruct x9; destruct H19; simpl in *; auto.
  destruct x9; destruct H19; simpl in *; auto.
  make_Himp.
  rewrite tqs'_eq.
  apply starB_del_bwd.
  auto.
  rewrite tqs'_eq.
  destruct x9; reflexivity.

  t.
  t.
  t.
  t.

  (* Now the hard part of yield(), with two different queues. *)
  post; evaluate hints.
  rewrite tqs_eq in *.
  toFront ltac:(fun P => match P with
                           | tqs' _ _ => idtac
                         end) H8.
  eapply use_HimpWeak in H8; [ | apply (tqs'_weaken (w' := (x0, x2))); (red; intuition) ].
  t.

  t.

  post; evaluate hints.
  rewrite stackSize_split in *.
  assert (NoDup ("rp" :: "enq" :: "deq" :: "sp" :: nil)) by NoDup.
  evaluate hints.
  t.

  propxFo.
  autorewrite with sepFormula in *; unfold substH in *; simpl in *.
  generalize dependent H0; evaluate hints; intro.
  change (locals ("rp" :: "enq" :: "deq" :: "sp" :: nil) x4 21 (sel x2 "sp"))
    with (locals_call ("rp" :: "enq" :: "deq" :: "sp" :: nil) x4 21 (sel x2 "sp")
      ("rp" :: "sc" :: "pc" :: "sp" :: nil) 0 16) in H4.
  assert (ok_call ("rp" :: "enq" :: "deq" :: "sp" :: nil) ("rp" :: "sc" :: "pc" :: "sp" :: nil) 21 0 16)%nat
    by (split; [ simpl; omega
      | split; [ simpl; omega
        | split; [ NoDup
          | reflexivity ] ] ]).
  evaluate hints.

  propxFo.
  autorewrite with sepFormula in *; unfold substH in *; simpl in *.
  generalize dependent H2; evaluate hints; intro.
  change (locals ("rp" :: "enq" :: "deq" :: "sp" :: nil) x5 21 (sel x3 "sp"))
    with (locals_call ("rp" :: "enq" :: "deq" :: "sp" :: nil) x5 21 (sel x3 "sp")
      ("rp" :: "sc" :: "pc" :: "sp" :: nil) 14 16) in H5.
  assert (ok_call ("rp" :: "enq" :: "deq" :: "sp" :: nil) ("rp" :: "sc" :: "pc" :: "sp" :: nil) 21 14 16)%nat
    by (split; [ simpl; omega
      | split; [ simpl; omega
        | split; [ NoDup
          | reflexivity ] ] ]).
  rewrite tqs_eq in *.
  change (tqs' (x0, x1) x0) with (tqs'_pick_this_one (sel x3 "enq") (x0, x1) x0) in H5.
  evaluate hints.
  descend.
  toFront_conc ltac:(fun P => match P with
                                | susp' _ _ _ _ => idtac
                              end); apply susp'_intro.
  descend.
  2: step hints.
  step hints.
  step hints.
  instantiate (2 := (locals ("rp" :: "enq" :: "deq" :: "sp" :: nil) x3 21 (Regs x Sp)
    * (fun x y => x2 (x, y)))%Sep).
  step hints.
  descend; step hints.
  descend; step hints.
  descend; step hints.
  instantiate (1 := snd w').
  instantiate (1 := fst w').
  destruct w'; destruct H13; simpl in *.
  descend; step hints.
  etransitivity; [ | apply himp_star_frame; [ reflexivity | apply tqs'_del_bwd ] ].
  step hints.
  unfold ginv, globalInv.
  autorewrite with sepFormula; simpl.
  make_Himp.
  eapply Himp_trans; [ apply Himp_star_frame; [ apply starB_substH_fwd | apply Himp_refl ] | ].
  unfold substH; simpl.
  match goal with
    | [ |- (star ?P _ ===> _)%Sep ] =>
      replace P with (tqs' (b, w) (b %- sel x3 "enq")) by (rewrite tqs'_eq; reflexivity)
  end.
  sepLemma.
  auto.
  step hints.
  unfold localsInvariantYieldy; descend; step hints.

  descend; step hints.
  intros.
  eapply eq_neq_0; try eassumption.
  words_rewr.
  auto.
  descend; step hints.

  t.
  t.

  post.
  match goal with
    | [ H : context[locals ?a ?b ?c ?d] |- _ ] => change (locals a b c d)
      with (exitize_me a b c d) in H
  end.
  rewrite tqs_eq in H3.
  change (tqs' (x1, x2) x1) with (tqs'_pick_this_one (sel x3 "deq") (x1, x2) x1) in H3.
  evaluate hints.
  descend.
  3: instantiate (1 := upd (upd (upd x4 "ss" (sel x3 "deq")) "sc" (sel x3 "deq")) "ss" 25).
  eapply eq_neq_0; try eassumption; words_rewr.
  descend.
  auto.
  descend; step hints.
  unfold ginv, globalInv.
  autorewrite with sepFormula; simpl.
  make_Himp.
  eapply Himp_trans; [ | apply Himp_star_frame; [ apply starB_substH_bwd | apply Himp_refl ] ].
  unfold substH; simpl.
  match goal with
    | [ |- (_ ===> star ?P _)%Sep ] =>
      replace P with (tqs' (x1, x2) (x1 %- sel x3 "deq")) by (rewrite tqs'_eq; reflexivity)
  end.
  sepLemma.
Qed.

Transparent stackSize.

End Make.


(* -*- coq-prog-args: ("-nois" "-R" "../theories" "Coq") -*- *)
(* File reduced by coq-bug-finder from original input, then from 2236 lines to 1877 lines, then from 1652 lines to 160 lines, then from 102 lines to 34 lines *)
(* coqc version trunk (December 2014) compiled on Dec 23 2014 22:6:43 with OCaml 4.01.0
   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (90ed6636dea41486ddf2cc0daead83f9f0788163) *)
Generalizable All Variables.
Require Import Coq.Init.Notations.
Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Axiom admit : forall {T}, T.
Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity).
Notation "g 'o' f" := ltac:(let g' := g in let f' := f in exact (fun x => g' (f' x))) (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *)
Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope.
Arguments eq_refl {_ _}.
Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end.
Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }.
Arguments eisretr {A B} f {_} _.
Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'").
Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (g o f) | 1000 := admit.
Definition isequiv_homotopic {A B} (f : A -> B) (g : A -> B) `{IsEquiv A B f} (h : forall x, f x = g x) : IsEquiv g := admit.
Global Instance isequiv_inverse {A B} (f : A -> B) {feq : IsEquiv f} : IsEquiv f^-1 | 10000 := admit.
Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C} `{IsEquiv A B f} `{IsEquiv A C (g o f)} : IsEquiv g.
Proof.
  pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H
                                    (fun b => ap g (eisretr f b))) as k.
  revert k.
  let x := match goal with |- let k := ?x in _ => constr:(x) end in
  intro k; clear k;
  pose (x _).
  pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _
                           (fun b => ap g (eisretr f b))).
  Undo.
  apply (@isequiv_homotopic _ _ ((g o f) o f^-1) g _
                           (fun b => ap g (eisretr f b))).
Qed.


Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Omega.

Require Import v1.NeutronTactics.
Require Import v1.Multi.
Require Import epics.Types.
Require Import epics.Records.
Require Import epics.Step.
Require Import epics.Opcodes.

(* List lemmas - misc *)

(* TODO: move - copied from Interpret.v *)
Lemma in_map_index_list : forall n A x (f : index n -> A),
    In x (map f (index_list n)) ->
    exists i, x = f i.
intros0 Hin.
rewrite in_map_iff in Hin. break_exists. break_and.
eauto.
Qed.

(* List lemmas - forall*)

Lemma forall_app_1 : forall A P (xs ys : list A),
    (Forall P xs /\ Forall P ys) ->
    Forall P (xs ++ ys).
intros. break_and.
rewrite Forall_forall in *.
intros x Hin. apply in_app_or in Hin. destruct Hin; eauto.
Qed.

Lemma forall_app_2 : forall A P (xs ys : list A),
    Forall P (xs ++ ys) ->
    (Forall P xs /\ Forall P ys).
intros. repeat rewrite Forall_forall in *.
split; eauto using in_or_app.
Qed.

Lemma forall_app : forall A P (xs ys : list A),
    Forall P (xs ++ ys) <->
    (Forall P xs /\ Forall P ys).
intros. constructor; eauto using forall_app_1, forall_app_2.
Qed.

Lemma forall_concat : forall A P (xss : list (list A)),
    Forall (Forall P) xss ->
    Forall P (concat xss).
first_induction xss; intros0 Hfa.
{ simpl. constructor. }
inversion Hfa; subst.
simpl. rewrite forall_app. split; eauto.
Qed.

Lemma forall_tail : forall A P (x : A) xs,
    Forall P (x :: xs) ->
    Forall P xs.
inversion 1. assumption.
Qed.
Hint Resolve forall_tail.

Lemma Forall_map : forall A B (P : B -> Prop) (f : A -> B) xs,
    Forall (fun x => P (f x)) xs <-> Forall P (map f xs).
induction xs; intros; split; inversion 1; subst; simpl in *; eauto.
- constructor; eauto. rewrite <- IHxs. assumption.
- constructor; eauto. rewrite -> IHxs. assumption.
Qed.

(*
Lemma forall_for_each : forall n P f,
    (forall i : index n, Forall P (f i)) ->
    Forall P (for_each f).
intros0 Hf.
unfold for_each. eapply forall_concat. rewrite Forall_forall.
intros p Hin. forward eapply in_map_index_list; eauto.
break_exists. subst. eauto.
Qed.
*)

(* List lemmas - skipn *)

Lemma skipn_all : forall A n (xs : list A),
    n >= length xs ->
    skipn n xs = [].
first_induction xs; intros0 Hge.
{ destruct n; reflexivity. }
destruct n; simpl in *; [ omega | ].
eapply IHxs. omega.
Qed.

Lemma skipn_cons : forall A n (xs : list A) x,
    nth_error xs n = Some x ->
    skipn n xs = x :: skipn (S n) xs.
first_induction n; intros0 Hn.
- destruct xs; simpl in *; congruence.
- destruct xs; simpl in *; try congruence.
  eapply IHn. assumption.
Qed.

Lemma skipn_sub : forall A n (xs : list A) x,
    n < length xs ->
    nth_error xs (length xs - S n) = Some x ->
    skipn (length xs - S n) xs = x :: skipn (length xs - n) xs.
intros0 Hn Hlt.

replace (length xs - n) with (S (length xs - S n)) in * by omega.
eapply skipn_cons. assumption.
Qed.

Lemma skipn_sub' : forall A n (xs : list A),
    n < length xs ->
    exists x,
    nth_error xs (length xs - S n) = Some x /\
    skipn (length xs - S n) xs = x :: skipn (length xs - n) xs.
intros0 Hlt.
assert (Hnth : length xs - S n < length xs) by omega.
rewrite <- (nth_error_Some) in Hnth.
destruct (nth_error _ _) eqn:?; try congruence.
eexists; eauto using skipn_sub.
Qed.

(* List lemmas - in *)

Lemma in_concat : forall A (x : A) xss,
    In x (concat xss) ->
    exists xs, In xs xss /\ In x xs.
first_induction xss; intros0 H; simpl in H.
{ destruct H. }
rename a into xs.
eapply in_app_or in H. destruct H as [H | H].
- exists xs. firstorder eauto.
- forward eapply IHxss; eauto. break_exists. break_and.
  firstorder eauto.
Qed.

(*
Lemma in_for_each : forall n f x,
    In x (for_each f) ->
    exists i : index n, In x (f i).
intros0 H.
unfold for_each in H.
eapply in_concat in H. break_exists. break_and.
eapply in_map_index_list in H. break_exists.
subst. eauto.
Qed.
*)

(* Lookup lemmas *)

Lemma lookup_state_type : forall dbs dbt rn rs rt,
    dbt = database_state_type dbs ->
    rt = record_state_type rs ->
    lookup_state dbs rn = Some rs ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrs;
destruct dbs; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_config_type : forall dbc dbt rn rc rt,
    dbt = database_config_type dbc ->
    rt = record_config_type rc ->
    lookup_config dbc rn = Some rc ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrc;
destruct dbc; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_program_type : forall dbp dbt rn rp rt,
    dbt = database_program_type dbp ->
    rt = record_program_type rp ->
    lookup_program dbp rn = Some rp ->
    lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Heqrt Hnrc;
destruct dbp; simpl in *; try congruence.
- subst. simpl. congruence.
- subst. simpl in *. eauto.
Qed.

Lemma lookup_config_type_ex : forall dbc dbt rn rc,
    dbt = database_config_type dbc ->
    lookup_config dbc rn = Some rc ->
    exists rt, lookup_type dbt rn = Some rt.
first_induction rn; intros0 Heqdbt Hnrc;
destruct dbt; destruct dbc; simpl in *; try congruence.
- eexists. reflexivity.
- fancy_injection Heqdbt. eapply IHrn; eauto.
Qed.

Lemma lookup_state_type_eq : forall dbs dbt rn rs rt,
    dbt = database_state_type dbs ->
    lookup_state dbs rn = Some rs ->
    lookup_type dbt rn = Some rt ->
    rt = record_state_type rs.
first_induction rn; intros0 Heqdbt Hls Hlt;
subst dbt; destruct dbs; simpl in *; try congruence.
eapply IHrn; eauto.
Qed.

Lemma lookup_Some_lt : forall A xs idx x,
    @lookup A xs idx = Some x ->
    idx < length xs.
intros. unfold lookup in *. rewrite <- nth_error_Some. congruence.
Qed.

Lemma lookup_lt_Some_ex : forall A xs idx,
    idx < length xs ->
    exists x, @lookup A xs idx = Some x.
intros. unfold lookup in *. rewrite <- nth_error_Some in H.
destruct (nth_error xs idx).
- eexists. reflexivity.
- congruence.
Qed.

Lemma lookup_length_ex : forall A B xs ys idx x,
    @lookup A xs idx = Some x ->
    (* Put length premise second so it gets processed later by `; eauto`. *)
    length xs = length ys ->
    exists y, @lookup B ys idx = Some y.
first_induction idx; intros;
destruct xs; simpl in *; try congruence;
destruct ys; simpl in *; try congruence.
- eexists. reflexivity.
- eapply IHidx; eauto.
Qed.

Lemma lookup_map : forall A B f xs rn x,
    @lookup A xs rn = Some x ->
    @lookup B (map f xs) rn = Some (f x).
first_induction rn; intros0 Hlook; destruct xs; simpl in *; try congruence.
eapply IHrn. assumption.
Qed.

Lemma lookup_map' : forall A B f xs ys rn x,
    @lookup A xs rn = Some x ->
    ys = map f xs ->
    @lookup B ys rn = Some (f x).
intros0 Hlook Heq. subst ys. eauto using lookup_map.
Qed.

Lemma sum_lt_init : forall xs x x',
    x < x' ->
    fold_left Nat.add xs x < fold_left Nat.add xs x'.
first_induction xs; intros0 Hlt; simpl in *.
{ assumption. }
apply IHxs. omega.
Qed.

Lemma sum_base_split : forall b1 b2 xs,
    fold_left Nat.add xs (b1 + b2) = b1 + fold_left Nat.add xs b2.
first_induction xs; intros; simpl.
{ omega. }
replace (b1 + b2 + a) with (b1 + (b2 + a)) by omega.
eapply IHxs.
Qed.

Lemma sum_base_add : forall b xs,
    fold_left Nat.add xs b = b + fold_left Nat.add xs 0.
intros.
replace b with (b + 0) at 1 by omega.
eapply sum_base_split.
Qed.

Lemma sum_cons : forall x xs base,
    fold_left Nat.add (x :: xs) base =
    x + fold_left Nat.add xs base.
intros. simpl.
rewrite Nat.add_comm.
eapply sum_base_split.
Qed.

Lemma sum_app : forall xs1 xs2 base,
    fold_left Nat.add (xs1 ++ xs2) base =
    base + fold_left Nat.add xs1 0 + fold_left Nat.add xs2 0.
intros.
rewrite fold_left_app. simpl.
rewrite <- sum_base_add, <- sum_base_add.
reflexivity.
Qed.

Lemma sum_init' : forall xs base x,
    fold_left Nat.add xs (base + x) =
    base + fold_left Nat.add xs x.
first_induction xs; intros; simpl.
{ omega. }
replace (base + x + a) with (base + (x + a)) by omega.
apply IHxs.
Qed.

Lemma sum_init : forall xs base,
    fold_left Nat.add xs base =
    base + fold_left Nat.add xs 0.
intros. replace (base) with (base + 0) at 1 by omega. eapply sum_init'.
Qed.

(* list_magic and friends *)

(* core lemmas used by list_magic *)
Lemma Forall_nth_error : forall X (P : X -> Prop) xs,
    Forall P xs ->
    (forall i x, nth_error xs i = Some x -> P x).
intros.
rewrite Forall_forall in *.
eauto using nth_error_In.
Qed.

Lemma nth_error_Forall : forall X (P : X -> Prop) xs,
    (forall i x, nth_error xs i = Some x -> P x) ->
    Forall P xs.
intros. rewrite Forall_forall in *. intros.
forward eapply In_nth_error; eauto. break_exists. eauto.
Qed.

Lemma Forall2_length : forall X Y (P : X -> Y -> Prop) xs ys,
    Forall2 P xs ys ->
    length xs = length ys.
induction xs; intros0 Hfa; invc Hfa; simpl; eauto.
Qed.

Lemma Forall2_nth_error : forall X Y (P : X -> Y -> Prop) xs ys,
    Forall2 P xs ys ->
    (forall i x y,
        nth_error xs i = Some x ->
        nth_error ys i = Some y ->
        P x y).
induction xs; intros0 Hfa; invc Hfa; intros0 Hnx Hny.
- destruct i; discriminate Hnx.
- destruct i; simpl in Hnx, Hny.
  + congruence.
  + eapply IHxs; eauto.
Qed.

Lemma nth_error_Forall2 : forall X Y (P : X -> Y -> Prop) xs ys,
    length xs = length ys ->
    (forall i x y,
        nth_error xs i = Some x ->
        nth_error ys i = Some y ->
        P x y) ->
    Forall2 P xs ys.
induction xs; intros0 Hlen Hnth; destruct ys; invc Hlen.
- constructor.
- constructor.
  + eapply Hnth with (i := 0); reflexivity.
  + eapply IHxs; eauto.
    intros. eapply Hnth with (i := S i); simpl; eauto.
Qed.

Lemma length_nth_error_Some : forall X Y  xs ys x i,
    @length X xs = @length Y ys ->
    nth_error xs i = Some x ->
    exists y, nth_error ys i = Some y.
intros.
destruct (nth_error ys i) eqn:?; try eauto.
rewrite nth_error_None in *.
assert (nth_error xs i <> None) by congruence.
rewrite nth_error_Some in *.
omega.
Qed.

Lemma Forall2_nth_error_Some : forall X Y (P : X -> Y -> Prop) xs ys x i,
    Forall2 P xs ys ->
    nth_error xs i = Some x ->
    exists y, nth_error ys i = Some y.
intros. eapply length_nth_error_Some. eapply Forall2_length. all:eauto.
Qed.

(* list_magic_using H:

   Given this context and goal:

    H : forall i,
        forall x, nth_error xs i = Some x ->
        forall y, nth_error ys i = Some y ->
        P x ->
        Q y ->
        R x y ->
        S x
    Hp : Forall P xs
    Hq : Forall Q ys
    Hr : Forall2 R xs ys
     -----
    Forall S x

   Complete the entire proof, by combining `H` with the lemmas above.
 *)

Ltac collect_length_hyps :=
    repeat match goal with
    | [ H : Forall2 _ ?xs_ ?ys_ |- _ ] =>
            lazymatch goal with
            | [ H : length xs_ = length ys_ |- _ ] => fail (* already known *)
            | [ |- _ ] =>
                    forward eapply Forall2_length with (xs := xs_) (ys := ys_) (1 := H)
            end
    end.

Ltac find_matching_entries HH i :=
    repeat match type of HH with
    | forall y, nth_error ?ys_ i = Some y -> _ =>
            first
                [ specialize (HH ?? **)
                | let Hexist := fresh "H" in
                  let y := fresh "y" in
                  let Hy := fresh "H" y in
                  forward eapply length_nth_error_Some with (ys := ys_) as Hexist;
                  [ | eassumption | ];
                  [ congruence | ];
                  destruct Hexist as [y Hy];
                  specialize (HH y Hy) ]
    end.

Ltac require_no_match P :=
    lazymatch goal with
    | [ H : P |- _ ] => fail "expected no hypothesis matching" P ", but found" H
    | [ |- _ ] => idtac
    end.

Ltac collect_entry_hyps i :=
    repeat match goal with
    | [ Hfa : Forall ?P ?xs, Hnth : nth_error ?xs i = Some ?x |- _ ] =>
            require_no_match (P x);
            assert (P x) by (eapply Forall_nth_error with (1 := Hfa) (2 := Hnth))
    | [ Hfa : Forall2 ?P ?xs ?ys,
        Hnx : nth_error ?xs i = Some ?x,
        Hny : nth_error ?ys i = Some ?y |- _ ] =>
            require_no_match (P x y);
            assert (P x y) by
                (eapply Forall2_nth_error with (1 := Hfa) (2 := Hnx) (3 := Hny))
    end.

Ltac list_magic_using HH :=
    let i := fresh "i" in
    collect_length_hyps;
    (eapply nth_error_Forall || (eapply nth_error_Forall2; [congruence | ..]));
    intro i; intros;
    specialize (HH i);
    collect_length_hyps; find_matching_entries HH i; collect_entry_hyps i;
    eapply HH; eauto.

(* list_magic_on (xs, (ys, (zs, tt))):

   Assert and attempt to prove a suitable `H`, based on the uses of `Forall` on
   `xs`, `ys`, and `zs` in the context and goal.  Solves goals of the form
   `Forall P xs` or `Forall P xs ys`, but may produce a subgoal to prove that
   `P` holds on a particular `x`. *)

Ltac build_list_magic_hyp_type_inner lists G :=
    let i := fresh "i" in
    simple refine (forall i : nat, (_ : Prop));
    let rec loop ls :=
        lazymatch ls with
        | (?l, ?ls) =>
                let x := fresh l "_" i in
                let Hx := fresh "H" x in
                simple refine (forall x, forall Hx : nth_error l i = Some x, (_ : Prop));
                loop ls
        | tt => idtac
        end in
    loop lists;
    repeat match goal with
    | [ Hfa : Forall ?P ?xs,
        Hnth : nth_error ?xs i = Some ?x |- _ ] =>
            simple refine (P x -> (_ : Prop));
            clear Hfa
    | [ Hfa : Forall2 ?P ?xs ?ys,
        Hnthx : nth_error ?xs i = Some ?x,
        Hnthy : nth_error ?ys i = Some ?y |- _ ] =>
            simple refine (P x y -> (_ : Prop));
            clear Hfa
    end;
    lazymatch G with
    | Forall ?P ?xs =>
            lazymatch goal with
            | [ Hnth : nth_error xs i = Some ?x |- _ ] =>
                    exact (P x)
            end
    | Forall2 ?P ?xs ?ys =>
            lazymatch goal with
            | [ Hnthx : nth_error xs i = Some ?x,
                Hnthy : nth_error ys i = Some ?y |- _ ] =>
                    exact (P x y)
            end
    end.

Ltac build_list_magic_hyp_type H_ty lists :=
    match goal with
    | [ |- ?G ] =>
            simple refine (let H_ty : Prop := _ in _);
            [ build_list_magic_hyp_type_inner lists G
            | simpl in H_ty ]
    end.

Ltac list_magic_on lists :=
    let H := fresh "H" in
    let H_ty := fresh H "_ty" in
    build_list_magic_hyp_type H_ty lists;
    assert (H : H_ty); unfold H_ty in *; clear H_ty;
        [ intros; eauto | try list_magic_using H ].

Fixpoint numbered' {A} n (xs : list A) :=
    match xs with
    | [] => []
    | x :: xs => (n, x) :: numbered' (S n) xs
    end.

Definition numbered {A} (xs : list A) := numbered' 0 xs.

Lemma numbered'_map_snd : forall A n (xs : list A),
    map snd (numbered' n xs) = xs.
first_induction xs; intros; eauto.
- simpl. f_equal. eauto.
Qed.

Lemma numbered_map_snd : forall A (xs : list A),
    map snd (numbered xs) = xs.
unfold numbered. intros. eapply numbered'_map_snd.
Qed.

Definition map_partial {A B} (f : A -> option B) : list A -> option (list B) :=
    let fix go xs :=
        match xs with
        | [] => Some []
        | x :: xs =>
                match f x, go xs with
                | Some y, Some ys => Some (y :: ys)
                | _, _ => None
                end
        end in go.