Unset Asymmetric Patterns.

Definition goodid : forall {A} (x: A), A := fun A x => x.
Definition wrongid : forall A (x: A), A := fun {A} x => x.

Inductive ty := N | B.

Inductive alt_list : ty -> ty -> Type :=
  | nil {k} : alt_list k k
  | Ncons {k} : nat -> alt_list B k -> alt_list N k
  | Bcons {k} : bool -> alt_list N k -> alt_list B k.

Definition trullynul k {k'} (l : alt_list k k') :=
match k,l with
 |N,l' => Ncons 0 (Bcons true l')
 |B,l' => Bcons true (Ncons 0 l')
end.

(* At some time, the success of trullynul was dependent on the name of
   the variables! *)

Definition trullynul2 k {a} (l : alt_list k a) :=
match k,l with
 |N,l' => Ncons 0 (Bcons true l')
 |B,l' => Bcons true (Ncons 0 l')
end.

Definition trullynul3 k {z} (l : alt_list k z) :=
match k,l with
 |N,l' => Ncons 0 (Bcons true l')
 |B,l' => Bcons true (Ncons 0 l')
end.

Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 ->
alt_list t1 t3 :=
  match l with
  | nil => fun _ l2 => P l2
  | Ncons n l1 => fun _ l2 => Ncons n (app (@P) l1 l2)
  | Bcons b l1 => fun _ l2 => Bcons b (app (@P) l1 l2)
  end.

Check (fun {t t'} (l: alt_list t t') =>
 app trullynul (goodid l) (wrongid _ nil)).


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman
january 2013

************************************************************)

(** **********************************************************

Contents :  Definition of adjunction

	    Definition of equivalence of precategories

	    Equivalence of categories yields weak equivalence
            of object types

            A fully faithful and ess. surjective functor induces
            equivalence of precategories, if the source
            is a category.

************************************************************)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.
Require Import RezkCompletion.equivalences.

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
(*Local Notation "'hom' C" := (precategory_morphisms (C := C)) (at level 2).*)
Local Notation "f ;; g" := (compose f g)(at level 50).
Notation "[ C , D ]" := (functor_precategory C D).
Local Notation "# F" := (functor_on_morphisms F)(at level 3).

Section from_equiv_to_fully_faithful.

Variables A B : precategory.
Variable F : functor A B.
Variable H : equivalence_of_precats F.

Let G : functor B A := right_adjoint (pr1 H).
Let eta := eta_pointwise_iso_from_equivalence H.
Let eps := eps_pointwise_iso_from_equivalence H.

Check eta.

Definition inverse {a b} (g : F a --> F b) : a --> b :=
   eta a ;;  #G g ;; inv_from_iso (eta b).

Lemma inverse_is_inverse_1 a b (f : a --> b) :
    inverse (#F f) == f.
Proof.
  unfold inverse.
  set (H' := nat_trans_ax _ _ (eta_from_left_adjoint (pr1 H))).
  simpl in H'; rewrite <- H'; clear H'; simpl in *.
  rewrite <- assoc.
  transitivity (f ;; identity _ ).
  apply maponpaths.
  set (H':=iso_inv_after_iso _ _ _ (eta b)).
  apply H'.
  rewrite id_right.
  apply idpath.
Qed.

Lemma triangle_id_inverse (a : A):
   iso_inv_from_iso (functor_on_iso _ _ F _ _ (eta a)) == eps (F a).
Proof.
  apply eq_iso. simpl.
  match goal with | [  |- ?x == ?y ] => transitivity (x ;; identity _ )end.
  apply pathsinv0, id_right.
  apply iso_inv_on_right.
  set (H':=triangle_id_left_ad _ _ _ (pr1 H) a).
  apply pathsinv0.
  apply H'.
Qed.

Lemma triangle_id_inverse' (a : A):
   inv_from_iso (functor_on_iso _ _ F _ _ (eta a)) == eps (F a).
Proof.
  apply (base_paths _ _ (triangle_id_inverse a)).
Qed.

Lemma inverse_is_inverse_2 a b (g : F a --> F b) :
    #F (inverse g) == g.
Proof.
  unfold inverse.
  repeat rewrite functor_comp.
  rewrite functor_on_inv_from_iso.
  simpl.
  rewrite triangle_id_inverse'.
  rewrite <- assoc.
  set (H':=nat_trans_ax _ _ (eps_from_left_adjoint (pr1 H))).
  simpl in H'; rewrite H'; clear H'.
  rewrite assoc.
  set (H' := pathsinv0 (triangle_id_left_ad _ _ _ (pr1 H) a)).
  match goal with | [ |- ?f ;; ?g == ?h ] =>
        assert (H'' : identity _ == f) end.
  - simpl in *; apply H'.
  - rewrite <- H''. rewrite id_left. apply idpath.
Qed.

Lemma fully_faithful_from_equivalence : fully_faithful F.
Proof.
  unfold fully_faithful.
  intros a b.
  apply (gradth _ (@inverse a b)).
  - apply inverse_is_inverse_1.
  - apply inverse_is_inverse_2.
Qed.

End from_equiv_to_fully_faithful.


(** * FOL Reductions *)

Require Export FOL.PCP Deduction.

(** ** Validity *)

Section validity.

  Notation u := 0. Notation v := 1.
  Context {b : logic}.
  Variable R : BSRS.

  Definition prep (x : string bool) (t : term) : term := fold_right t_f t x.
  Definition iprep domain eta {I : interp domain eta} (x : list bool) (y : domain) := fold_right i_f y x.
  Definition enc s := (prep s t_e).

  Definition F1 := map (fun '(x,y) => Pr (enc x) (enc y)) R.
  Definition F2 := map (fun '(x, y) => ∀ u; ∀ v; Pr u v --> Pr (prep x u) (prep y v)) R.
  Definition F3 := (∀ u; Pr u u --> Q).

  Definition F : form b := F1 ==> F2 ==> F3 --> Q.

  Lemma enc_vars x :
    vars_t (enc x) = [].
  Proof.
    induction x; trivial.
  Qed.

  Lemma prep_subst y t1 x t :
    subst_t y t1 (prep x t) = prep x (subst_t y t1 t).
  Proof.
    induction x; cbn; f_equal; eauto.
  Qed.

  Lemma prep_vars x t :
    vars_t (prep x t) = vars_t t.
  Proof.
    induction x; cbn; eauto.
  Qed.

  Lemma iprep_eval domain eta (I : interp domain eta) rho x s :
    eval rho (prep x s) = iprep x (eval rho s).
  Proof.
    induction x; cbn; now do 2 f_equal.
  Qed.

  Lemma iprep_app domain eta (I : interp domain eta) x y d :
    iprep (x ++ y) d = iprep x (iprep y d).
  Proof.
    unfold iprep. now rewrite fold_right_app.
  Qed.

  Global Instance IB : interp (string bool) (fun _ => []) :=
    {|
      i_f b s := b :: s ;
      i_e := nil;
      i_P u v := derivable R u v ;
      i_Q := BPCP' R
    |}.

  Lemma IB_prep rho s t :
    eval rho (prep s t) = s ++ eval rho t.
  Proof.
    induction s; cbn; trivial.
    rewrite <- IHs. reflexivity.
  Qed.

  Lemma IB_enc rho s :
    eval rho (enc s) = s.
  Proof.
    unfold enc. rewrite IB_prep.
    cbn. apply app_nil_r.
  Qed.

  Lemma IB_drv rho t1 t2 :
    rho ⊨ (Pr t1 t2) <-> derivable R (eval rho t1) (eval rho t2).
  Proof.
    cbn. reflexivity.
  Qed.

  Lemma IB_F1 rho :
    rho ⊫ F1.
  Proof.
    unfold F1.
    intros ? ([x y] & <- & ?) % in_map_iff.
    cbn. econstructor. now rewrite !IB_enc.
  Qed.

  Lemma IB_F2 rho :
    rho ⊫ F2.
  Proof.
    unfold F2. intros ? ([x y] & <- & ?) % in_map_iff u v ?. cbn.
    rewrite !IB_prep. cbn in *. eauto using derivable.
  Qed.

  Lemma IB_F3 rho :
    rho ⊨ F3.
  Proof.
    cbn. apply cBPCP.
  Qed.

  Lemma IB_F rho :
    rho ⊨ F -> BPCP' R.
  Proof.
    intros H. unfold F in H. rewrite !impl_sat in H. eapply H.
    - eapply IB_F1.
    - eapply IB_F2.
    - apply IB_F3.
  Qed.

  Lemma drv_val domain eta (I : interp domain eta) rho u v :
    derivable R u v -> rho ⊨ (F1 ==> F2 ==> Pr (enc u) (enc v)).
  Proof.
    rewrite !impl_sat. intros. induction H.
    - eapply H0. eapply in_map_iff. exists (x/y). eauto.
    - eapply (H1 (∀ 0; ∀ 1; Pr 0 1 --> Pr (prep x 0) (prep y 1))) in IHderivable.
      + cbn. unfold enc in *. rewrite !iprep_eval in *. cbn in IHderivable.
        rewrite <- !iprep_app in IHderivable. eapply IHderivable.
      + eapply in_map_iff. exists (x/y). eauto.
  Qed.

  Theorem BPCP_valid :
    BPCP R <-> valid F.
  Proof.
    rewrite BPCP_BPCP'. split.
    - intros [u H] D eta I rho.
      eapply (@drv_val _ _ I) in H. unfold F. cbn in *.
      rewrite !impl_sat in *. cbn in *.
      intros. eapply (H2 (eval rho (enc u))). eauto.
    - intros H. apply IB_F with (rho := fun _ => nil), H.
  Qed.

  (** ** Provability *)

  Hint Resolve enc_vars.

  Definition ctx_S :=
    F3 :: rev F2 ++ rev F1.

  Lemma drv_prv s u v :
    derivable R u v -> (@prv s b ctx_S (Pr (enc u) (enc v))).
  Proof.
    induction 1.
    - econstructor. right. eapply in_app_iff. right.
      rewrite <- in_rev. eapply in_map_iff. exists (x/y). eauto.
    - assert (@prv s b ctx_S (∀ 0; ∀ 1; Pr 0 1 --> Pr (prep x 0) (prep y 1))).
      + econstructor. right. eapply in_app_iff. left.
        rewrite <- in_rev. eapply in_map_iff. exists (x/y). eauto.
      + eapply AllE with (t := enc u) in H1; eauto.
        cbn in H1. rewrite !prep_subst in H1. cbn in H1.
        eapply AllE with (t := enc v) in H1; eauto. cbn in H1.
        unfold enc in H1. rewrite !prep_subst in H1. cbn in H1.
        unfold enc, prep in *. rewrite !fold_right_app.
        eapply (ImpE H1). eassumption.
  Qed.

  Lemma impl_prv s A B phi :
    @prv s b (rev B ++ A) phi -> @ prv s b A (B ==> phi).
  Proof.
    revert A; induction B; intros A; cbn; simpl_list; intros.
    - firstorder.
    - eapply ImpI. now eapply IHB.
  Qed.

  Lemma BPCP_prv' s :
    BPCP' R -> @prv s b nil F.
  Proof.
    intros [u H].
    apply drv_prv with (s:=s) in H. unfold F.
    repeat eapply impl_prv. simpl_list. eapply ImpI.
    assert (@prv s b ctx_S (∀ 0; Pr 0 0 --> Q)).
    econstructor. now unfold ctx_S. eapply AllE with  (t := enc u) in H0.
    cbn in H0. now eapply (ImpE H0). apply prep_vars.
  Qed.

End validity.

Theorem BPCP_prv R :
  BPCP R <-> nil ⊢M (F R).
Proof.
  rewrite BPCP_BPCP'. split.
  - apply BPCP_prv'.
  - intros H % soundness. eapply BPCP_BPCP'. now apply (BPCP_valid R).
Qed.

(** ** Satisfiability *)

Lemma valid_satis phi :
  valid phi -> ~ satis (¬ phi).
Proof.
  intros H1 (D & eta & I & rho & H2).
  apply H2, (H1 D eta I rho).
Qed.

Theorem BPCP_satis R :
  ~ BPCP R <-> satis (¬ F R).
Proof.
  rewrite BPCP_BPCP'. split.
  - intros H. exists _, (fun _ => nil), (IB R), (fun _ => nil).
    intros H'. cbn. apply H, (IB_F H').
  - rewrite <- BPCP_BPCP'. intros H1 H2 % (BPCP_valid R (b:=full)).
    apply (valid_satis H2), H1.
Qed.

(** ** Corollaries *)

Lemma form_discrete {b : logic} :
  discrete (form b).
Proof.
  apply discrete_iff. constructor. apply eq_dec_form.
Qed.

Hint Resolve stack_enum form_discrete.

Definition UA :=
  ~ enumerable (compl BPCP).

Corollary valid_red :
  BPCP ⪯ @valid frag.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_valid R).
Qed.

Corollary valid_undec :
  UA -> ~ decidable (@valid frag).
Proof.
  intros H. now apply (not_decidable valid_red).
Qed.

Corollary valid_unenum :
  UA -> ~ enumerable (compl (@valid frag)).
Proof.
  intros H. now apply (not_coenumerable valid_red).
Qed.

Corollary prv_red :
  BPCP ⪯ @prv intu frag nil.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_prv R).
Qed.

Corollary prv_undec :
  UA -> ~ decidable (@prv intu frag nil).
Proof.
  intros H. now apply (not_decidable prv_red).
Qed.

Corollary prv_unenum :
  UA -> ~ enumerable (compl (@prv intu frag nil)).
Proof.
  intros H. apply (not_coenumerable prv_red); trivial.
Qed.

Corollary satis_red :
  compl BPCP ⪯ @satis full.
Proof.
  exists (fun R => ¬ F R). intros R. apply (BPCP_satis R).
Qed.

Corollary satis_undec :
  UA -> ~ decidable (@satis full).
Proof.
  intros H1 H2 % (dec_red satis_red).
  now apply H1, dec_count_enum.
Qed.

Corollary satis_enum :
  UA -> ~ enumerable (@satis full).
Proof.
  intros H1 H2 % (enumerable_red satis_red); auto.
Qed.

(** ** Non-Standard Model *)

Module NonStan. Section Nonstan.

  Variable R : BSRS.

  Instance IB : interp (option (string bool)) (fun _ => Some nil) :=
    {|
      i_f b x := match x with Some u => Some (b :: u) | None => None end ;
      i_e := Some nil;
      i_P x y := match x, y with Some u, Some v => derivable R u v | _, _ => True end ;
      i_Q := False
    |}.

  Lemma IB_eval_Some rho t u v :
    eval rho t = Some v -> eval rho (prep u t) = Some (u ++ v).
  Proof.
    intros H. induction u; cbn; trivial.
    unfold prep in IHu. now rewrite IHu.
  Qed.

  Lemma IB_eval_None rho t u :
    eval rho t = None -> eval rho (prep u t) = None.
  Proof.
    intros H. induction u; cbn; trivial.
    unfold prep in IHu. now rewrite IHu.
  Qed.

  Lemma IB_enc rho u :
    eval rho (enc u) = Some u.
  Proof.
    unfold enc. rewrite <- (app_nil_r u) at 2.
    now apply IB_eval_Some.
  Qed.

  Lemma IB_deriv rho u v :
    rho ⊨ (Pr (enc u) (enc v)) <-> derivable R u v.
  Proof.
    cbn. rewrite !IB_enc. reflexivity.
  Qed.

  Lemma IB_deriv' rho t1 t2 u v :
    eval rho t1 = Some u -> eval rho t2 = Some v ->
    rho ⊨ (Pr t1 t2) <-> derivable R u v.
  Proof.
    intros H1 H2. cbn. rewrite H1, H2. reflexivity.
  Qed.

  Lemma IB_F1 rho :
    rho ⊫ F1 R.
  Proof.
    unfold F1.
    intros ? ([x y] & <- & ?) % in_map_iff.
    cbn. rewrite !IB_enc. now constructor.
  Qed.

  Lemma IB_F2 rho :
    rho ⊫ F2 R.
  Proof.
    unfold F2. intros ? ([x y] & <- & ?) % in_map_iff [u|] [v|] ?; cbn in *.
    - erewrite !IB_eval_Some; cbn; auto. now constructor 2.
    - erewrite IB_eval_Some, IB_eval_None; cbn; auto.
    - erewrite IB_eval_None; cbn; auto.
    - erewrite !IB_eval_None; cbn; auto.
  Qed.

  Lemma IB_F rho :
    rho ⊨ F R.
  Proof.
    unfold F. rewrite !impl_sat. intros _ _ H.
    apply (H None). cbn. auto.
  Qed.

  Lemma IB_nonstandard rho :
    rho ⊨ ¬ ∀ 0; ¬ Pr 0 0.
  Proof.
    intros H. apply (H None). cbn. auto.
  Qed.

End Nonstan. End NonStan.


(** * HoareAsLogic: Hoare Logic as a Logic *)

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic.

    This chapter is optional.  Before reading it, you'll want to read
    the [ProofObjects] chapter in _Logical
    Foundations_ (_Software Foundations_, volume 1). *)

From PLF Require Import Imp.
From PLF Require Import Hoare.

(* ################################################################# *)
(** * Definitions *)

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq  : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (TEST b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

(** We don't need to include axioms corresponding to
    [hoare_consequence_pre] or [hoare_consequence_post], because
    these can be proven easily from [H_Consequence]. *)

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence.
    apply X.  apply H.  intros. apply H0. Qed.

Lemma H_Consequence_post  : forall (P Q Q' : Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence.
    apply X. intros. apply H0.  apply H. Qed.

(** As an example, let's construct a proof object representing a
    derivation for the hoare triple

      {{(X=3) [X |-> X + 2] [X |-> X + 1]}}
      X::=X+1 ;; X::=X+2
      {{X=3}}.

    We can use Coq's tactics to help us construct the proof object. *)

Example sample_proof :
  hoare_proof
    ((fun st:state => st X = 3) [X |-> X + 2] [X |-> X + 1])
    (X ::= X + 1;; X ::= X + 2)
    (fun st:state => st X = 3).
Proof.
  eapply H_Seq; apply H_Asgn.
Qed.

(*
Print sample_proof.

====>
  H_Seq
  (((fun st : state => st X = 3) [X |-> X + 2]) [X |-> X + 1])
  (X ::= X + 1)
  ((fun st : state => st X = 3) [X |-> X + 2])
  (X ::= X + 2)
  (fun st : state => st X = 3)
  (H_Asgn
     ((fun st : state => st X = 3) [X |-> X + 2])
     X (X + 1))
  (H_Asgn
     (fun st : state => st X = 3)
     X (X + 2))
*)

(* ################################################################# *)
(** * Properties *)

(** **** Exercise: 2 stars, standard (hoare_proof_sound)

    Prove that such proof objects represent true claims. *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also use Coq's reasoning facilities to prove metatheorems
    about Hoare Logic.  For example, here are the analogs of two
    theorems we saw in chapter [Hoare] -- this time expressed in terms
    of the syntax of Hoare Logic derivations (provability) rather than
    directly in terms of the semantics of Hoare triples.

    The first one says that, for every [P] and [c], the assertion
    [{{P}} c {{True}}] is _provable_ in Hoare Logic.  Note that the
    proof is more complex than the semantic proof in [Hoare]: we
    actually need to perform an induction over the structure of the
    command [c]. *)

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  induction c; intro P.
  - (* SKIP *)
    eapply H_Consequence.
    apply H_Skip.
    intros. apply H.
    (* Proof of True *)
    intros. apply I.
  - (* ::= *)
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  - (* ;; *)
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  - (* TEST *)
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  - (* WHILE *)
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

(** Similarly, we can show that [{{False}} c {{Q}}] is provable for
    any [c] and [Q]. *)

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  induction c; intro Q.
  - (* SKIP *) pre_false_helper H_Skip.
  - (* ::= *) pre_false_helper H_Asgn.
  - (* ;; *) pre_false_helper H_Seq. apply IHc1. apply IHc2.
  - (* TEST *)
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  - (* WHILE *)
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

(** As a last step, we can show that the set of [hoare_proof] axioms
    is sufficient to prove any true fact about (partial) correctness.
    More precisely, any semantic Hoare triple that we can prove can
    also be proved from these axioms.  Such a set of axioms is said to
    be _relatively complete_.  Our proof is inspired by this one:

      http://www.ps.uni-saarland.de/courses/sem-ws11/script/Hoare.html

    To carry out the proof, we need to invent some intermediate
    assertions using a technical device known as _weakest
    preconditions_.  Given a command [c] and a desired postcondition
    assertion [Q], the weakest precondition [wp c Q] is an assertion
    [P] such that [{{P}} c {{Q}}] holds, and moreover, for any other
    assertion [P'], if [{{P'}} c {{Q}}] holds then [P' -> P].  We can
    more directly define this as follows: *)

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', s =[ c ]=> s' -> Q s'.

(** **** Exercise: 1 star, standard (wp_is_precondition)  *)

Lemma wp_is_precondition: forall c Q,
  {{wp c Q}} c {{Q}}.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (wp_is_weakest)  *)

Lemma wp_is_weakest: forall c Q P',
   {{P'}} c {{Q}} -> forall st, P' st -> wp c Q st.
(* FILL IN HERE *) Admitted.

(** The following utility lemma will also be useful. *)

Lemma bassn_eval_false : forall b st, ~ bassn b st -> beval st b = false.
Proof.
  intros b st H. unfold bassn in H. destruct (beval st b).
    exfalso. apply H. reflexivity.
    reflexivity.
Qed.
(** [] *)

(** **** Exercise: 5 stars, standard (hoare_proof_complete)

    Complete the proof of the theorem. *)

Theorem hoare_proof_complete: forall P c Q,
  {{P}} c {{Q}} -> hoare_proof P c Q.
Proof.
  intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* SKIP *)
    eapply H_Consequence.
     eapply H_Skip.
      intros.  eassumption.
      intro st. apply HT.  apply E_Skip.
  - (* ::= *)
    eapply H_Consequence.
      eapply H_Asgn.
      intro st. apply HT. econstructor. reflexivity.
      intros; assumption.
  - (* ;; *)
    apply H_Seq with (wp c2 Q).
     eapply IHc1.
       intros st st' E1 H. unfold wp. intros st'' E2.
         eapply HT. econstructor; eassumption. assumption.
     eapply IHc2. intros st st' E1 H. apply H; assumption.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we might hope that our axiomatic Hoare logic is
    _decidable_; that is, that there is an (terminating) algorithm (a
    _decision procedure_) that can determine whether or not a given
    Hoare triple is valid (derivable).  But such a decision procedure
    cannot exist!

    Consider the triple [{{True}} c {{False}}]. This triple is valid
    if and only if [c] is non-terminating.  So any algorithm that
    could determine validity of arbitrary triples could solve the
    Halting Problem.

    Similarly, the triple [{{True}} SKIP {{P}}] is valid if and only if
    [forall s, P s] is valid, where [P] is an arbitrary assertion of
    Coq's logic. But it is known that there can be no decision
    procedure for this logic.

    Overall, this axiomatic style of presentation gives a clearer
    picture of what it means to "give a proof in Hoare logic."
    However, it is not entirely satisfactory from the point of view of
    writing down such proofs in practice: it is quite verbose.  The
    section of chapter [Hoare2] on formalizing decorated programs
    shows how we can do even better. *)

(* Thu Feb 7 20:09:23 EST 2019 *)


(*
  Reduction from:
    Turing Machine Halting (HaltTM 1)
  to:
    System F Type Checking (SysF_TYP)
*)

Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.ReducibilityFacts.

Require Import Undecidability.TM.TM.
Require Import Undecidability.SystemF.SysF.

Require Undecidability.SystemF.Reductions.HaltTM_1_to_SysF_TYP.
Require Undecidability.SystemF.Reductions.SysF_TYP_to_SysF_TC.

(* Many-one reduction from Turing machine halting to System F type checking *)
Theorem reduction : HaltTM 1 ⪯ SysF_TC.
Proof.
  apply (reduces_transitive HaltTM_1_to_SysF_TYP.reduction).
  exact SysF_TYP_to_SysF_TC.reduction.
Qed.


Require Import Logic.Class.Eq.

Require Import Logic.STLC.Valid.
Require Import Logic.STLC.Syntax.
Require Import Logic.STLC.IsType.
Require Import Logic.STLC.Context.

Declare Scope STLC_Typing_scope.

(* Just so the predicate Judgment can have two arguments instead of three.      *)
Inductive Typing (b v:Type) : Type :=
| mkTyping : forall (e:Exp b v) (Ty:T b), Typing b v
.

Arguments Typing   {b} {v}.
Arguments mkTyping {b} {v}.

Notation "e >: Ty" :=(mkTyping e Ty)
    (at level 25, no associativity)      : STLC_Typing_scope.

Open Scope STLC_Typing_scope.

(* Predicate expressing a typing judgement.                                     *)
Inductive Judgement (b v:Type) (eq:Eq v): Context -> Typing -> Prop :=
| JAnn : forall (G:Context) (e:Exp b v) (Ty:T b),
    Judgement b v eq G (e >: Ty)            ->  (* e is of type Ty in context G *)
    Judgement b v eq G ((e :: Ty) >: Ty)        (* Annotated expr same type     *)
| JVar : forall (G:Context) (x:v) (Ty:T b),
    Valid G                                 ->  (* G is a valid context         *)
    G :>> x ::: Ty                          ->  (* variable x declared type Ty  *)
    Judgement b v eq G (`x >: Ty)               (* variable expr same type      *)
| JApp : forall (G:Context) (e1 e2:Exp b v) (Ty Ty':T b),
    Judgement b v eq G (e1 >: Ty :-> Ty')   ->  (* e1 of type Ty :-> Ty'        *)
    Judgement b v eq G (e2 >: Ty)           ->  (* e2 of type Ty                *)
    Judgement b v eq G (e1 $ e2 >: Ty')         (* e1 e2 of type Ty'            *)
| JLam : forall (G:Context) (x:v) (e:Exp b v) (Ty Ty':T b),
    Valid G                                 ->  (* G is a valid context         *)
    G :> Ty                                 ->  (* Ty well-formed expression    *)
    Judgement b v eq (G;x ::: Ty) (e >: Ty')->  (* e is of type Ty' with x:::Ty *)
    Judgement b v eq G ((\x ~> e) >: Ty :-> Ty')(* \x -> e is of type Ty :-> Ty'*)
.

Arguments Judgement {b} {v} {eq}.
Arguments JAnn      {b} {v} {eq}.
Arguments JVar      {b} {v} {eq}.
Arguments JApp      {b} {v} {eq}.
Arguments JLam      {b} {v} {eq}.

Notation "G :- T" := (Judgement G T)
    (at level 90, no associativity) : STLC_Typing_scope.

Open Scope STLC_Typing_scope.

(* A typing judgement will never hold, unless the context is valid.             *)
Lemma TypedIsValid : forall (b v:Type)(eq:Eq v)(G:Context)(e:Exp b v)(Ty:T b),
    G :- e >: Ty -> Valid G.
Proof.
    intros b v eq G e Ty H1. remember (e >: Ty) as k eqn:E. revert e Ty E.
    induction H1 as
        [ G e Ty H3 IH
        | G x Ty H3 H4
        | G e1 e2 Ty Ty' H3 IH1 H4 IH2
        | G x e Ty Ty' H3 H4 H5 IH
        ]; intros e' Sy H2; inversion H2; subst.
    - apply (IH e Sy). reflexivity.
    - assumption.
    - apply (IH2 e2 Ty). reflexivity.
    - assumption.
Qed.

(* A typing judgement will never hold, unless type expression is well-formed    *)
Lemma TypedIsType : forall (b v:Type)(eq:Eq v)(G:Context)(e:Exp b v)(Ty:T b),
    G :- e >: Ty -> G :> Ty.
Proof.
    intros b v eq G e Ty H1. remember (e >: Ty) as k eqn:E. revert e Ty E.
    induction H1 as
        [ G e Ty H3 IH
        | G x Ty H3 H4
        | G e1 e2 Ty Ty' H3 IH1 H4 IH2
        | G x e Ty Ty' H3 H4 H5 IH
        ]; intros e' Sy H2; inversion H2; subst; clear H2.
    - apply (IH e). reflexivity.
    - apply (ValidIsType _ _ _ G x); assumption.
    - apply IsTypeRevR with Ty. apply IH1 with e1. reflexivity.
    - apply TFun; try assumption. apply IsTypeIrrelevant with x Ty.
      apply IH with e. reflexivity.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Nth.
Require option.Option.
Require list.HdTl.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Definition zero_at (l:(list Z)) (i:Z): Prop := ((list.Nth.nth i
  l) = (Some 0%Z)) /\ forall (j:Z), ((0%Z <= j)%Z /\ (j < i)%Z) ->
  ~ ((list.Nth.nth j l) = (Some 0%Z)).

(* Why3 assumption *)
Definition no_zero (l:(list Z)): Prop := forall (j:Z), ((0%Z <= j)%Z /\
  (j < (list.Length.length l))%Z) -> ~ ((list.Nth.nth j l) = (Some 0%Z)).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 goal *)
Theorem WP_parameter_search_loop : forall (l:(list Z)), forall (s:(list Z))
  (i:Z), ((0%Z <= i)%Z /\
  (((i + (list.Length.length s))%Z = (list.Length.length l)) /\
  ((forall (j:Z), (0%Z <= j)%Z -> ((list.Nth.nth j
  s) = (list.Nth.nth (i + j)%Z l))) /\ forall (j:Z), ((0%Z <= j)%Z /\
  (j < i)%Z) -> ~ ((list.Nth.nth j l) = (Some 0%Z))))) -> ((~ (s = nil)) ->
  ((~ (s = nil)) -> forall (o:Z),
  match s with
  | nil => False
  | (cons h _) => (o = h)
  end -> ((o = 0%Z) -> ((((0%Z <= i)%Z /\ (i < (list.Length.length l))%Z) /\
  (zero_at l i)) \/ ((i = (list.Length.length l)) /\ (no_zero l)))))).
(* Why3 intros l s i (h1,(h2,(h3,h4))) h5 h6 o h7 h8. *)
intuition.
destruct s.
destruct H4.
subst; subst.
clear H0 H1.
left.
split.
change (Length.length (cons 0 s))%Z with (1 + Length.length s)%Z in H.
generalize (Length.Length_nonnegative s).
omega.
red; intuition.
assert (H0: (0 <= 0)%Z) by omega.
generalize (H3 0%Z H0).
generalize (Nth.nth_def 0%Z (cons 0%Z s)).
ring_simplify (i+0)%Z.
intuition.
Qed.


Require Import coqutil.Byte.
Require Import Rupicola.Lib.Api.
Require Import Crypto.Algebra.Hierarchy.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Local Open Scope Z_scope.

Class FieldParameters :=
  { (** mathematical parameters **)
    M_pos : positive; (* modulus *)
    M : Z := Z.pos M_pos;
    a24 : F M_pos; (* (a+2) / 4 or (a-2) / 4, depending on the implementation *)

    (** function names **)
    mul : string; add : string; sub : string;
    square : string; scmula24 : string; inv : string;
    from_bytes : string; to_bytes : string;

    (* felem_small_literal p x :=
         store p (expr.literal x);
         store (p+4) (expr.literal 0);
         ...

       felem_copy pX pY :=
         store pX (load pY);
         store (pX+4) (load (pY+4));
         ... *)
    felem_copy : string;
    felem_small_literal : string;
  }.

Class FieldParameters_ok {field_parameters : FieldParameters} :=
  { M_prime : Znumtheory.prime M;
    (* TODO: a24_ok *)
  }.

Class FieldRepresentation
      {field_parameters : FieldParameters}
      {semantics : Semantics.parameters} :=
  { felem : Type;
    feval : felem -> F M_pos;
    feval_bytes : list byte -> F M_pos;
    felem_size_in_bytes : Z; (* for stack allocation *)
    FElem : word -> felem -> Semantics.mem -> Prop;
    FElemBytes : word -> list byte -> Semantics.mem -> Prop :=
      fun addr bs =>
        (emp (length bs = Z.to_nat felem_size_in_bytes)
         * array ptsto (word.of_Z 1) addr bs)%sep;
    bounds : Type;
    bounded_by : bounds -> felem -> Prop;

    (* for saturated implementations, loose/tight bounds are the same *)
    loose_bounds : bounds;
    tight_bounds : bounds;
  }.

Definition Placeholder
           {field_parameters : FieldParameters}
           {semantics : Semantics.parameters}
           {field_representation : FieldRepresentation}
           (p : Semantics.word) : Semantics.mem -> Prop :=
  Memory.anybytes p felem_size_in_bytes.

Class FieldRepresentation_ok
      {field_parameters : FieldParameters}
      {semantics : Semantics.parameters}
      {field_representation : FieldRepresentation} :=
  { felem_size_in_bytes_mod :
      (felem_size_in_bytes mod Memory.bytes_per_word Semantics.width)%Z = 0%Z;
    FElem_from_bytes :
      forall px,
        Lift1Prop.iff1 (Placeholder px) (Lift1Prop.ex1 (FElem px));
    relax_bounds :
      forall X : felem, bounded_by tight_bounds X
                        -> bounded_by loose_bounds X;
  }.

Notation unop_spec name op xbounds outbounds :=
  (forall! (x : felem) (px pout : word),
      (fun Rr mem =>
         bounded_by xbounds x
         /\ (exists Ra, (FElem px x * Ra)%sep mem)
         /\ (Placeholder pout * Rr)%sep mem)
        ===> name @ [pout; px] ===>
        (fun _ =>
           liftexists out,
           (emp (feval out = op (feval x)
                 /\ bounded_by outbounds out)
            * FElem pout out)%sep))
    (only parsing).

Notation binop_spec name op xbounds ybounds outbounds :=
  (forall! (x y : felem) (px py pout : word),
      (fun Rr mem =>
         bounded_by xbounds x
         /\ bounded_by ybounds y
         /\ (exists Ra, (FElem px x * Ra)%sep mem)
         /\ (exists Ra, (FElem py y * Ra)%sep mem)
         /\ (Placeholder pout * Rr)%sep mem)
        ===> name @ [pout; px; py] ===>
        (fun _ =>
           liftexists out,
           (emp ((feval out = op (feval x) (feval y))
                 /\ bounded_by outbounds out)
            * FElem pout out)%sep)) (only parsing).

Section FunctionSpecs.
  Context {semantics : Semantics.parameters}
          {semantics_ok : Semantics.parameters_ok semantics}.
  Context {field_parameters : FieldParameters}
          {field_representaton : FieldRepresentation}.

  Instance spec_of_mul : spec_of mul :=
    binop_spec mul F.mul loose_bounds loose_bounds tight_bounds.
  Instance spec_of_square : spec_of square :=
    unop_spec square (fun x => F.mul x x) loose_bounds tight_bounds.
  Instance spec_of_add : spec_of add :=
    binop_spec add F.add tight_bounds tight_bounds loose_bounds.
  Instance spec_of_sub : spec_of sub :=
    binop_spec sub F.sub tight_bounds tight_bounds loose_bounds.
  Instance spec_of_scmula24 : spec_of scmula24 :=
    unop_spec scmula24 (F.mul a24) loose_bounds tight_bounds.
  (* TODO: what are the bounds for inv? *)
  Instance spec_of_inv : spec_of inv :=
    unop_spec inv F.inv tight_bounds loose_bounds.

  Definition spec_of_from_bytes : spec_of from_bytes :=
    forall! (bs : list byte) (px pout : word),
      (fun Rr mem =>
         (exists Ra, (FElemBytes px bs * Ra)%sep mem)
         /\ (Placeholder pout * Rr)%sep mem)
        ===> from_bytes @ [pout; px] ===>
        (fun _ =>
           liftexists X,
           (emp (feval X = feval_bytes bs /\ bounded_by tight_bounds X)
            * FElem pout X)%sep).

  Definition spec_of_to_bytes : spec_of to_bytes :=
    forall! (x : felem) (px pout : word) (old_out : list byte),
      (fun Rr mem =>
         bounded_by tight_bounds x
         /\ (exists Ra, (FElem px x * Ra)%sep mem)
         /\ (FElemBytes pout old_out * Rr)%sep mem)
        ===> to_bytes @ [pout; px] ===>
        (fun _ =>
           liftexists bs,
           (emp (feval_bytes bs = feval x) * FElemBytes pout bs)%sep).

  Definition spec_of_felem_copy : spec_of felem_copy :=
    forall! (x : felem) (px pout : word),
      (sep (FElem px x * Placeholder pout)%sep)
        ===> felem_copy @ [pout; px] ===>
        (fun _ => FElem px x * FElem pout x)%sep.

  Definition spec_of_felem_small_literal : spec_of felem_small_literal :=
    forall! (x pout : word),
      (sep (Placeholder pout))
        ===> felem_small_literal @ [pout; x] ===>
        (fun _ =>
           liftexists X,
           (emp (F.to_Z (feval X) = word.unsigned x
                 /\ bounded_by tight_bounds X)
            * FElem pout X)%sep).
End FunctionSpecs.

Section SpecProperties.
  Context {semantics : Semantics.parameters}
          {semantics_ok : Semantics.parameters_ok semantics}.
  Context {field_parameters : FieldParameters}
          {field_representaton : FieldRepresentation}
          {field_representation_ok : FieldRepresentation_ok}.

  Lemma FElem_to_bytes px x :
    Lift1Prop.impl1 (FElem px x) (Placeholder px).
  Proof.
    rewrite FElem_from_bytes.
    repeat intro; eexists; eauto.
  Qed.

  Lemma M_nonzero : M <> 0.
  Proof. cbv [M]. congruence. Qed.
End SpecProperties.


Require Import QArith.
Require Import Arith.
Require Import Reals.
Require Import Psatz.
Require Import QArith.Qminmax.
Require Import Coq.Arith.PeanoNat.
Require Lra.

Structure Point2D := {
fst:> Q;
snd:> Q;
}.
Axiom Q_equality : forall (x y : Q), x == y -> x = y.

Inductive dim: Set := zero : dim | one :dim.

Lemma eq_dim_dec : forall (i:dim)(j:dim), {i=j} + {~i=j}.
Proof.
intros.
induction i .
-induction j.
  + tauto.
  + right. discriminate.
-induction j.
  + right. discriminate.
  + tauto.
Qed.

Definition dart := nat.
Definition eq_dart_dec := eq_nat_dec.
Definition nil := 0%nat.
Definition default_point : Point2D := {| fst:=0 ; snd:=0|}.

Inductive Hmap : Set :=
V : Hmap
| I : Hmap -> dart -> Point2D -> Hmap
| L : Hmap -> dim -> dart -> dart -> Hmap.

Fixpoint fpoint (m:Hmap) (d:dart) : Point2D :=
match m with
V => default_point
| I m0 x p => if eq_dart_dec x d then p else  fpoint m0 d
| L m0 _ _ _ => fpoint m0 d
end.

Fixpoint exd (m:Hmap) (d:dart) : Prop :=
match m with
V => False
| I m0 x _ => x =d \/ exd m0  d
| L m0 _ _ _ => exd m0 d
end.

Fixpoint k_succ (m:Hmap)(k:dim)(d:dart) : dart :=
match m with
V => nil
|I m0 _ _ => k_succ m0 k d
|L m0 k0 x y =>
if eq_dim_dec k k0
then if eq_dart_dec x d then y else k_succ m0 k d
else k_succ m0 k d
end.

Fixpoint k_succ_cl (m:Hmap)(k:dim)(d:dart): dart :=
match m with
V => nil
|I m0 _ _ => k_succ_cl m0 k d
|L m0 k0 x y =>
if eq_dim_dec k k0
  then if eq_dart_dec x d then y else k_succ m0 k d
else k_succ_cl m0 k d
end.

Fixpoint k_pred (m:Hmap)(k:dim)(d:dart) : dart :=
match m with
V => nil
|I m0 _ _ => k_pred m0 k d
|L m0 k0 x y =>
if eq_dim_dec k k0
then if eq_dart_dec y d then x else k_pred m0 k d
else k_pred m0 k d
end.

Definition k_succ_rev := k_pred.

Definition has_succ (m:Hmap)(k:dim)(d:dart) : Prop := k_succ m k d <> nil.
Definition has_pred (m:Hmap)(k:dim)(d:dart) : Prop := k_pred m k d <> nil.

Lemma nat_succ_ne_zero: forall (x:nat) ,S x <> nil.
Proof.
induction x.
- auto.
- unfold nil. lia.
Qed.

Lemma succ_dec: forall (m:Hmap)(k:dim)(d:dart) , has_succ m k d + (~has_succ m k d).
Proof.
intros.
unfold has_succ. remember (k_succ m k d) as x.
induction x.
- tauto.
- left . apply nat_succ_ne_zero.
Qed.

Lemma pred_dec: forall (m:Hmap)(k:dim)(d:dart) , has_pred m k d + (~has_pred m k d).
Proof.
intros.
unfold has_pred. remember (k_pred m k d) as x.
induction x.
- tauto.
- left . apply nat_succ_ne_zero.
Qed.
Definition det (p q r : Point2D) : Q :=
((fst p) * (snd q)) - (fst q )* (snd p) - (fst p) * (snd r) +
(fst r )* (snd p) + (fst q) * (snd r) - (fst r) * (snd q).

Definition prec_I (m:Hmap)(x:dart) : Prop := x <> nil /\ ~ exd m x.
Definition prec_L (m:Hmap)(k:dim)(x:dart)(y:dart) : Prop :=
exd m x /\ exd m y /\ ~has_succ m k x /\ ~has_pred m k y /\ k_succ_cl m k x <> y.

Fixpoint inv_hmap (m:Hmap) :Prop :=
match m with
V => True
| I m0 x p => inv_hmap m0 /\ prec_I m0 x
| L m0 k x y => inv_hmap m0 /\ prec_L m0 k x y
end.
Definition collinear (x y z :Point2D) : Prop :=
(det x y z) = 0.

Definition noncollinear (m:Hmap) : Prop :=
forall (d1 d2 d3 : dart),
let p1 := (fpoint m d1) in let p2 := (fpoint m d2) in
let p3 := (fpoint m d3) in exd m d1 -> exd m d2 -> exd m d3 ->
p1 <> p2 -> p1 <> p3 -> p2 <> p3 -> ~ collinear p1 p2 p3.

Definition well_emb (m:Hmap) : Prop :=
forall (x:dart), exd m x -> let px := (fpoint m x) in
let x0 := (k_succ m zero x) in let px0 := (fpoint m x0) in
let x1 := (k_succ m one x) in let px1 := (fpoint m x1) in
let x_0 := (k_succ_rev m zero x) in let px_0 := (fpoint m x_0) in
let x_1 := (k_succ_rev m one x) in let px_1 := (fpoint m x_1) in
(has_succ m zero x -> px <> px0) /\ (has_succ m one x -> px = px1) /\
(has_pred m zero x -> px <> px_0) /\ (has_pred m one x -> px = px_1) /\
(forall y:dart, exd m y -> let py := (fpoint m y) in
y <> x -> y <> x1 -> y <> x_1 -> px <> py).

Definition ccw (p q r : Point2D) : Prop := det p q r > 0.

Fixpoint max_dart (m:Hmap) : dart :=
match m with
V => nil
| I m0 x p => if(lt_dec (max_dart m0) x) then x else (max_dart m0)
| L m0 _ _ _ => (max_dart m0)
end.

Lemma q_lt_bar: forall (x y:Q), ~x<y <-> x>=y.
Proof.
intros. split.
- apply Qnot_lt_le.
- apply Qle_not_lt.
Qed.

Lemma Qlt_dec: forall (x y:Q), {x<y} + {~ x < y}.
Proof.
intros.
case (Qlt_le_dec x y).
-intro. auto.
-intro. apply Qle_not_lt in q. auto.
Qed.

Lemma ccw_dec: forall (p q r : Point2D) , {ccw p q r} + {~ ccw p q r}.
Proof.
intros.
unfold ccw.
remember (det p q r) as d.
apply Qlt_dec.
Qed.

Fixpoint linkless (m:Hmap) : Prop :=
match m with
V => True
|I m0 _ _ => linkless m0
|L m0 _ _ _ => False
end.

Fixpoint mem_count (m:Hmap) : nat:=
match m with
V => nil
|I m0 _ _ => mem_count m0 + 1
|L m0 _ _ _ => mem_count m0
end.
Lemma det_colinear: forall (p q:Point2D) ,
~ccw p p q /\ ~ccw p q p /\ ~ccw q p p .
Proof.
intros.
split.
unfold ccw. unfold det. lra.
split. unfold ccw. unfold det. lra. unfold ccw. unfold det. lra.
Qed.
Lemma ccw_not: forall (p q r:Point2D),
ccw p q r -> ~ccw p r q.
Proof.
intros.
unfold ccw in *. unfold det in *. lra.
Qed.
Lemma ccw_not_col: forall (p q r:Point2D),
~ccw p q r -> ~ collinear p q r -> ccw p r q.
Proof.
intros.
unfold ccw in *.
unfold collinear in *. apply (Qnot_lt_le 0 (det p q r) ) in H.
apply (Qle_lteq (det p q r) 0) in H. elim H.
intro. unfold det in *. lra.
intro. apply (Q_equality (det p q r) 0) in H1. tauto.
Qed.

Lemma ccw_cyclity: forall( p r q:Point2D),
ccw p q r -> ccw q r p.
Proof. intros. unfold ccw in *. unfold det in *. lra.
Qed.
Lemma ccw_symm: forall( p q r :Point2D),
ccw p q r -> ~ ccw p r q.
Proof.
intros. unfold ccw in *. unfold det in *. lra.
Qed.
Lemma ccw_inter: forall (p q r t:Point2D),
ccw t q r -> ccw p t r -> ccw p q t -> ccw p q r.
Proof.
intros. unfold ccw in *. unfold det in *. lra.
Qed.

Lemma Q_gt_0_plus : forall (r1 r2 : Q),
  r1 > 0 -> r2 > 0 -> r1 + r2 > 0.
Proof.
intros.
lra.
Qed.

Lemma Q_gt_0_mult : forall (r1 r2 : Q),
  r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof.
intros. assert( 0 * r2 <  r1 * r2).
 apply (Qmult_lt_compat_r 0 r1 r2 ).
- tauto.
- tauto.
- lra.
Qed.
Lemma Q_gt_0_div : forall (r1 r2 : Q),
  r1 > 0 -> r2 > 0 -> r1 * / r2 > 0.
Proof.
intros.
assert( /r2 > 0).
apply Qinv_lt_0_compat. tauto.
apply Q_gt_0_mult.
tauto. tauto.
Qed.

Lemma Q_mult_div : forall (r1 r2 r3 : Q),
  r1 = r2 * r3 -> r2 > 0 -> (r1 * / r2 = r3).
Proof.
intros.

assert (r1 * / r2 == r3).
- rewrite H in *. assert(r2*r3 == r3*r2). apply (Qmult_comm ).
  rewrite H1 in *. assert (r2 * / r2 ==1). apply (Qmult_inv_r r2).
  lra. assert(r3 * r2 * / r2 == r3 * (r2 * / r2)).
  lra. rewrite H2 in *. assert (r3 * 1 == r3). lra.
  rewrite H4 in H3. tauto.
- apply Q_equality. tauto.
Qed.

Axiom ccw_trans: forall(p q r t s : Point2D),
(ccw s t p) -> (ccw s t q) -> (ccw s t r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).

(*dual transivity for leftdart dl and its next and previous darts dln and dlp
from the point of view p for arbitrary point do*)
Axiom ccw_dual_trans: forall (t s p q r :Point2D),
ccw t s p -> ccw t s r -> ccw t s q -> ccw s p q ->
ccw s q r -> ccw s p r.


Require Export SpecializedCategory Paths.
Require Import Common.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section PCategory.
  Variable V : Type.
  Variable E : V -> V -> Type.

  Hint Immediate concatenate_associative.
  Hint Rewrite concatenate_associative.

  Definition PathsCategory : @SpecializedCategory V.
    refine (@Build_SpecializedCategory _
                                       (@path V E)
                                       (@NoEdges _ _)
                                       (fun _ _ _ p p' => concatenate p' p)
                                       _
                                       _
                                       _);
    abstract t_with t'.
  Defined.
End PCategory.


Require Import List.
Import ListNotations.
Require Import Coq.Lists.ListSet.
Require Import Arith.
Require Import Omega.

Require Import Unification.

Inductive goal : Set :=
| Fail   : goal
| Cut    : goal
| Unify  : term -> term -> goal
| Disj   : goal -> goal -> goal
| Conj   : goal -> goal -> goal
| Fresh  : (name -> goal) -> goal
| Invoke : name -> term -> goal.

Definition rel : Set := term -> goal.

Inductive is_fv_of_goal (n : name) : goal -> Prop :=
| fvUnifyL : forall t1 t2 (IN_FV : In n (fv_term t1)),
                          is_fv_of_goal n (Unify t1 t2)
| fvUnifyR : forall t1 t2 (IN_FV : In n (fv_term t2)),
                          is_fv_of_goal n (Unify t1 t2)
| fvDisjL  : forall g1 g2 (IS_FV : is_fv_of_goal n g1),
                          is_fv_of_goal n (Disj g1 g2)
| fvDisjR  : forall g1 g2 (IS_FV : is_fv_of_goal n g2),
                          is_fv_of_goal n (Disj g1 g2)
| fvConjL  : forall g1 g2 (IS_FV : is_fv_of_goal n g1),
                          is_fv_of_goal n (Conj g1 g2)
| fvConjR  : forall g1 g2 (IS_FV : is_fv_of_goal n g2),
                          is_fv_of_goal n (Conj g1 g2)
| fvFresh  : forall fg n' (NEQ : n' <> n)
                          (IS_FV : is_fv_of_goal n (fg n')),
                          is_fv_of_goal n (Fresh fg)
| fvInvoke : forall r arg (IN_FV : In n (fv_term arg)),
                          is_fv_of_goal n (Invoke r arg).

Hint Constructors is_fv_of_goal : core.

(* Weak version of a variable renaming *)
Inductive renaming (old_x : name) (new_x : name) : goal -> goal -> Prop :=
| rFail : renaming old_x new_x Fail Fail
| rCut  : renaming old_x new_x Cut Cut
| rUnify : forall t1 t2, renaming old_x new_x (Unify t1 t2)
                                              (Unify (apply_subst [(old_x, Var new_x)] t1)
                                                     (apply_subst [(old_x, Var new_x)] t2))
| rDisj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1)
                               (R_G2 : renaming old_x new_x g2 rg2),
                               renaming old_x new_x (Disj g1 g2) (Disj rg1 rg2)
| rConj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1)
                               (R_G2 : renaming old_x new_x g2 rg2),
                               renaming old_x new_x (Conj g1 g2) (Conj rg1 rg2)
| rFreshNFV : forall fg (OLD_X_NOT_FV : ~ is_fv_of_goal old_x (Fresh fg)),
                        renaming old_x new_x (Fresh fg) (Fresh fg)
| rFreshFV : forall fg rfg (OLD_X_FV : is_fv_of_goal old_x (Fresh fg))
                           (R_FG : forall y (Y_NOT_FV : ~ is_fv_of_goal y (Fresh fg)),
                                            renaming old_x new_x (fg y) (rfg y)),
                           renaming old_x new_x (Fresh fg) (Fresh rfg)
| rInvoke : forall r arg, renaming old_x new_x (Invoke r arg)
                                               (Invoke r (apply_subst [(old_x, Var new_x)] arg)).

Hint Constructors renaming : core.

Definition consistent_binding (b : name -> goal) : Prop :=
  forall x y, (~ is_fv_of_goal x (Fresh b)) -> renaming x y (b x) (b y).

Inductive consistent_goal : goal -> Prop :=
| cgFail   : consistent_goal Fail
| cgCut    : consistent_goal Cut
| cgUnify  : forall t1 t2, consistent_goal (Unify t1 t2)
| cgDisj   : forall g1 g2 (CG_G1 : consistent_goal g1)
                          (CG_G2 : consistent_goal g2),
                          consistent_goal (Disj g1 g2)
| cgConj   : forall g1 g2 (CG_G1 : consistent_goal g1)
                          (CG_G2 : consistent_goal g2),
                          consistent_goal (Conj g1 g2)
| cgFresh  : forall fg (CB_FG : consistent_binding fg)
                       (CG_BODY : forall n, consistent_goal (fg n)),
                       consistent_goal (Fresh fg)
| cgInvoke : forall r arg, consistent_goal (Invoke r arg).

Hint Constructors consistent_goal : core.

Definition consistent_function (f : term -> goal) : Prop :=
  forall a1 a2 t, renaming a1 a2 (f t) (f (apply_subst [(a1, Var a2)] t)).

Definition consistent_rel (r : rel) : Prop :=
  forall (arg : term), consistent_goal (r arg) /\ consistent_function r.

Definition closed_goal_in_context (c : list name) (g : goal) : Prop :=
  forall n, is_fv_of_goal n g -> In n c.

Definition closed_rel (r : rel) : Prop :=
  forall (arg : term), closed_goal_in_context (fv_term arg) (r arg).

Definition def : Set := {r : rel | closed_rel r /\ consistent_rel r}.

Definition spec : Set := name -> def.

Axiom Prog : spec.


Inductive Product (A B:Type) : Type := mk_Product
  { π₁ : A
  ; π₂ : B
  }.

Inductive DProduct (A:Type) (B:A -> Type) : Type := mk_DProduct
  { dπ₁ : A
  ; dπ₂ : B dπ₁
  }.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
           := match insort_arg1, insort_arg0 with
              |  Nil, i => Cons i Nil
              | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort (sort y) x
              end.

Lemma Nat_beq_refl : forall (n : natural), eqb n n = true.
Proof.
   intros.
   induction n.
   - assumption.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : lst), eq (mem (insort  y x) x) true.
Proof.
   intros.
  induction y.
  - simpl. destruct (less x n).
    + simpl. rewrite Nat_beq_refl. reflexivity.
    + simpl. rewrite IHy. apply Bool.orb_true_r.
  - simpl. lfind. Admitted.


Require Import init.

Require Export linear_base.
Require Export category_base.
Require Export ring_category.
(** This requires a commutative ring, not just any old ring.  If I ever need
one-sided modules, I'll just make a different category for those.
*)
Record ModuleObj (R : CRingObj) := make_module {
    module_V : Type;
    module_plus : Plus module_V;
    module_zero : Zero module_V;
    module_neg : Neg module_V;
    module_plus_assoc : @PlusAssoc module_V module_plus;
    module_plus_comm : @PlusComm module_V module_plus;
    module_plus_lid : @PlusLid module_V module_plus module_zero;
    module_plus_linv : @PlusLinv module_V module_plus module_zero module_neg;

    module_scalar : ScalarMult (cring_U R) module_V;
    module_scalar_id : @ScalarId (cring_U R) module_V (cring_one R) module_scalar;
    module_scalar_ldist : @ScalarLdist (cring_U R) module_V module_plus module_scalar;
    module_scalar_rdist : @ScalarRdist (cring_U R) module_V (cring_plus R) module_plus module_scalar;
    module_scalar_comp : @ScalarComp (cring_U R) module_V (cring_mult R) module_scalar;
}.
Arguments module_V {R}.
Arguments module_plus {R}.
Arguments module_zero {R}.
Arguments module_neg {R}.
Arguments module_plus_assoc {R}.
Arguments module_plus_comm {R}.
Arguments module_plus_lid {R}.
Arguments module_plus_linv {R}.
Arguments module_scalar {R}.
Arguments module_scalar_id {R}.
Arguments module_scalar_ldist {R}.
Arguments module_scalar_rdist {R}.
Arguments module_scalar_comp {R}.

Global Existing Instances module_plus module_zero module_neg module_plus_assoc
    module_plus_comm module_plus_lid module_plus_linv module_scalar
    module_scalar_id module_scalar_ldist module_scalar_rdist module_scalar_comp.

Record ModuleObjHomomorphism {R : CRingObj} (M : ModuleObj R) (N : ModuleObj R) := make_module_homomorphism {
    module_homo_f :> module_V M → module_V N;
    module_homo_plus : ∀ u v,
        module_homo_f (u + v) = module_homo_f u + module_homo_f v;
    module_homo_scalar : ∀ a v,
        module_homo_f (a · v) = a · module_homo_f v;
}.
Arguments module_homo_f {R M N}.

Theorem module_homo_zero {R : CRingObj} {M N : ModuleObj R} :
    ∀ f : ModuleObjHomomorphism M N, f 0 = 0.
Proof.
    intros f.
    rewrite <- (scalar_lanni 0).
    rewrite module_homo_scalar.
    apply scalar_lanni.
Qed.

Theorem module_homo_neg {R : CRingObj} {M N : ModuleObj R} :
    ∀ f : ModuleObjHomomorphism M N,
    ∀ v, f (-v) = -f v.
Proof.
    intros f v.
    rewrite <- scalar_neg_one.
    rewrite (@module_homo_scalar _ _ _ f).
    apply scalar_neg_one.
Qed.

Theorem module_homomorphism_eq {R : CRingObj} {M N : ModuleObj R} :
    ∀ f g : ModuleObjHomomorphism M N,
    (∀ x, f x = g x) → f = g.
Proof.
    intros [f1 plus1 scalar1] [f2 plus2 scalar2] f_eq.
    cbn in *.
    assert (f1 = f2) as eq.
    {
        apply functional_ext.
        apply f_eq.
    }
    subst f2.
    rewrite (proof_irrelevance plus2 plus1).
    rewrite (proof_irrelevance scalar2 scalar1).
    reflexivity.
Qed.

Definition module_homo_id {R : CRingObj} (L : ModuleObj R)
    : ModuleObjHomomorphism L L := make_module_homomorphism R L L
        (λ x, x)
        (λ u v, Logic.eq_refl _)
        (λ a v, Logic.eq_refl _).

Lemma module_homo_compose_plus : ∀ {R : CRingObj} {L M N : ModuleObj R}
    {f : ModuleObjHomomorphism M N} {g : ModuleObjHomomorphism L M},
    ∀ a b, f (g (a + b)) = f (g a) + f (g b).
Proof.
    intros R L M N f g a b.
    rewrite module_homo_plus.
    apply module_homo_plus.
Qed.
Lemma module_homo_compose_scalar : ∀ {R : CRingObj} {L M N : ModuleObj R}
    {f : ModuleObjHomomorphism M N} {g : ModuleObjHomomorphism L M},
    ∀ a v, f (g (a · v)) = a · (f (g v)).
Proof.
    intros R L M N f g a v.
    rewrite module_homo_scalar.
    apply module_homo_scalar.
Qed.
Definition module_homo_compose {R : CRingObj} {L M N : ModuleObj R}
    (f : ModuleObjHomomorphism M N) (g : ModuleObjHomomorphism L M)
    : ModuleObjHomomorphism L N := make_module_homomorphism R L N
        (λ x, f (g x))
        module_homo_compose_plus module_homo_compose_scalar.

Global Program Instance MODULE (R : CRingObj) : Category := {
    cat_U := ModuleObj R;
    cat_morphism M N := ModuleObjHomomorphism M N;
    cat_compose {L M N} f g := module_homo_compose f g;
    cat_id M := module_homo_id M;
}.
Next Obligation.
    apply module_homomorphism_eq.
    intros x.
    cbn.
    reflexivity.
Qed.
Next Obligation.
    apply module_homomorphism_eq.
    intros x.
    cbn.
    reflexivity.
Qed.
Next Obligation.
    apply module_homomorphism_eq.
    intros x.
    cbn.
    reflexivity.
Qed.

Section ModuleObjCategoryObjects.

Context U `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UPA : @PlusAssoc U UP,
    UPC : @PlusComm U UP,
    UPZ : @PlusLid U UP UZ,
    UPN : @PlusLinv U UP UZ UN,
    UM : Mult U,
    UO : One U,
    UMA : @MultAssoc U UM,
    UMC : @MultComm U UM,
    UMO : @MultLid U UM UO,
    UMD : @Ldist U UP UM
}.

Definition scalar_cring := make_cring
    (make_ring
        (make_rng
            U UP UZ UN UM UPA UPC UPZ UPN UMA UMD ldist_rdist
        )
        UO
        UMO
        mult_lid_rid
    )
    UMC.

Local Instance scalar_scalar_mult : ScalarMult U U := {
    scalar_mult a b := a * b
}.
Local Program Instance scalar_scalar_id : ScalarId U U.
Next Obligation.
    apply mult_lid.
Qed.
Local Program Instance scalar_scalar_ldist : ScalarLdist U U.
Next Obligation.
    apply ldist.
Qed.
Local Program Instance scalar_scalar_rdist : ScalarRdist U U.
Next Obligation.
    apply rdist.
Qed.
Local Program Instance scalar_scalar_comp : ScalarComp U U.
Next Obligation.
    apply mult_assoc.
Qed.

Definition scalar_module := make_module scalar_cring U UP UZ UN UPA UPC UPZ UPN scalar_scalar_mult scalar_scalar_id scalar_scalar_ldist scalar_scalar_rdist scalar_scalar_comp.

Context V `{
    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    VPA : @PlusAssoc V VP,
    VPC : @PlusComm V VP,
    VPZ : @PlusLid V VP VZ,
    VPN : @PlusLinv V VP VZ VN,

    SM : ScalarMult U V,
    SMO : @ScalarId U V UO SM,
    SML : @ScalarLdist U V VP SM,
    SMR : @ScalarRdist U V UP VP SM,
    SMC : @ScalarComp U V UM SM
}.

Definition vector_module := make_module scalar_cring V VP VZ VN VPA VPC VPZ VPN SM SMO SML SMR SMC.

End ModuleObjCategoryObjects.

Definition cring_module (C : CRingObj) := make_module C (cring_U C) (cring_plus C)
    (cring_zero C) (cring_neg C) (cring_plus_assoc C) (cring_plus_comm C)
    (cring_plus_lid C) (cring_plus_linv C)
    (@scalar_scalar_mult (cring_U C) (cring_mult C))
    (@scalar_scalar_id (cring_U C) (cring_mult C) (cring_one C) (cring_mult_lid C))
    (@scalar_scalar_ldist (cring_U C) (cring_plus C) (cring_mult C) (cring_ldist C))
    (@scalar_scalar_rdist (cring_U C) (cring_plus C) (cring_mult C) (cring_mult_comm C) (cring_ldist C))
    (@scalar_scalar_comp (cring_U C) (cring_mult C) (cring_mult_assoc C))
.


Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

Require Import Undecidability.TM.TM.

From Undecidability.MinskyMachines
  Require Import MM HaltTM_1_to_MM.

From Undecidability.FRACTRAN
  Require Import FRACTRAN Reductions.MM_FRACTRAN.

(* ** HaltTM_1 reduces to FRACTRAN_HALTING  *)

(* Many-one reduction from Turing machine halting to FRACTRAN (regular) halting *)
Lemma HaltTM_to_FRACTRAN_REG_HALTING : HaltTM 1 ⪯ FRACTRAN_REG_HALTING.
Proof.
  apply (reduces_transitive HaltTM_to_MM_HALTING).
  exact MM_FRACTRAN_REG_HALTING.
Qed.

(* Many-one reduction from Turing machine halting to FRACTRAN halting *)
Lemma HaltTM_to_FRACTRAN_HALTING : HaltTM 1 ⪯ FRACTRAN_HALTING.
Proof.
  apply (reduces_transitive HaltTM_to_MM_HALTING).
  exact MM_FRACTRAN_HALTING.
Qed.


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

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

Print Assumptions carry.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia Relations.

From Undecidability.MinskyMachines
  Require Import MMA mma_defs ndMM2.

From Undecidability.Shared.Libs.DLW
  Require Import utils Vec.pos Vec.vec Code.subcode Code.sss.

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Tactic Notation "vec2" hyp(v) "into" ident(x) ident(y) :=
    vec split v with x; vec split v with y; vec nil v; clear v.

Section MMA2_ndMM2.

  Notation STOPₙ := (@ndmm2_stop _).
  Notation INCₙ  := (@ndmm2_inc _).
  Notation DECₙ  := (@ndmm2_dec _).
  Notation ZEROₙ := (@ndmm2_zero _).

  Notation α := true.
  Notation β := false.

  Infix "∊" := In (at level 70).
  Infix "⊆" := incl (at level 70).

  Notation ø := vec_nil.

  Definition pos2_to_bool (p : pos 2) :=
    match p with pos0 => α | _ => β end.

  Notation "⌈ p ⌉" := (pos2_to_bool p) (at level 1, format "⌈ p ⌉").

  Definition mma2_instr_enc i (ρ : mm_instr (pos 2)) :=
    match ρ with
      | INCₐ x   => INCₙ ⌈x⌉ i (1+i) :: nil
      | DECₐ x j => DECₙ ⌈x⌉ i j :: ZEROₙ ⌈x⌉ i (1+i) :: nil
    end.

  Notation "'⟨' i , ρ '⟩₁'" := (mma2_instr_enc i  ρ) (format "⟨ i , ρ ⟩₁").

  Reserved Notation "'⟪' i , l '⟫ₗ'" (at level 1, format "⟪ i , l ⟫ₗ").

  Fixpoint mma2_linstr_enc i l :=
    match l with
      | nil  => nil
      | ρ::l => ⟨i,ρ⟩₁ ++ ⟪1+i,l⟫ₗ
    end
  where "⟪ i , l ⟫ₗ" := (mma2_linstr_enc i l).

  Fact mma2_linstr_enc_app i l m : ⟪i,l++m⟫ₗ = ⟪i,l⟫ₗ ++ ⟪length l+i,m⟫ₗ.
  Proof.
    revert i; induction l as [ | ? l IHl ]; intros ?; simpl; auto.
    rewrite app_ass, IHl; do 3 f_equal; auto.
  Qed.

  Fact mma2_linstr_enc_In i P c :
          c ∊ ⟪i,P⟫ₗ -> exists L ρ R, P = L++ρ::R /\ c ∊ ⟨length L+i,ρ⟩₁.
  Proof.
    revert i; induction P as [ | ρ P IH ]; intros i.
    + intros [].
    + simpl; rewrite in_app_iff; intros [ H | H ].
      * exists nil, ρ, P; split; auto.
      * destruct (IH (1+i)) as (l & ρ' & r & H1 & H2); auto.
        exists (ρ::l), ρ', r; split; auto.
        - simpl; f_equal; auto.
        - eq goal H2; do 2 f_equal; simpl; lia.
  Qed.

  Notation "Σ //ₙ a ⊕ b ⊦ u" := (ndmm2_accept Σ a b u) (at level 70, no associativity).

  Notation "ρ //ₐ s -1> t" := (mma_sss ρ s t) (at level 70, no associativity).
  Notation "P //ₐ r :1> s" := (sss_step (@mma_sss _) P r s)  (at level 70, no associativity).
  Notation "P //ₐ s ->> t" := (sss_compute (@mma_sss _) P s t) (at level 70, no associativity).
  Notation "P //ₐ s ~~> t" := (sss_output (@mma_sss _) P s t) (at level 70, no associativity).

  Tactic Notation "state" "rebuild" ident(s) hyp(i) hyp(a) hyp(b) :=
    set (s := (i,a##b##ø));
    change a with (vec_pos (snd s) pos0);
    change b with (vec_pos (snd s) pos1);
    change i with (fst s).

  Hint Resolve in_eq in_cons : core.

  Local Fact mma2_instr_enc_sound Σ ρ i a b j a' b' :
          ρ //ₐ (i,a##b##ø) -1> (j,a'##b'##ø)
       -> ⟨i,ρ⟩₁ ⊆ Σ
       -> Σ //ₙ a' ⊕ b' ⊦ j
       -> Σ //ₙ a  ⊕ b  ⊦ i.
  Proof.
    state rebuild s1 i a b.
    state rebuild s2 j a' b'.
    generalize s1 s2; clear s1 s2 i a b j a' b'.
    destruct 1 as [ i x v | i x k v Hv | i x k v u Hv ]; try revert Hv;
      vec2 v into a b; repeat invert pos x; simpl.
    + constructor 2 with (1+i); auto.
    + constructor 3 with (1+i); auto.
    + intros -> ?; constructor 6 with (1+i); auto.
    + intros -> ?; constructor 7 with (1+i); auto.
    + intros -> ?; constructor 4 with k; auto.
    + intros -> ?; constructor 5 with k; auto.
  Qed.

  Local Fact mma2_step_linstr_sound Σ P i a b j a' b' :
          (1,P) //ₐ (i,a##b##ø) :1> (j,a'##b'##ø)
       -> ⟪1,P⟫ₗ ⊆  Σ
       -> Σ //ₙ a' ⊕ b' ⊦ j
       -> Σ //ₙ a  ⊕ b  ⊦ i.
  Proof.
    intros (n & L & ρ & R & v & H1 & H2 & H3).
    inversion H1; subst n P; clear H1.
    inversion H2; subst v i; clear H2.
    intros H.
    apply mma2_instr_enc_sound with (1 := H3).
    apply incl_tran with (2 := H).
    rewrite mma2_linstr_enc_app; simpl.
    rewrite plus_comm.
    apply incl_appr, incl_appl, incl_refl.
  Qed.

  Variable P : list (mm_instr (pos 2)).

  Definition mma2_prog_enc := STOPₙ 0 :: ⟪1,P⟫ₗ.
  Notation ΣP := mma2_prog_enc.

  Local Lemma mma2_compute_linstr_sound i a b j a' b'  :
          (1,P) //ₐ (i,a##b##ø) ->> (j,a'##b'##ø)
       -> ΣP //ₙ a' ⊕ b' ⊦ j
       -> ΣP //ₙ a  ⊕ b  ⊦ i.
  Proof.
    intros (n & Hn); revert Hn.
    state rebuild s1 i a b.
    state rebuild s2 j a' b'.
    generalize s1 s2; clear s1 s2 i a b j a' b'.
    induction 1 as [ (i,v) | n (i,u) (j,v) (k,w) H1 H2 IH2 ]; simpl; auto.
    revert H1 H2 IH2; vec2 u into au bu; vec2 v into av bv; vec2 w into aw bw.
    simpl; intros H1 H2 IH3 H; generalize (IH3 H).
    apply mma2_step_linstr_sound with (1 := H1), incl_tl, incl_refl.
  Qed.

  Local Lemma mma2_prog_enc_stop : ΣP //ₙ 0 ⊕ 0 ⊦ 0.
  Proof. constructor 1; simpl; auto. Qed.

  Hint Resolve mma2_prog_enc_stop : core.

  Local Lemma mma2_prog_enc_sound i a b  :
          (1,P) //ₐ (i,a##b##ø) ->> (0,0##0##ø) -> ΣP //ₙ a  ⊕ b  ⊦ i.
  Proof. intros H; apply mma2_compute_linstr_sound in H; auto. Qed.

  Local Lemma mma2_prog_enc_complete a b i :
             ΣP //ₙ a ⊕ b ⊦ i -> (1,P) //ₐ (i,a##b##ø) ->> (0,0##0##ø).
  Proof.
    induction 1 as [ u H
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | b p u H H1 IH1
                   | a p u H H1 IH1 ].
    + destruct H as [ H | H ].
      * inversion H; subst u.
        exists 0; constructor 1.
      * apply mma2_linstr_enc_In in H
          as (l & [ x | x ] & r & H1 & H2); repeat invert pos x; simpl in H2.
        1-2: now destruct H2.
        1-2: now destruct H2 as [ | [] ].
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      2: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss INC with pos0.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss INC with pos1.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC S with pos0 v a.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC S with pos1 v b.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x j ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC zero with pos0 j.
      mma sss stop.
    + destruct H as [ H | H ]; try discriminate.
      apply mma2_linstr_enc_In in H
        as (l & [ x | x j ] & r & H3 & H2); repeat invert pos x; simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      apply sss_compute_trans with (2 := IH1).
      rewrite H3.
      mma sss DEC zero with pos1 j.
      mma sss stop.
  Qed.

  Theorem MMA2_ndMM2_equiv a b : (1,P) //ₐ (1,a##b##ø) ~~> (0,0##0##ø)
                             <-> ΣP //ₙ a ⊕ b ⊦ 1.
  Proof.
    split.
    + intros []; apply mma2_prog_enc_sound; auto.
    + split.
      * now apply mma2_prog_enc_complete.
      * simpl; lia.
  Qed.

End MMA2_ndMM2.

Theorem reduction : MMA2_HALTS_ON_ZERO ⪯ @ndMM2_ACCEPT nat.
Proof.
  apply reduces_dependent; exists.
  intros (P & v); vec2 v into a b.
  exists (existT _ (mma2_prog_enc P) (1,(a,b))).
  apply MMA2_ndMM2_equiv.
Qed.


Require Import Coq.Strings.Ascii Coq.Strings.String Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Coq.QArith.QArith.
Require Import Coq.ZArith.BinInt.
Require Import Rewriter.Util.Option.
Require Coq.Strings.BinaryString.
Require Coq.Strings.OctalString.
Require Coq.Strings.HexString.
Require Import Rewriter.Util.Strings.Decimal.
Require Import Rewriter.Util.Strings.Parse.Common.
Require Import Rewriter.Util.Notations.
Import ListNotations.
Import BinPosDef.
Local Open Scope option_scope.
Local Open Scope list_scope.
Local Open Scope char_scope.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope nat_scope.

Definition is_num (ch : ascii) : bool
  := match DecimalString.uint_of_char ch (Some Decimal.Nil) with Some _ => true | None => false end.

Definition is_oct_num (ch : ascii) : bool
  := match OctalString.ascii_to_digit ch with Some _ => true | None => false end.

Definition is_hex_num (ch : ascii) : bool
  := match HexString.ascii_to_digit ch with Some _ => true | None => false end.

Definition startswith_oct (s : string) : bool
  := match s with
     | String zero (String kind (String d rest))
       => (zero =? "0")%char && (kind =? "o")%char && is_oct_num d
     | _ => false
     end.

Definition startswith_hex (s : string) : bool
  := match s with
     | String zero (String kind (String d rest))
       => (zero =? "0")%char && (kind =? "x")%char && is_hex_num d
     | _ => false
     end.

Definition parse_bin_prefix : ParserAction _ := "0b".
Definition parse_oct_prefix : ParserAction _ := "0o".
Definition parse_dec_prefix : ParserAction _ := "".
Definition parse_hex_prefix : ParserAction _ := "0x".

Definition parse_digits_gen_step (base : N) : ParserAction N
  := (parse_strs
        (List.flat_map
           (fun v => if (v <? 10)%N
                     then [(String (ascii_of_N (v + N_of_ascii "0")) "", v)]
                     else [(String (ascii_of_N (v - 10 + N_of_ascii "A")) "", v);
                             (String (ascii_of_N (v - 10 + N_of_ascii "a")) "", v)])
           (List.map N.of_nat (List.seq 0 (N.to_nat base))))).

(*
Definition parse_oct_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 8.
Definition parse_dec_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 10.
Definition parse_hex_digits : ParserAction (list N)
  := Eval cbv -[ParserAction parse_alt_gen parse_impossible parse_str parse_star] in
      parse_digits_gen 16.
 *)

Definition digits_to_N (base : N) (digits : list N) : N
  := List.fold_left
       (fun so_far d => base * so_far + d)%N
       digits
       0%N.

Redirect "log" Check eq_refl : digits_to_N 10 [1;2;3;4;5;6]%N = 123456%N.

Local Coercion N.of_nat : nat >-> N.
Local Coercion Z.of_N : N >-> Z.
Local Coercion inject_Z : Z >-> Q.

Definition parse_num_gen (allow_neg : bool) {P} (base : N) (parse_prefix : ParserAction P) : ParserAction Q
  := (if allow_neg then ((strip_whitespace_around "-")?) else parse_map (fun _ => None) "")
       ;;->{ fun n v => if n:option _ then (-v)%Q else v }
       parse_prefix ;;->{ fun _ v => v }
       ((((parse_digits_gen_step base)* )
           ;;->{ fun ds decimals
                 => (digits_to_N base ds
                     + digits_to_N base decimals / base^List.length decimals)%Q }
           "." ;;->{ fun _ v => v }
           (parse_digits_gen_step base)* )
        || parse_map (digits_to_N base : _ -> Q) ((parse_digits_gen_step base)+))
       ;;->{ fun n e => match e with Some e => n * e | None => n end%Q }
       (((("e" || "E") ;;->{ fun _ v => Qpower 10 v }
         (((strip_whitespace_around "-")?)
            ;;->{ fun n v => if n:option _ then (-v)%Z else v }
            (parse_map (digits_to_N base : _ -> Z) ((parse_digits_gen_step base)+) )))
        || (("p" || "P") ;;->{ fun _ v => Qpower 2 v }
         (((strip_whitespace_around "-")?)
            ;;->{ fun n v => if n:option _ then (-v)%Z else v }
            (parse_map (digits_to_N base : _ -> Z) ((parse_digits_gen_step base)+) ))))?).

Definition parse_num (allow_neg : bool) : ParserAction Q
  := parse_num_gen allow_neg 2 parse_bin_prefix
     || parse_num_gen allow_neg 8 parse_oct_prefix
     || parse_num_gen allow_neg 10 parse_dec_prefix
     || parse_num_gen allow_neg 16 parse_hex_prefix.

Redirect "log" Check let ls := [("-1234", -(1234):Q); ("0xF", 15:Q); ("10.5", (10 + 5/10)); ("-10.5", -(10+5/10))]%Q in
                     eq_refl
                     : List.map (fun '(s, v) => ((parse_num true;;->{fun v _ => v} ε)%parse s )) ls
                       = List.map (fun '(s, v) => [(v, "")]) ls.

Inductive Qexpr := Qv (_ : Q) | Qeopp (a : Qexpr) | Qeadd (a b : Qexpr) | Qesub (a b : Qexpr) | Qemul (a b : Qexpr) | Qediv (a b : Qexpr) | Qepow (b e : Qexpr).
Coercion Qv : Q >-> Qexpr.
Declare Scope Qexpr_scope.
Delimit Scope Qexpr_scope with Qexpr.
Bind Scope Qexpr_scope with Qexpr.
Infix "^" := Qepow : Qexpr_scope.
Infix "*" := Qemul : Qexpr_scope.
Infix "+" := Qeadd : Qexpr_scope.
Infix "/" := Qediv : Qexpr_scope.
Infix "-" := Qesub : Qexpr_scope.
Notation "- x" := (Qeopp x) : Qexpr_scope.

Fixpoint eval_Qexpr (v : Qexpr) : Q
  := match v with
     | Qv x => x
     | Qeopp a => Qopp (eval_Qexpr a)
     | Qeadd a b => Qplus (eval_Qexpr a) (eval_Qexpr b)
     | Qesub a b => Qminus (eval_Qexpr a) (eval_Qexpr b)
     | Qemul a b => Qmult (eval_Qexpr a) (eval_Qexpr b)
     | Qediv a b => Qdiv (eval_Qexpr a) (eval_Qexpr b)
     | Qepow b e => let b := eval_Qexpr b in
                    let e := eval_Qexpr e in
                    let (qe, re) := Z.div_eucl (Qnum e) (Z.pos (Qden e)) in
                    (* (b^qe)*(b^(re/Qden e)) *)
                    Qmult (Qpower b qe) (Qpower b (* approximate *) (re / Z.pos (Qden e)))
     end.

Fixpoint eval_Qexpr_strict (v : Qexpr) : option Q
  := match v with
     | Qv x => Some x
     | Qeopp a => option_map Qopp (eval_Qexpr_strict a)
     | Qeadd a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qplus a b)
     | Qesub a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qminus a b)
     | Qemul a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qmult a b)
     | Qediv a b => a <- eval_Qexpr_strict a; b <- eval_Qexpr_strict b; Some (Qdiv a b)
     | Qepow b e => b <- eval_Qexpr_strict b;
                      e <- eval_Qexpr_strict e;
                      let (qe, re) := Z.div_eucl (Qnum e) (Z.pos (Qden e)) in
                      if Z.eqb re 0
                      then Some (Qpower b qe)
                      else None
     end.

Definition parse_ops {A} (ls : list (string * (A -> A -> A))) (parse : ParserAction A) : ParserAction A
  := parse ;;->{fun l fs => List.fold_left (fun v f => f v) fs l}
           (strip_whitespace_around (parse_strs ls) ;;->{fun f r l => f l r}
                                    parse)*.

Definition parse_prefix_ops {A} (ls : list (string * (A -> A))) (parse : ParserAction A) : ParserAction A
  := ((strip_whitespace_after (parse_strs ls))* )
       ;;->{fun ls v => fold_right (fun f x => f x) v ls }
       parse.

Section step.
  Context (parse_num : ParserAction Q)
          (parse : ParserAction Qexpr).

  Definition parseQexpr_gen_parens : ParserAction Qexpr
    := ("(" ;;->{fun _ v => v} strip_whitespace_around parse ;;->{fun v _ => v} ")")
       || parse_map Qv parse_num.
  Definition parseQexpr_gen_exp : ParserAction Qexpr
    := parse_ops [("^", Qepow)] parseQexpr_gen_parens.
  Definition parseQexpr_gen_opp : ParserAction Qexpr
    := parse_prefix_ops [("-", Qeopp)] parseQexpr_gen_exp.
  Definition parseQexpr_gen_mul_div : ParserAction Qexpr
    := parse_ops [("*", Qemul); ("/", Qediv)] parseQexpr_gen_opp.
  Definition parseQexpr_gen_add_sub : ParserAction Qexpr
    := parse_ops [("+", Qeadd); ("-", Qesub)] parseQexpr_gen_mul_div.
End step.

Fixpoint parse_Qexpr_fueled (parse_num : ParserAction Q) (fuel : nat) : ParserAction Qexpr
  := strip_whitespace_around
       (parseQexpr_gen_add_sub parse_num
                               (match fuel with
                                | O => parse_impossible
                                | S fuel => parse_Qexpr_fueled parse_num fuel
                                end)).

Definition parse_Qexpr_gen (parse_num : ParserAction Q) : ParserAction Qexpr := fuel (parse_Qexpr_fueled parse_num).

Definition parse_Qexpr_with_vars (vars : list (string * Q)) : ParserAction Qexpr
  := parse_Qexpr_gen
       (List.fold_right
          (fun '((s, q) : string * Q) default => default || parse_map (fun _ => q) s)%parse
          (parse_num false)
          vars).

Definition parseQexpr_arith_with_vars (vars : list (string * Q)) (s : string) : option Qexpr
  := finalize (parse_Qexpr_with_vars vars) s.
Definition parseQ_arith_with_vars (vars : list (string * Q)) (s : string) : option Q
  := option_map eval_Qexpr (parseQexpr_arith_with_vars vars s).
Definition parseZ_arith_with_vars (vars : list (string * Q)) (s : string) : option Z
  := (q <- parseQ_arith_with_vars vars s; Some (Qnum q / Z.pos (Qden q)))%Z%option.
Definition parsepositive_arith_with_vars (vars : list (string * Q)) (s : string) : option positive
  := (z <- parseZ_arith_with_vars vars s; match z with Z0 => None | Zpos p => Some p | Zneg _ => None end).
Definition parseN_arith_with_vars (vars : list (string * Q)) (s : string) : option N
  := (z <- parseZ_arith_with_vars vars s; match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N%option.
Definition parsenat_arith_with_vars (vars : list (string * Q)) (s : string) : option nat
  := (n <- parseN_arith_with_vars vars s; Some (N.to_nat n)).

Definition Q_to_Z_strict (x : Q) : option Z
  := let '(q, r) := Z.div_eucl (Qnum x) (Zpos (Qden x)) in
     if Z.eqb r 0
     then Some q
     else None.

Definition parseQ_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option Q
  := (q <- parseQexpr_arith_with_vars vars s; eval_Qexpr_strict q)%option.
Definition parseZ_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option Z
  := (q <- parseQ_arith_strict_with_vars vars s; Q_to_Z_strict q)%option.
Definition parsepositive_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option positive
  := (z <- parseZ_arith_strict_with_vars vars s; match z with Z0 => None | Zpos p => Some p | Zneg _ => None end).
Definition parseN_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option N
  := (z <- parseZ_arith_strict_with_vars vars s; match z with Z0 => Some 0 | Zpos p => Some (Npos p) | Zneg _ => None end)%N%option.
Definition parsenat_arith_strict_with_vars (vars : list (string * Q)) (s : string) : option nat
  := (n <- parseN_arith_strict_with_vars vars s; Some (N.to_nat n)).

Definition parse_Qexpr := parse_Qexpr_with_vars [].
Definition parseQexpr_arith := parseQexpr_arith_with_vars [].
Definition parseQ_arith := parseQ_arith_with_vars [].
Definition parseZ_arith := parseZ_arith_with_vars [].
Definition parsepositive_arith := parsepositive_arith_with_vars [].
Definition parseN_arith := parseN_arith_with_vars [].
Definition parsenat_arith := parsenat_arith_with_vars [].
Definition parseQ_arith_strict := parseQ_arith_strict_with_vars [].
Definition parseZ_arith_strict := parseZ_arith_strict_with_vars [].
Definition parsepositive_arith_strict := parsepositive_arith_strict_with_vars [].
Definition parseN_arith_strict := parseN_arith_strict_with_vars [].
Definition parsenat_arith_strict := parsenat_arith_strict_with_vars [].

Redirect "log" Check eq_refl : parseQexpr_arith "1 + -2" = Some (1%Q + - 2%Q)%Qexpr.


Require Import Iron.Language.Simple.Step.
Require Import Iron.Language.Simple.Ty.
Require Import Iron.Language.Simple.Exp.

(* A closed, well typed expression is either a value or can
   take a step in the evaluation. *)
Theorem progress
 :  forall x t
 ,  TYPE nil x t
 -> value x \/ (exists x', STEP x x').
Proof.
 intros.
 remember (@nil ty) as tyenv.
 induction H; subst.

 Case "XVar".
  burn.

 Case "XLam".
  left. burn.

 Case "XApp".
  right.
  assert (@nil ty = nil). burn. rip.

  destruct IHTYPE1.
  SCase "value x1".
   destruct IHTYPE2.
   SSCase "value x2".
    have (exists t x, x1 = XLam t x).
     destruct H4 as [t11].
     destruct H4 as [x11].
     subst.
    exists (substX 0 x2 x11). burn.

   SSCase "x2 steps".
    destruct H3 as [x2'].
    exists (XApp x1 x2').
    lets D: EsContext XcApp2; burn.

   SSCase "x1 steps".
    destruct H2 as [x1'].
    exists (XApp x1' x2).
    lets D: EsContext XcApp1; burn.
Qed.


(*
 * Module: ThreadProofs
 *
 * Description:
 *  Prove useful theorems about threads and the semantics of SVA-OS.
 *)

(* Load Coq Standard Library modules *)
Require Import Arith.
Require Import List.
Require Import Coq.Logic.Classical_Prop.

(* Load SVAOS specific modules *)
Require Export Semantics.

(*
 * Theorem: updateEmptyThreadList
 *
 * Description:
 *  Prove that updating an empty thread list yields an empty thread list.  I
 *  would think that this would be obvious, but apparently Coq needs to be
 *  convinced.
 *)
Theorem updateEmptyThreadList: forall (tid : nat) (t : SVAThread),
updateThread tid t nil = nil.
Proof.
intros.
destruct tid.
auto.
unfold updateThread.
auto.
Qed.

(*
 * Theorem: updateDifferentThread
 *
 * Description:
 *  Show that updating a thread ID in a thread list will return the same thread
 *  for threads with a different thread ID.
 *)
Theorem updateDifferentThread : forall (tid ntid : nat)
                                       (t : SVAThread)
                                       (tl : ThreadList),
tid <> ntid -> (getThread tid tl) = (getThread tid (updateThread ntid t tl)).
Proof.
intros.
generalize dependent tid.
generalize dependent ntid.
induction tl.

(* Case 1: Base case *)
intros.
destruct ntid.

(* Case 1a: Updating first thread *)
auto.

(* Case 1b: Updating not the first thread *)
auto.

(* Case 2: Induction case *)
intros.
destruct tid.
destruct ntid.

(* Case 2a: Get first, update first *)
contradiction H.
auto.

(* Case 2b: Get first, update not first *)
simpl.
unfold getThread.
auto.

(* Case 2c: Get not first, update not first *)
unfold getThread.
simpl.
destruct ntid.

simpl.
auto.

simpl.
apply IHtl.
contradict H.
rewrite -> H.
auto.
Qed.

(*
 * Theorem: addValidThread
 *
 * Description:
 *  Show that adding a valid thread to a valid thread list yields a valid
 *  thread list.
 *)
Theorem addValidThread : forall (t   : SVAThread)
                                (tl  : ThreadList)
                                (cfg : list nat)
                                (mmu : MMU)
                                (ds  : store),
(validThread t cfg mmu ds) /\
(validThreadList tl cfg mmu ds) -> validThreadList (t :: tl) cfg mmu ds.
Proof.
intros.
destruct H as [H1 H2].
unfold validThreadList.
split.

(* Case 1 *)
auto.

(* Case 2 *)
auto.
Qed.

(*
 * Theorem: replaceValidThread
 *
 * Description:
 *  Show that replacing a thread in a thread list with another valid thread
 *  keeps the entire thread list valid.
 *)
Theorem replaceValidThread : forall (t : SVAThread)
                                    (tl  : ThreadList)
                                    (cfg : list nat)
                                    (mmu : MMU)
                                    (ds  : store)
                                    (n   : nat),
(validThread t cfg mmu ds) /\ (validThreadList tl cfg mmu ds)
->
validThreadList (updateThread n t tl) cfg mmu ds.
Proof.
intros t tl mmu cfg ds.
induction tl.

(* Cases 1 and 2 *)
intros.
destruct H as [H1 H2].
induction n.
auto.
auto.

(* Case 3 *)
intros.
destruct H as [H1 H2].
destruct H2 as [H2 H3].
fold validThreadList in H3.

assert (validThreadList (a :: tl) mmu cfg ds).
apply addValidThread.
auto.

destruct n.
simpl.
auto.

unfold updateThread.
simpl.
fold updateThread.
auto.
Qed.

(*
 * Theorem: validThreadMMU
 *
 * Description:
 *  This theorem shows that modifying the mapping for an address that is not
 *  the PC in an SVAThread does not make the thread invalid.
 *)
Theorem validThreadMMU : forall (t : SVAThread)
                                (c1 : config)
                                (tlb : TLBTy)
                                (v p : nat),
(validConfig c1) /\
(validThread t (getCFG c1) (getCMMU c1) (getStore c1)) /\
(((canThreadSwap t) = true) -> (v <> (getThreadPC t)) /\ (v <> ((getThreadPC t) - 1)))
->
(validThread t (getCFG c1) (updateTLB v tlb (getCMMU c1)) (getStore c1)).
Proof.
intros.
destruct c1.
simpl.
simpl in H.
destruct H as [H1 H].
destruct H as [H2 H].
destruct t.
destruct b.

(* Case 1: The thread holds valid processor state *)
simpl in H.
unfold validThread in H2.
unfold validThread.
destruct H as [H3 H4].
auto.
assert ((vLookup (n9 - 1) (updateTLB v tlb m) s) = (vLookup (n9 - 1) m s)).
rewrite <- sameMMURead.
auto.
auto.
rewrite -> H.
auto.

(* Case 2: The thread holds no valid state *)
auto.
Qed.

(*
 * Theorem: validThreadStore
 *
 * Description:
 *  This theorem shows that a thread is still valid if there is a write to a
 *  virtual address other then the program counter value within the tread.
 *)
Theorem validThreadStore : forall (t : SVAThread) (c : config) (v : nat) (n : tm),
((validConfig c) /\
(validThread t (getCFG c) (getCMMU c) (getStore c)) /\
(threadInText t (getCFG c) (getCMMU c) (getTextStart c) (getTextEnd c)) /\
(((canThreadSwap t) = true) ->
  (v <> (getThreadPC t)) /\
  (v <> ((getThreadPC t) - 1)) /\
  (not (In v (getCFG c))))) /\
(textMappedOnce c)
->
(validThread t (getCFG c) (getCMMU c) (replace (getPhysical (getTLB v (getCMMU c))) n (getStore c))).
Proof.
intros.
destruct c.
simpl.
simpl in H.
destruct t.
destruct b.

(* Case 1: The thread holds valid processor state *)
simpl in H.
destruct H as [H H1].
destruct H as [H H2].
destruct H2 as [H3 H2].
destruct H2 as [H4 H2].
destruct H4 as [H10 H11].
unfold validThread.
destruct H3 as [H5 | H6].
destruct H11 as [H12 | H13].
left.
auto.
left.
auto.
destruct H11 as [H12 | H13].
left.
auto.
right.
unfold vLookup in H6.
unfold vLookup.
rewrite <- sameRead.
auto.

apply H1.
rewrite <- pred_of_minus.
split.
auto.

destruct H2 as [H8 H2].
auto.
rewrite <- pred_of_minus in H2.
apply not_eq_sym.
apply H2.

(* Case 2: The thread holds no valid processor state *)
unfold validThread.
auto.
Qed.

(*
 * Theorem: threadsAlwaysValid
 *
 * Description:
 *  Prove that if the threads in a configuration are valid, then they remain
 *  valid after a step in the semantics is taken.
 *)
Theorem threadsAlwaysValid : forall (c1 c2 : config),
(validCFG c1 (getCFG c1)) /\ (validConfig c1) /\ (textNotWriteable c1) /\
(validThreadList (getThreadList c1) (getCFG c1) (getCMMU c1) (getStore c1)) /\
(getTextStart c1) <= (getPhysical (getTLB (getPC c1) (getCMMU c1))) <= (getTextEnd c1) /\
(threadListInText (getThreadList c1)
  (getCFG c1)(getCMMU c1) (getTextStart c1) (getTextEnd c1)) /\
(textMappedOnce c1) /\
(c1 ==> c2)
->
(validThreadList (getThreadList c2) (getCFG c2) (getCMMU c2) (getStore c2)).
Proof.
intros.
destruct H as [vcfg H].
destruct H as [H1 H2].
destruct H2 as [H2 H3].
destruct H3 as [H4 H3].
destruct H3 as [H9 H3].
destruct H3 as [HA H3].
destruct H3 as [HE H3].
destruct H3.
destruct c.

(* Case 1 *)
auto.

(* Case 2 *)
auto.

(* Case 3 *)
simpl.
simpl in H1.
simpl in H2.
simpl in H4.
simpl in H9.
simpl in HA.
destruct H as [H5 H6].
destruct H6 as [H6 H7].
destruct H7 as [H7 H8].
induction tl.

(* Case 3a *)
auto.

(* Case 3b *)
destruct HA as [HA HB].
fold threadListInText in HB.
unfold validThreadList.
split.
destruct a.
destruct b.

(* Case 3ba: The first thread can be swapped *)
unfold threadInText in HA.
destruct HA as [HA HC].
destruct HC as [HC | HC].
unfold validThread.
left.
auto.

assert (n <> n0).
contradict HA.
rewrite <- HA.
contradict HA.

assert (~ canWrite n MMU).
apply H2.
auto.
contradiction.

assert (CFG = (getCFG (C MMU DS Reg PC SP CFG cs ce st asid tid ntid
          ((Thread true n0 i i0) :: tl) gvs gve gl th))).
auto.
assert (MMU = (getCMMU (C MMU DS Reg PC SP CFG cs ce st asid tid ntid
          ((Thread true n0 i i0) :: tl) gvs gve gl th))).
auto.
assert (DS = (getStore (C MMU DS Reg PC SP CFG cs ce st asid tid ntid
          (Thread true n0 i i0 :: tl) gvs gve gl th))).
auto.
rewrite -> H0.
rewrite -> H3.
rewrite -> H10.
apply validThreadStore.
simpl.
split.
split.
auto.
split.
unfold validThreadList in H4.
destruct H4.
unfold validThread in H4.
apply H4.
split.
auto.
split.
auto.
split.
contradict H7.
rewrite -> H7.
apply H2.
rewrite <- pred_of_minus.
unfold threadInText in HA.
destruct HA as [HA HD].
apply HC.
simpl in IHtl.
simpl in vcfg.
unfold validCFG in vcfg.
apply cfg23 in vcfg.
simpl in vcfg.
unfold validCFG3 in vcfg.
assert ((In n CFG) -> (cs <= getPhysical (getTLB n MMU) <= ce)).
apply vcfg.
contradict H12.
assert (cs <= getPhysical (getTLB n MMU) <= ce).
apply vcfg.
auto.
assert (not (canWrite n MMU)).
apply H2.
auto.
contradiction.
auto.

(* Case 3bb: The first thread cnnot be swapped *)
auto.
fold validThreadList.
apply IHtl.
auto.
unfold validThreadList in H4.
destruct H4.
fold validThreadList in H0.
auto.
auto.
auto.

(* Case 4 *)
auto.

(* Case 5 *)
auto.

(* Case 6 *)
auto.

(* Case 7 *)
simpl.
simpl in H1.
simpl in H2.
simpl in H4.
simpl in H9.
simpl in HA.
destruct H as [H10 H].
destruct H as [H11 H].
destruct H as [H12 H].
destruct H as [H13 H].
destruct H as [H14 H].
destruct H as [H15 H].
destruct H as [H16 H].
induction tl.

(* Case 7a: Show that it's true for an empty thread list *)
auto.

(* Case 7b: Show that it's true for an existing list *)
unfold validThreadList.
split.

(* Case 7b1: Show that it's true for the first thread in the list *)
unfold validThreadList in H4.
destruct H4.
fold validThreadList in H3.
destruct a.
destruct b.

(* Case 7b1a: Show that it's true for the first thread in the list if it's swappable *)

(* Detour: Show that n <> v *)
assert (n <> v).
unfold threadListInText in HA.
destruct HA as [HB HA].
fold threadListInText in HA.
unfold threadInText in HB.
simpl in HB.
destruct HB as [HB HD].
rewrite -> H12 in H14.
contradict HB.
rewrite -> HB.
contradict HB.
destruct HB.
destruct H14.
contradict H4.
apply lt_not_le.
auto.
contradict H5.
apply lt_not_le.
auto.

(* Detour: Show that v <> (n - 1) *)
unfold threadListInText in HA.
destruct HA as [HB HA].
fold threadListInText in HA.
unfold threadInText in HB.
destruct HB as [HB HC].
destruct HC as [valid1 | valid2].
unfold validThread.
left.
auto.

assert (v <> (pred n)).
destruct HB as [HD HB].
rewrite -> H12 in H14.

contradict valid2.
rewrite <- valid2.
contradict valid2.
destruct valid2.
destruct H14.
contradict H7.
apply le_not_lt.
auto.

contradict H6.
apply lt_not_le.
auto.

(* Back from detour: Prove case 7b1b *)
assert (CFG = (getCFG (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th))).
auto.
assert (MMU = (getCMMU (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th))).
auto.
assert (DS = (getStore (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th))).
auto.
rewrite -> H6.
rewrite -> H7.
rewrite -> H8.
apply validThreadMMU.
auto.
simpl.
split.
apply H1.
unfold validThread in H0.
split.
apply H0.
intro.
split.
apply not_eq_sym.
apply H4.

(* Handle the case where we need that v <> n - 1 *)
rewrite <- pred_of_minus.
auto.

(* Case 7b1b: Show that it's true if the first thread is not swappable *)
auto.

(* Case 7b2 *)
fold validThreadList.
apply IHtl.
auto.
destruct H4.
fold validThreadList in H3.
auto.
destruct HA.
fold threadListInText in H3.
auto.
auto.

(* Case 8 *)
auto.
auto.

(* Case 9 *)
auto.
auto.

(* Case 10 *)
auto.

(* Case 11 *)
auto.

(* Case 12 *)
simpl.
apply replaceValidThread.
simpl in H1.
simpl in H2.
simpl in H4.
destruct H as [H5 H6].
destruct H6 as [H6 H7].
destruct H7 as [H7 H8].
split.
unfold validThread.
auto.
auto.

(* Case 13 *)
simpl.
apply replaceValidThread.
split.
destruct getThread.
destruct getThread.
unfold threadOnCPU.
unfold validThread.
right.
simpl.
rewrite <- minus_n_O.
unfold vLookup.
unfold vaLookup in H.
destruct H as [H17 H].
destruct H as [H18 H].
auto.
apply replaceValidThread.
split.
destruct getThread.
unfold threadOffCPU.
unfold validThread.
auto.
auto.

(* Case 14 *)
simpl.
simpl in HA.
apply replaceValidThread.
split.
unfold validThread.
auto.
auto.

(* Case 15 *)
simpl.
simpl in HA.
simpl in H4.
simpl in H9.
simpl in H1.
apply replaceValidThread.
split.
unfold validThread.
auto.
auto.

(* Case 16 *)
auto.

(* Case 17 *)
simpl.
unfold pushSIC.
apply replaceValidThread.
split.

(* Case 17a *)
unfold validThread.
auto.

(* Case 17b *)
auto.

(* Case 18 *)
simpl.
unfold popSIC.
apply replaceValidThread.
split.

(* Case 18a *)
simpl.
auto.

(* Case 18b *)
auto.

(* Case 19 *)
simpl.
unfold pushIC.
apply replaceValidThread.
split.

(* Case 19a *)
unfold validThread.
auto.

(* Case 19b *)
auto.
Qed.

(*
 * Theorem: getThreadExtraList
 *
 * Description:
 *  Prove that fetching a thread from the second element on in a list is the
 *  same as fetching the element from the list without its first element.
 *)
Theorem getThreadExtraList: forall (n : nat) (t : SVAThread) (tl : ThreadList),
(getThread (S n) (t :: tl)) = (getThread n tl).
Proof.
intros.
unfold getThread.
simpl.
auto.
Qed.

(*
 * Theorem: getThreadImpliesIn
 *
 * Description:
 *  Prove that if a thread fetched from a thread list is in that thread list,
 *  then it is in a list with an additional element on the front of the thread
 *  list.
 *)
Theorem getThreadImpliesIn: forall (n : nat) (t : SVAThread) (tl : ThreadList),
In (getThread n tl) tl -> In (getThread n tl) (t :: tl).
Proof.
intros.
generalize dependent t.
generalize dependent n.
induction tl.

(* Case 1: Base case *)
contradiction.

(* Case 2: Induction case *)
intros.
destruct n.

unfold getThread.
simpl.
auto.

unfold getThread.
simpl.
unfold getThread in H.
simpl in H.
destruct H.

right.
left.
auto.

right.
right.
auto.
Qed.

(*
 * Theorem: updateThreadStillThere
 *
 * Description:
 *  Prove that if a thread with a particular thread ID is in a thread list,
 *  then there is still a thread for that ID after any thread in the list is
 *  updated to have a new value.
 *)
Theorem updateThreadStillThere: forall (t : SVAThread)
                                       (tl : ThreadList)
                                       (tid ntid : nat),
(In (getThread tid tl) tl) /\ (tid < length tl) ->
(In (getThread tid (updateThread ntid t tl)) (updateThread ntid t tl)).
Proof.
intros.
destruct H as [H1 H2].
assert (tid < length (updateThread ntid t tl)).
rewrite <- updateMaintainsListLength.
auto.
apply nth_In.
auto.
Qed.

(*
 * Theorem: threadIDsAlwaysValid
 *
 * Description:
 *  Show that the relationship between the current thread ID and the next
 *  thread ID always holds.
 *)
Theorem threadIDsAlwaysValid: forall (c1 c2 : config),
(c1 ==> c2) /\ (validThreadIDs c1) -> (validThreadIDs c2).
Proof.
intros.
destruct H as [H1 H2].
destruct H1.

(* Case 1 *)
destruct c.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.

(* Case: svaInitStack *)
simpl.
simpl in H2.
rewrite <- updateMaintainsListLength.
split.
apply H2.
apply H.

(* Case: svaSwap *)
simpl.
rewrite <- updateMaintainsListLength.
rewrite <- updateMaintainsListLength.
split.
apply H.
apply H2.

(* Case: trap *)
simpl.
rewrite <- updateMaintainsListLength.
auto.

(* Case: iret *)
simpl.
rewrite <- updateMaintainsListLength.
auto.

(* Case: svaRegisterTrap *)
auto.

(* Case: svaSaveIcontext *)
simpl.
unfold pushSIC.
rewrite <- updateMaintainsListLength.
auto.

(* Case: svaLoadIContext *)
simpl.
unfold popSIC.
rewrite <- updateMaintainsListLength.
auto.

(* Case: svaPushFunction *)
simpl.
unfold pushIC.
rewrite <- updateMaintainsListLength.
auto.
Qed.

(*
 * Theorem: threadAlwaysThere
 *
 * Description:
 *  This theorem shows that if the current thread is in the thread list, it is
 *  still there after a step is taken in the semantics.
 *)
Theorem threadAlwaysThere: forall (c1 c2 : config),
(c1 ==> c2) /\
(validThreadIDs c1) /\
(In (getThread (getCurrThread c1) (getThreadList c1)) (getThreadList c1))
->
(In (getThread (getCurrThread c2) (getThreadList c2)) (getThreadList c2)).
Proof.
intros.
destruct H as [H1 H2].
destruct H2 as [H3 H2].
destruct H1.
destruct c.
simpl in H2.

(* Cases 1 - 13 *)
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.

(* Case 14: svaInitStack *)
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
auto.
apply H3.

(* Case 15: svaSwap *)
auto.

(* Case 16: trap *)
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
apply updateThreadStillThere.
split.
apply nth_In.
apply H.
apply H.
rewrite <- updateMaintainsListLength.
apply H.
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
auto.
apply H3.

(* Case 17: iret *)
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
auto.
apply H3.

(* Case 18: svaRegisterTrap *)
auto.

(* Case 19: svaSaveIcontext *)
unfold pushSIC.
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
auto.
apply H3.

(* Case 20: svaLoadIcontext *)
unfold popSIC.
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
auto.
apply H3.

(* Case 21: svaPushFunction *)
unfold pushSIC.
simpl.
simpl in H2.
apply updateThreadStillThere.
split.
auto.
apply H3.
Qed.