From isla Require Import opsem.

Definition a7418 : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 39%Z (Val (Val_Symbolic 38%Z) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 44%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (ZeroExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffc%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 48%Z (Unop (Extract 63%N 0%N) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop Concat [Manyop Concat [Manyop Concat [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Bvnot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 48%Z) Mk_annot) (Unop (Extract 63%N 0%N) (Val (Val_Bits (BV 128%N 0x3f%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Val (Val_Symbolic 48%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Val (Val_Symbolic 44%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot; Ite (Binop (Eq) (Unop (SignExtend 64%N) (Val (Val_Symbolic 48%Z) Mk_annot) Mk_annot) (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvadd) [Unop (SignExtend 64%N) (Val (Val_Symbolic 39%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 128%N 0xfffffffffffffffffffffffffffffffc%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 128%N 0x1%Z)) Mk_annot] Mk_annot) Mk_annot) (Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot) (Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
  Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
  Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
  Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 61%Z) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
  Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
  Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  tnil
.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23eqsynthconj2 : forall  (lv0 : natural), (@eq natural (Succ lv0) (plus (Succ lv0) Zero)).
Admitted.
QuickChick conj23eqsynthconj2.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e291m19_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import propInv5.
Local Open Scope Z.

Definition _timer1 :=36000.
Definition _timer0 := _timer1-1.
Definition _logvar := ON.
Definition _hands0 :=
 (make (of_Z (_timer1+1)) ON).

Definition _hands1 := _hands0.[of_Z _timer1 <- _logvar].
Definition _dryer0 := make (of_Z (_timer1+1)) ON.
Definition _dryer1 := _dryer0.[of_Z _timer1 <- _dryer0.[of_Z (_timer1-1)]].
Definition _ctrlState0 := (make (of_Z (_timer1+1)) ctrlDrying).
Definition _ctrlState1 := _ctrlState0.[of_Z _timer1 <- _ctrlState0.[of_Z (_timer1-1)]].
Definition _ctrlTimer0 :=0.
Definition _ctrlTimer1 := _ctrlTimer0 + 1.
Definition _dryer2 := _dryer1.[of_Z _timer1 <- ON].
Definition _ctrlState2 := _ctrlState1.[of_Z _timer1 <- ctrlDrying].
Definition _ctrlTimer2 := 0.

Theorem proof5_5 :
 exists hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 ctrlState2 ctrlTimer2
(logvar : bool),
 ~((startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 logvar) /\
    ctrlState1.[of_Z timer1]<>ctrlWaiting /\ ctrlState1.[of_Z timer1]=ctrlDrying /\ hands1.[of_Z timer1]=ON /\ ctrlTimer2=0 /\
 ctrlState2=ctrlState1.[of_Z timer1 <- ctrlDrying] /\ ctrlTimer2<10
 ->
    (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1)).

Proof.
exists _hands0.
exists _hands1.
exists _dryer0.
exists _dryer1.
exists _ctrlState0.
exists _ctrlState1.
exists _ctrlTimer0.
exists _ctrlTimer1.
exists _timer0.
exists _timer1.
exists _ctrlState2.
exists _ctrlTimer2.
exists _logvar.
unfold not.
intros.
assert (Hcond :
 (startnewloop _hands0 _hands1 _dryer0 _dryer1 _ctrlState0 _ctrlState1 _ctrlTimer0 _ctrlTimer1 _timer0 _timer1 _logvar) /\
    _ctrlState1.[of_Z _timer1]<>ctrlWaiting /\ _ctrlState1.[of_Z _timer1]=ctrlDrying /\ _hands1.[of_Z _timer1]=ON /\
     _ctrlTimer2=0 /\  _ctrlState2=_ctrlState1.[of_Z _timer1 <- ctrlDrying] /\ _ctrlTimer2<10).

split.
split.
split.
(*proving propInv for timer0*)
unfold propInv5.
intros.
unfold _timer0 in H0.
unfold _timer1 in H0.
elimtype False.
auto with zarith.
(*proving extraInv for timer0*)
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
unfold _timer0.
unfold _timer1.
auto with zarith.
split.
unfold _ctrlTimer0.
auto with zarith.
split.
intros.
right.
unfold _ctrlState0.
apply get_make.
intros.
split.
auto with zarith.
split.
unfold _hands0.
apply get_make.
split.
unfold _dryer0.
apply get_make.
intros.
elimtype False.
unfold _ctrlTimer0 in H1.
auto with zarith.
split.
symmetry.
apply Zeq_plus_swap.
reflexivity.
repeat split.
repeat split.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
rewrite get_make.
discriminate.
auto.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
rewrite get_make.
reflexivity.
auto.

(*proving negating requirement*)
apply H in Hcond.
inversion_clear Hcond.
unfold propInv5 in H0.
specialize (H0 (_timer1-(36000-1))).
assert (Hpremise : (0<(_timer1-(36000-1)) /\ (_timer1-(36000-1))<=(_timer1-(36000-1)) /\
 _dryer1.[of_Z (_timer1-(36000-1))]=ON)).
unfold _timer1.
auto with zarith.
apply H0 in Hpremise.
elim Hpremise.
intros.
inversion_clear H2.
inversion_clear H4.
inversion_clear H5.
replace _dryer1.[of_Z x] with _dryer0.[of_Z x] in H6.
unfold _dryer0 in H6.
rewrite get_make in H6.
contradict H6.
discriminate.
auto.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e130m5_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e206m5_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From QuickChick Require Import QuickChick. Import QcNotation.
From Coq Require Import Bool ZArith List. Import ListNotations.
From ExtLib Require Import Monad.
From ExtLib.Data.Monads Require Import OptionMonad.
Import MonadNotation.

From STLC Require Import Impl Spec.

Derive (Arbitrary, Fuzzy) for Typ.

Derive (Sized, Fuzzy) for nat.

Derive (Fuzzy) for bool.

Derive (Arbitrary, Fuzzy) for Expr.

(* ManualExtract Expr.
ManualExtract Typ. *)

(*|toggle|*)Axiom num_tests : nat. Extract Constant num_tests => "max_int".

Definition test_prop_SinglePreserve (e: Expr) :=
    prop_SinglePreserve e.

Definition test_prop_SinglePreserve_fuzzer :=
    fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_SinglePreserve.

(*! FuzzChick test_prop_SinglePreserve (test_prop_SinglePreserve_fuzzer tt). *)

Definition test_prop_MultiPreserve (e: Expr) :=
    prop_MultiPreserve e.

Definition test_prop_MultiPreserve_fuzzer :=
    fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_MultiPreserve.

(*! FuzzChick test_prop_MultiPreserve (test_prop_MultiPreserve_fuzzer tt). *)


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e213m3_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e213m3_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From Coq Require Import
     Arith
     String.

From ExtLib Require Import
     Data.String
     Structures.Monad
     Core.RelDec
     Data.Map.FMapAList.

From Paco Require Import paco.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts
     Eq.Rutt
     Events.MapDefault
     Events.State
     Events.StateFacts.

From ITree.Extra Require Import
     ITrace.ITraceDefinition
     ITrace.ITraceFacts
     ITrace.ITracePreds
     Dijkstra.DelaySpecMonad
     Dijkstra.DijkstraMonad
     Dijkstra.TracesIT
     Dijkstra.StateSpecT.

Import Monads.
Import MonadNotation.
#[local] Open Scope monad_scope.

Definition env := alist string nat.

Variant StateE : Type -> Type :=
  | GetE : string -> StateE nat
  | PutE : string -> nat -> StateE unit
.

Variant IO : Type -> Type :=
  | Read : IO nat
  | Write : nat -> IO unit
.
Notation stateiotree A := (itree (StateE +' IO) A).

Definition StateIOSpec : Type -> Type := StateSpecT env (TraceSpec IO).

Definition SIOSpecOrder := StateSpecTOrder env (TraceSpec IO).

Definition SIOSpecOrderLaws := StateSpecTOrderedLaws env (TraceSpec IO).

Definition SIOSpecEq  := StateSpecTEq env (TraceSpec IO).

Definition SIOObs := EffectObsStateT env (TraceSpec IO) (itree IO).

Definition SIOMorph :=MonadMorphimStateT env (TraceSpec IO) (itree IO).

Definition verify_cond {A : Type} := DijkstraProp (stateT env (itree IO)) StateIOSpec SIOObs A.

(*Predicate on initial state and initial log*)
Definition StateIOSpecPre : Type := env -> ev_list IO -> Prop.
(*Predicate on final log and possible return value*)
Definition StateIOSpecPost (A : Type) : Type := itrace IO (env * A) -> Prop.

Program Definition encode {A} (pre : StateIOSpecPre) (post : StateIOSpecPost A) : StateIOSpec A :=
  fun s log p => pre s log /\ (forall tr, post tr -> p tr).

Section PrintMults.
  Variable X Y : string.
  Context (HXY : X <> Y).
  (*this part has some pretty basic errors*)
  Variant write_next_mult  (n : nat) : forall B, IO B -> B -> Prop :=
    | wnm : write_next_mult n unit (Write n) tt.

  Definition wnm_ev (next : nat) A  (io : IO A) (_ : A) : forall B, IO B -> B -> Prop :=
    match io with
    | Write n => write_next_mult (next + n)
    | Read => bot3 end.

  Variant writes_n (n : nat) : forall A, IO A -> A -> Prop :=
    | wn : writes_n n unit (Write n) tt.

  Definition mults_n {R : Type} (n : nat) (tr : itrace IO R) := state_machine (wnm_ev n) bot4 (writes_n 0) bot1 tr.

  CoFixpoint mults_of_n_from_m {R : Type} (n m : nat) : itrace IO R:=
    Vis (evans unit (Write m) tt) (fun _ => mults_of_n_from_m n (n + m) ).

  Definition mults_of_n {R : Type} (n : nat) : itrace IO R :=
    mults_of_n_from_m n 0.

  Definition print_mults_pre : StateIOSpecPre :=
    fun s log => log = nil /\  lookup_default Y 0 s = 0.

  (*Is there going to be a problem introducing k?*)
  Definition print_mults_post : StateIOSpecPost unit :=
    fun tr => exists n k, (tr ≈ Vis (evans _ Read n) k /\ (mults_of_n n) ≈ (k tt))%itree.

  Definition print_mults : stateiotree unit :=
   x <- trigger Read;;
   trigger (PutE X x);;
   ITree.iter ( fun _ : unit =>
    y <- trigger (GetE Y);;
    trigger (Write y);;
    x <- trigger (GetE X);;
    trigger (PutE Y (y + x));;
    Ret (inl tt)
   ) tt.

  Definition add (V : string) (v : nat) (s : env) : env :=
    alist_add _ V v s.

  Definition handleIOStateE (A : Type) (ev : (StateE +' IO) A) : stateT env (itree IO) A :=
    fun s =>
    match ev with
    | inl1 ev' =>
      match ev' with
      | GetE V => Ret (s, lookup_default V 0 s)
      | PutE V v => Ret (Maps.add V v s, tt) end
    | inr1 ev' => Vis ev' (fun x => Ret (s,x) )
    end.

  Ltac unf_res := unfold resum, ReSum_id, id_, Id_IFun in *.

  Lemma lookup_eq : forall (s : env) (x : string) (v d : nat),
    lookup_default x d (Maps.add x v s) = v.
  Proof.
    intros. assert (Maps.mapsto x v (Maps.add x v s) ).
    { apply Maps.mapsto_add_eq; try reflexivity. }
    eapply Maps.mapsto_lookup in H. unfold lookup_default. rewrite H. auto.
  Qed.

  Lemma lookup_nin : forall (x : string) (s : env), (forall v : nat, ~ Maps.mapsto x v s) -> Maps.lookup x s = None.
  Proof.
    intros. red in s. red in s. generalize dependent x. induction s; intros; auto.
    - cbn. destruct a as [y v]. destruct (Strings.String.string_dec x y).
      + subst. exfalso. eapply H. red. cbn. red. cbn.
        rewrite RelDec.rel_dec_eq_true; auto. apply RelDec_Correct_string.
      + rewrite RelDec.rel_dec_neq_false; auto; try apply RelDec_Correct_string.
        unfold Maps.lookup in IHs. cbn in *. apply IHs; auto. intros.
        intro Hcontra. eapply H. red. cbn.
        rewrite RelDec.rel_dec_neq_false; eauto; try apply RelDec_Correct_string.
  Qed.

  Lemma lookup_neq : forall (s : env) (x y: string) (v d: nat), x <> y ->
                                                          lookup_default x d (Maps.add y v s)  = lookup_default x d s.
  Proof.

    intros.
    destruct (classic (exists v', Maps.mapsto x v' s)).
    - destruct H0 as [v' Hv'].
      assert (Maps.mapsto x v' (Maps.add y v s)).
      {
        eapply Maps.mapsto_add_neq in Hv'; eauto.
      }
      apply Maps.mapsto_lookup in H0. apply Maps.mapsto_lookup in Hv'. unfold lookup_default.
      rewrite Hv'. rewrite H0. auto.
    - assert (forall v',~ Maps.mapsto x v' s).
      { intros v' Hc. apply H0. exists v'. auto. }
      clear H0. apply lookup_nin in H1 as Hs. unfold lookup_default.
      rewrite Hs.
      assert (forall v', ~Maps.mapsto x v' (Maps.add y v s)).
      {
        intros v' Hcontra. apply Maps.mapsto_add_neq in Hcontra; auto.
        eapply H1; eauto.
      }
      apply lookup_nin in H0 as Hs'. rewrite Hs'. auto.
  Qed.

  Ltac prove_arg H :=
    let H' := fresh H in
    match type of H with ?P -> _ => assert (H' : P); try (specialize (H H'); clear H') end.

  Lemma print_mults_sats_spec :
    verify_cond (encode print_mults_pre print_mults_post) (interp_state handleIOStateE print_mults).
  Proof.
    repeat red. simpl. intros s log [p Hp] [Hpre H'] b Href. simpl in *.
    apply H'. clear H'. unfold print_mults_pre in Hpre.
    destruct Hpre as [Hlog Henv]. subst.
    unfold print_mults_post. setoid_rewrite append_nil.
    unfold print_mults in Href. setoid_rewrite interp_state_bind in Href.
    setoid_rewrite interp_state_trigger in Href.
    setoid_rewrite bind_vis in Href.
    apply trace_refine_vis in Href as Hbhd. basic_solve.
    rewrite Hbhd in Href. setoid_rewrite Hbhd.
    destruct e0.
    2 : destruct ev; assert void; try apply Hempty; try constructor; contradiction.
    assert (A = nat).
    {
      destruct ev; auto. cbn in *. pinversion Href. ddestruction; subst.
      cbn in *. inversion H1; auto.
    }
    subst. rename ans into n. exists n.
    match type of Href with
    _ ⊑ Vis _ ?k => remember k as kp end.
    exists k0. split.
    {
      simpl in Href. clear Henv. unf_res.
      pinversion Href. ddestruction; subst. inversion H1. ddestruction; subst. reflexivity.
    }
    clear Hp p Hbhd b.
    assert (k0 tt ⊑ kp n).
    { clear Heqkp. pinversion Href. ddestruction; subst.
      unfold resum, ReSum_id, id_, Id_IFun in *. inversion H1. ddestruction; subst.
      assert (RAnsRef IO unit nat (evans nat Read n) tt Read n); auto with itree.
      apply H6 in H. pclearbot. auto.
    }
    clear Href ev. subst. rewrite bind_ret_l in H. simpl in *. rewrite interp_state_bind in H.
    rewrite interp_state_trigger in H. simpl in *. rewrite bind_ret_l in H.
    simpl in *.
    specialize (@interp_state_iter' (StateE +' IO) ) as Hiter.
    unfold state_eq in Hiter. rewrite Hiter in H. clear Hiter.

    remember (Maps.add X n s) as si.
    assert (si = alist_add RelDec_string X n s); try (subst; auto; fail).
    rewrite <- H0 in H. clear H0.
    unfold mults_of_n.
    remember 0 as next_to_write.

    (*set up invariant for the coind hyp*)
    assert (lookup_default Y 0 si = next_to_write).
    { subst. rewrite lookup_neq; auto. }
    assert(lookup_default X 0 si = n).
    { subst. apply lookup_eq. }
    clear Heqsi Heqnext_to_write Henv s.
    generalize dependent si.
    remember (k0 tt) as tr. clear Heqtr k0.
    generalize dependent tr.
    generalize dependent next_to_write.

    pcofix CIH.
    (*This coinductive hypothesis looks good*)
    intros.
    rename H1 into HX.
    pfold. red.
    (*should be able to learn that observe tr is what we need*)

    (*This block shows how to proceed through the loop body*)
    rename H0 into H.
    unfold Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree in H.
    rewrite unfold_iter in H.
    match type of H with _ ⊑ ITree.bind _ ?k0 => remember k0 as k end.

    setoid_rewrite bind_bind in H.
    rewrite bind_trigger in H.
    setoid_rewrite interp_state_vis in H.
    cbn in H. rewrite bind_ret_l in H. rewrite tau_eutt in H.
    setoid_rewrite bind_trigger in H.
    rewrite interp_state_vis in H. cbn in H.
    rewrite bind_vis in H.
    rewrite bind_vis in H.
    setoid_rewrite bind_ret_l in H.
    unf_res.
    punfold H. red in H. cbn in *.
    dependent induction H.
    2:{ rewrite <- x. constructor; auto. eapply IHruttF; eauto; reflexivity. }
    inversion H; ddestruction; subst; ddestruction; try contradiction.
    subst. specialize (H0 tt tt).
    destruct a.
    prove_arg H0; auto with itree. pclearbot.
    match type of H0 with
      paco2 _ bot2 ?tr ?t => assert (Hk1 : tr ⊑ t); auto end.
    rewrite <- x. constructor; auto.
    intros [].
    clear x tr. right.
    remember (lookup_default X 0 si) as n.
    remember (lookup_default Y 0 si) as m.
    eapply CIH with (Maps.add Y (n + m) si); try apply lookup_eq.
    2: { rewrite lookup_neq; subst; auto. }
    rewrite tau_eutt in Hk1. setoid_rewrite bind_trigger in Hk1.
    setoid_rewrite interp_state_vis in Hk1. cbn in *.
    rewrite bind_ret_l in Hk1. rewrite tau_eutt in Hk1.
    setoid_rewrite bind_vis in Hk1.
    setoid_rewrite interp_state_vis in Hk1. cbn in *.
    rewrite bind_ret_l in Hk1. rewrite bind_ret_l in Hk1.
    rewrite tau_eutt in Hk1. cbn in *.
    rewrite interp_state_ret in Hk1. rewrite bind_ret_l in Hk1.
    cbn in *.
    rewrite tau_eutt in Hk1.
    unfold Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree.
    match goal with
      H : _ ⊑ ITree.iter _ (?s1, _) |- _ ⊑ ITree.iter _ (?s2, _) =>
      enough (Hseq : s2 = s1) end; try rewrite Hseq; auto.
    subst. rewrite Nat.add_comm. auto.
  Qed.

End PrintMults.


From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

From Coq Require Import Sorting.Permutation.
From Coq Require Import Morphisms.
From Coq Require Import Program.Tactics.
From Coq Require Import Omega.

From Coq Require Import FSets.FMapPositive.
From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import NLustre.NLOrdered.
From Velus Require Import IndexedStreams.
From Velus Require Import CoindStreams.
From Velus Require Import CoindToIndexed.

From Velus Require Import CoreExpr.CESemantics.
From Velus Require Import NLustre.NLIndexedSemantics.
From Velus Require Import NLustre.NLCoindSemantics.

From Coq Require Import Setoid.

Module Type NLCOINDTOINDEXED
       (Import Ids     : IDS)
       (Import Op      : OPERATORS)
       (Import OpAux   : OPERATORS_AUX          Op)
       (Import CESyn   : CESYNTAX               Op)
       (Import Syn     : NLSYNTAX           Ids Op       CESyn)
       (Import IStr    : INDEXEDSTREAMS         Op OpAux)
       (Import CStr    : COINDSTREAMS           Op OpAux)
       (Import CIStr   : COINDTOINDEXED         Op OpAux           CStr IStr)
       (Import Ord     : NLORDERED          Ids Op       CESyn Syn)
       (CESem          : CESEMANTICS        Ids Op OpAux CESyn     IStr)
       (Indexed        : NLINDEXEDSEMANTICS Ids Op OpAux CESyn Syn IStr Ord CESem)
       (CoInd          : NLCOINDSEMANTICS   Ids Op OpAux CESyn Syn CStr Ord).

  Section Global.

    Variable G : global.

    (** * SEMANTICS CORRESPONDENCE *)

    (** ** Variables *)

    Corollary sem_vars_impl:
      forall H xs xss,
      Forall2 (sem_var H) xs xss ->
      CESem.sem_vars (tr_history H) xs (tr_Streams xss).
    Proof.
      unfold CESem.sem_vars, IStr.lift'.
      induction 1 as [|? ? ? ? Find];
        simpl; intro; constructor; auto.
      - apply sem_var_impl; auto.
      - apply IHForall2.
    Qed.
    Hint Resolve sem_vars_impl.

    (** ** Semantics of exps *)

    (** State the correspondence for [exp].
        Goes by induction on the coinductive semantics of [exp]. *)
    Hint Constructors CESem.sem_exp_instant.
    Lemma sem_exp_impl:
      forall H b e es,
        CoInd.sem_exp H b e es ->
        CESem.sem_exp (tr_Stream b) (tr_history H) e (tr_Stream es).
    Proof.
      unfold tr_Stream.
      induction 1 as [? ? ? ? Hconst
                            |? ? ? ? ? Hvar
                            |? ? ? ? ? ? ? ? ? ? Hvar Hwhen
                            |? ? ? ? ? ? ? ? ? Hlift1
                            |? ? ? ? ? ? ? ? ? ? ? ? ? Hlift2]; intro n.
      - rewrite const_spec in Hconst; rewrite Hconst.
        destruct (tr_Stream b n); eauto.
      - apply sem_var_impl in Hvar; eauto.
      - specialize (IHsem_exp n).
        apply sem_var_impl in Hvar;
          unfold tr_Stream, IStr.sem_var, IStr.lift in Hvar.
        specialize (Hvar n); simpl in *.
        rewrite when_spec in Hwhen.
        destruct (Hwhen n)
          as [(Hes & Hxs & Hos)
             |[(? & ? & Hes & Hxs & ? & Hos)
              |(? & ? & Hes & Hxs & ? & Hos)]];
          rewrite Hos; rewrite Hes in IHsem_exp; rewrite Hxs in Hvar;
            eauto.
        rewrite <-(Bool.negb_involutive k); eauto.
      - specialize (IHsem_exp n); simpl in IHsem_exp.
        rewrite lift1_spec in Hlift1; destruct (Hlift1 n)
          as [(Hes & Hos)|(? & ? & Hes & ? & Hos)];
          rewrite Hos; rewrite Hes in IHsem_exp; eauto.
      - specialize (IHsem_exp1 n); specialize (IHsem_exp2 n); simpl in *.
        rewrite lift2_spec in Hlift2; destruct (Hlift2 n)
          as [(Hes1 & Hes2 & Hos)|(? & ? & ? & Hes1 & Hes2 & ? & Hos)];
          rewrite Hos; rewrite Hes1 in IHsem_exp1; rewrite Hes2 in IHsem_exp2;
            eauto.
    Qed.
    Hint Resolve sem_exp_impl.

    Corollary sem_exps_impl:
      forall H b es ess,
        Forall2 (CoInd.sem_exp H b) es ess ->
        CESem.sem_exps (tr_Stream b) (tr_history H) es (tr_Streams ess).
    Proof.
      induction 1; simpl; constructor.
      - apply sem_exp_impl; auto.
      - apply IHForall2.
    Qed.
    Hint Resolve sem_exps_impl.

    (** Give an indexed specification for annotated [exp], using the previous
        lemma. *)
    Lemma sem_aexp_index:
      forall n H b ck le es,
        CoInd.sem_aexp H b ck le es ->
        (sem_clock_instant (tr_Stream b n)
                                   (tr_history H n) ck false
         /\ CESem.sem_exp_instant
             (tr_Stream b n) (tr_history H n) le absent
         /\ tr_Stream es n = absent)
        \/
        (exists e,
            sem_clock_instant (tr_Stream b n)
                                      (tr_history H n) ck true
            /\ CESem.sem_exp_instant
                (tr_Stream b n) (tr_history H n) le (present e)
            /\ tr_Stream es n = present e).
    Proof.
      induction n; intros * Indexed.
      - inversion_clear Indexed as [? ? ? ? ? ? ? Indexed' Hck
                                      |? ? ? ? ? ? Indexed' Hck];
          apply sem_exp_impl in Indexed'; specialize (Indexed' 0);
            repeat rewrite tr_Stream_0; repeat rewrite tr_Stream_0 in Indexed';
              eapply (sem_clock_impl) in Hck; specialize (Hck 0); rewrite tr_Stream_0 in Hck.
        + right. eexists; intuition; auto.
        + left; intuition.
      - inversion_clear Indexed as [? ? ? ? ? ? ? Indexed'|? ? ? ? ? ? Indexed'];
          apply sem_exp_impl in Indexed';
          rewrite tr_Stream_S, tr_history_tl; eauto.
    Qed.

    (** We deduce from the previous lemma the correspondence for annotated
        [exp]. *)
    (* Hint Constructors CESem.sem_aexp_instant. *)
    Corollary sem_aexp_impl:
      forall H b e es ck,
        CoInd.sem_aexp H b ck e es ->
        CESem.sem_aexp (tr_Stream b) (tr_history H) ck e (tr_Stream es).
    Proof.
      intros * Indexed n.
      apply (sem_aexp_index n) in Indexed;
        destruct Indexed as [(? & ? & Hes)|(? & ? & ? & Hes)];
        rewrite Hes; constructor; auto.
    Qed.
    Hint Resolve sem_aexp_impl.

    (** [fby] is not a predicate but a function, so we directly state the
        correspondence.  *)
    Lemma fby_impl:
      forall c xs,
      tr_Stream (sfby c xs) ≈ Indexed.fby c (tr_Stream xs).
    Proof.
      intros * n; revert c xs.
      induction n; intros.
      - unfold_Stv xs; rewrite unfold_Stream at 1;
          unfold Indexed.fby; simpl; now rewrite tr_Stream_0.
      - unfold_Stv xs; rewrite unfold_Stream at 1;
          unfold Indexed.fby; simpl; repeat rewrite tr_Stream_S;
            rewrite IHn; unfold Indexed.fby;
              destruct (tr_Stream xs n); auto; f_equal;
                clear IHn; induction n; simpl; auto;
                  rewrite tr_Stream_S; destruct (tr_Stream xs n); auto.
    Qed.

    (** ** Semantics of cexps *)

    (** State the correspondence for [cexp].
        Goes by induction on the coinductive semantics of [cexp]. *)
    Hint Constructors CESem.sem_cexp_instant.
    Lemma sem_cexp_impl:
      forall H b e es,
        CoInd.sem_cexp H b e es ->
        CESem.sem_cexp (tr_Stream b) (tr_history H) e (tr_Stream es).
    Proof.
      unfold tr_Stream.
      induction 1 as [? ? ? ? ? ? ? ? ? Hvar Ht ? ? ? Hmerge
                    |? ? ? ? ? ? ? ? ? He Ht ? ? ? Hite
                    |? ? ? ? He]; intro n.
      - specialize (IHsem_cexp1 n); specialize (IHsem_cexp2 n).
        apply sem_var_impl in Hvar; eauto.
        unfold tr_Stream, IStr.sem_var, IStr.lift in Hvar.
        specialize (Hvar n); simpl in *.
        rename H0_ into Hf.
        rewrite merge_spec in Hmerge; destruct (Hmerge n)
          as [(Hxs & Hts & Hfs & Hos)
             |[(? & Hxs & Hts & Hfs & Hos)
              |(? & Hxs & Hts & Hfs & Hos)]];
          rewrite Hos; rewrite Hts in IHsem_cexp1; rewrite Hfs in IHsem_cexp2;
            rewrite Hxs in Hvar; auto.

      - specialize (IHsem_cexp1 n); specialize (IHsem_cexp2 n).
        eapply sem_exp_impl in He; unfold tr_Stream in He.
        specialize (He n); simpl in *.
        rewrite ite_spec in Hite; destruct (Hite n)
          as [(Hes & Hts & Hfs & Hos)
             |[(ct & cf & Hes & Hts & Hfs & Hos)
              |(ct & cf & Hes & Hts & Hfs & Hos)]];
          rewrite Hos; rewrite Hts in IHsem_cexp1; rewrite Hfs in IHsem_cexp2;
            rewrite Hes in He; auto.
        + change (present ct) with (if true then present ct else present cf).
          eapply CESem.Site_eq; eauto.
          apply val_to_bool_true.
        + change (present cf) with (if false then present ct else present cf).
          eapply CESem.Site_eq; eauto.
          apply val_to_bool_false.

      - apply sem_exp_impl in He; unfold tr_Stream in *; auto.
    Qed.
    Hint Resolve sem_cexp_impl.

    (** Give an indexed specification for annotated [cexp], using the previous
        lemma.  *)
    Lemma sem_caexp_index:
      forall n H b ck le es,
        CoInd.sem_caexp H b ck le es ->
        (sem_clock_instant (tr_Stream b n)
                                   (tr_history H n) ck false
         /\ CESem.sem_cexp_instant
             (tr_Stream b n) (tr_history H n) le absent
         /\ tr_Stream es n = absent)
        \/
        (exists e,
            sem_clock_instant (tr_Stream b n)
                                      (tr_history H n) ck true
            /\ CESem.sem_cexp_instant
                (tr_Stream b n) (tr_history H n) le (present e)
            /\ tr_Stream es n = present e).
    Proof.
      induction n; intros * Indexed.
      - inversion_clear Indexed as [? ? ? ? ? ? ? Indexed' Hck
                                      |? ? ? ? ? ? Indexed' Hck];
          apply sem_cexp_impl in Indexed'; specialize (Indexed' 0);
            repeat rewrite tr_Stream_0; repeat rewrite tr_Stream_0 in Indexed';
              apply sem_clock_impl in Hck; specialize (Hck 0); rewrite tr_Stream_0 in Hck.
        + right. eexists; intuition; auto.
        + left; intuition.
      - inversion_clear Indexed as [? ? ? ? ? ? ? Indexed'|? ? ? ? ? ? Indexed'];
          apply sem_cexp_impl in Indexed';
          repeat rewrite tr_Stream_S; rewrite tr_history_tl; eauto.
    Qed.

    (** We deduce from the previous lemma the correspondence for annotated
        [cexp]. *)
    Corollary sem_caexp_impl:
      forall H b e es ck,
        CoInd.sem_caexp H b ck e es ->
        CESem.sem_caexp (tr_Stream b) (tr_history H) ck e (tr_Stream es).
    Proof.
      intros * Indexed n.
      apply (sem_caexp_index n) in Indexed; destruct Indexed
        as [(? & ? & Hes)|(? & ? & ? & Hes)];
        rewrite Hes; constructor; auto.
    Qed.
    Hint Resolve sem_caexp_impl.

    (** * RESET CORRESPONDENCE  *)

    (** We state the correspondence for [bools_of]. *)
    Lemma bools_of_impl:
      forall xs rs,
        CStr.bools_of xs rs ->
        CESem.bools_of (tr_Stream xs) (tr_Stream rs).
    Proof.
      intros ** n; revert dependent xs; revert rs.
      induction n; intros * Rst.
      - unfold_Stv xs; unfold_Stv rs; rewrite tr_Stream_0; auto;
          inv Rst; simpl in *; auto.
      - unfold_Stv xs; unfold_Stv rs; rewrite 2 tr_Stream_S;
          inv Rst; simpl in *; auto.
    Qed.

    (** ** Properties about [count] and [mask] *)

    (** When a reset occurs initially, the count at [n] is the count at [n]
        forgetting the first instant, plus one if no reset occurs at [n] when
        shifting. *)
    Lemma count_true_shift:
      forall n r,
        IStr.count (tr_Stream (true ⋅ r)) n
        = if tr_Stream r n
          then IStr.count (tr_Stream r) n
          else S (IStr.count (tr_Stream r) n).
    Proof.
      induction n; simpl; intros.
      - destruct (tr_Stream r 0); auto.
      - specialize (IHn r).
        rewrite tr_Stream_S.
        destruct (tr_Stream r n) eqn: E';
          destruct (tr_Stream r (S n)); rewrite IHn; auto.
    Qed.

    (** When no reset occurs initially, the count at [n] is the count at [n]
        forgetting the first instant, minus one if a reset occurs at [n] when
        shifting. *)
    Lemma count_false_shift:
      forall n r,
        IStr.count (tr_Stream (false ⋅ r)) n
        = if tr_Stream r n
          then IStr.count (tr_Stream r) n - 1
          else IStr.count (tr_Stream r) n.
    Proof.
      induction n; simpl; intros.
      - destruct (tr_Stream r 0); auto.
      - specialize (IHn r).
        rewrite tr_Stream_S.
        destruct (tr_Stream r n) eqn: E';
          destruct (tr_Stream r (S n)); rewrite IHn; try omega.
        + apply Minus.minus_Sn_m, count_true_ge_1; auto.
        + rewrite Minus.minus_Sn_m; try omega.
          apply count_true_ge_1; auto.
    Qed.

    (** State the correspondence for [count]. *)
    Lemma count_impl:
      forall r,
        tr_Stream (CStr.count r) ≈ IStr.count (tr_Stream r).
    Proof.
      intros ** n.
      unfold CStr.count.
      revert r; induction n; intros; simpl.
      - rewrite (unfold_Stream (count_acc 0 r)); simpl.
        rewrite tr_Stream_0; auto.
      - rewrite (unfold_Stream (count_acc 0 r)); simpl.
        rewrite tr_Stream_S. destruct (hd r) eqn: R.
        + unfold tr_Stream at 1; unfold tr_Stream in IHn; unfold Str_nth in *.
          rewrite count_S_nth, IHn.
          destruct r; simpl in *; rewrite R, count_true_shift, tr_Stream_S.
          now destruct (tr_Stream r n).
        + rewrite IHn.
          destruct r; simpl in *; rewrite R, count_false_shift, tr_Stream_S.
          destruct (tr_Stream r n) eqn: R'; auto.
          apply count_true_ge_1 in R'; rewrite Minus.minus_Sn_m; omega.
    Qed.

    (** State the correspondence for [mask]. *)
    Lemma mask_impl:
      forall k r xss,
        tr_Streams (List.map (CStr.mask k r) xss)
        ≈ IStr.mask k (tr_Stream r) (tr_Streams xss).
    Proof.
      induction xss as [|xs];
        simpl; intros * n; unfold IStr.mask in *.
      - destruct (k =? IStr.count (tr_Stream r) n); auto.
      - simpl; unfold tr_Stream at 1; rewrite mask_nth.
        rewrite IHxss; simpl.
        rewrite <-count_impl, Nat.eqb_sym.
        unfold tr_Stream; cases.
    Qed.

    (** * FINAL LEMMAS *)

    (** Correspondence for [clocks_of], used to give a base clock for node
        applications. *)
    Lemma tr_clocks_of:
      forall xss,
        CESem.clock_of (tr_Streams xss) ≈ tr_Stream (CStr.clocks_of xss).
    Proof.
      unfold CESem.clock_of.
      intros xss n; revert dependent xss; induction n; intros.
      - rewrite unfold_Stream at 1; simpl; rewrite tr_Stream_0, tr_Streams_hd.
        induction xss; simpl; auto.
        f_equal; auto.
      - rewrite unfold_Stream at 1; simpl.
        rewrite tr_Stream_S, <-tr_Streams_tl; auto.
    Qed.
    Hint Resolve tr_clocks_of.

    (** Give an indexed specification for Streams synchronization. *)
    Lemma aligned_index:
      forall xs bs,
        aligned xs bs ->
        forall n, tr_Stream bs n = true <-> tr_Stream xs n <> absent.
    Proof.
      intros * Sync n; revert dependent xs; revert bs; induction n; intros.
      - inversion_clear Sync; rewrite 2 tr_Stream_0; intuition; discriminate.
      - rewrite <-2 tr_Stream_tl; apply IHn.
        inv Sync; auto.
    Qed.

    Lemma sem_clocked_var_impl:
      forall H b x ck xs,
        sem_var H x xs ->
        CoInd.sem_clocked_var H b x ck ->
        CESem.sem_clocked_var (tr_Stream b) (tr_history H) x ck.
    Proof.
      intros * Var (Sem & Sem').
      pose proof Var as Var'.
      apply Sem in Var as (bs & Clock & Sync); rename Var' into Var.
      apply sem_var_impl in Var;
        apply sem_clock_impl in Clock.
      pose proof (aligned_index _ _ Sync) as Spec.
      intro n; specialize (Var n); specialize (Clock n).
      split; split.
      - intros * Clock'.
        eapply IStr.sem_clock_instant_det in Clock; eauto.
        symmetry in Clock; apply Spec, not_absent_present in Clock as (?& E).
        rewrite E in Var; eauto.
      - intros (?& Var').
        eapply IStr.sem_var_instant_det in Var; eauto.
        assert (tr_Stream bs n = true) as <-; auto.
        apply Spec; intro; congruence.
      - intros * Clock'.
        eapply IStr.sem_clock_instant_det in Clock; eauto.
        symmetry in Clock; rewrite <-Bool.not_true_iff_false, Spec in Clock.
        assert (tr_Stream xs n = absent) as <-; auto.
        apply Decidable.not_not in Clock; auto.
        apply decidable_eq_value.
      - intros Var'.
        eapply IStr.sem_var_instant_det in Var; eauto.
        assert (tr_Stream bs n = false) as <-; auto.
        rewrite <-Bool.not_true_iff_false, Spec; auto.
    Qed.

    Lemma sem_clocked_vars_impl:
      forall H b xcs xss,
        Forall2 (sem_var H) (List.map fst xcs) xss ->
        CoInd.sem_clocked_vars H b xcs ->
        CESem.sem_clocked_vars (tr_Stream b) (tr_history H) xcs.
    Proof.
      intros * Vars Sem n.
      apply Forall_forall; intros (x, ck) Hin; simpl.
      pose proof Hin as Hin'.
      apply in_map with (f := fst) in Hin.
      eapply Forall2_in_left in Vars as (?&?&?); eauto.
      eapply sem_clocked_var_impl; eauto.
      eapply Forall_forall in Sem; eauto; auto.
    Qed.
    Hint Resolve sem_clocked_vars_impl.

    (** The final theorem stating the correspondence for nodes applications.
        We have to use a custom mutually recursive induction scheme [sem_node_mult]. *)
    Hint Constructors Indexed.sem_equation.
    Theorem implies:
      forall f xss yss,
        CoInd.sem_node G f xss yss ->
        Indexed.sem_node G f (tr_Streams xss) (tr_Streams yss).
    Proof.
      induction 1 as [| |???????????????? IH| |???????? Same Heqs IH]
                       using CoInd.sem_node_mult with
          (P_equation := fun H b e =>
                           CoInd.sem_equation G H b e ->
                           Indexed.sem_equation G (tr_Stream b) (tr_history H) e);
        eauto.

      - econstructor; eauto.
        intro; rewrite tr_clocks_of; auto.
        apply sem_clock_impl; auto.

      - econstructor; eauto.
        + intro; rewrite tr_clocks_of; auto.
          apply sem_clock_impl; auto.
        + apply bools_of_impl; eauto.
        + intro k; destruct (IH k).
          now rewrite <- 2 mask_impl.

      - econstructor; auto; subst; eauto.
        rewrite <-fby_impl; auto.

      - econstructor; eauto.
        + intro; rewrite tr_clocks_of; auto.
          eapply sem_clocked_vars_impl; auto.
          rewrite map_fst_idck; eauto.
        + apply Forall_forall; intros * Hin.
          rewrite tr_clocks_of.
          eapply Forall_forall in IH; eauto; eapply Forall_forall in Heqs; eauto.
    Qed.

  End Global.

End NLCOINDTOINDEXED.

Module NLCoindToIndexedFun
       (Ids     : IDS)
       (Op      : OPERATORS)
       (OpAux   : OPERATORS_AUX          Op)
       (CESyn   : CESYNTAX               Op)
       (Syn     : NLSYNTAX           Ids Op       CESyn)
       (IStr    : INDEXEDSTREAMS         Op OpAux)
       (CStr    : COINDSTREAMS           Op OpAux)
       (CIStr   : COINDTOINDEXED         Op OpAux           CStr IStr)
       (Ord     : NLORDERED          Ids Op       CESyn Syn)
       (CESem   : CESEMANTICS        Ids Op OpAux CESyn     IStr)
       (Indexed : NLINDEXEDSEMANTICS Ids Op OpAux CESyn Syn IStr Ord CESem)
       (CoInd   : NLCOINDSEMANTICS   Ids Op OpAux CESyn Syn CStr Ord)
<: NLCOINDTOINDEXED Ids Op OpAux CESyn Syn IStr CStr CIStr Ord CESem Indexed CoInd.
  Include NLCOINDTOINDEXED Ids Op OpAux CESyn Syn IStr CStr CIStr Ord CESem Indexed CoInd.
End NLCoindToIndexedFun.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e205m45x2e198m1_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Export pcf_sub_rep.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Existing Instance pcfpo_rep_struct.

Section initial_rep.

Notation "'TY'" := PCF.TY.
Notation "'IP'" := (IO TY).
Notation "a '~>' b" := (PCF.arrow a b) (at level 69, right associativity).
(* Notation "a ~> b" := (Module_Hom a b) (at level 50).*)
(*Notation "a 'x' b" := (Prod_Mod _ a b) (at level 30).*)

Notation "a 'x' b" := (product (*C:= MOD _ _*) a b) (at level 30).

(* Notation "P ^ z" := (FIB_MOD _ z P). *)
Notation "P [ z ]" := (FIB_MOD _ z P) (at level 35).

(*Notation "P ''' s" := (DER_MOD _ _ s P ) (at level 25).*)
Notation "'d' P // s" := (DER_MOD _ _ s P) (at level 25).
(*Notation " '*' " := (Term (*C:=MOD _ _*)).*)
Notation "'*'" := (Term (C:=MOD _ SO)).
Notation "'Bool'" := PCF.Bool.
Notation "'Nat'" := PCF.Nat.

Notation "f 'X' g" := (product_mor (*C:= MOD _ _ *) _ f g)(at level 30).

Notation "'FM'" := (#(FIB_MOD _ _ )).
Notation "'FPB'":= (FIB_PB _ _ _ ).
Notation "'PRPB'":= (PROD_PB _ _ _ _ ).
Notation "'PBF'":= (PB_FIB _ _ _ ).
Notation "'PBM'":= (#(PB_MOD _ _ )).
Notation "'DM'":= (#(DER_MOD _ _ _ )).
Notation "'DPB'":= (DER_PB _ _ _ ).

(** need to have PCF.BETA as an object in PCFPO_REP *)

Definition PCFinit : Monad IP := PCFPO_monad.

(** a very boring part : definition of all the module morphisms we need *)
(*Lemma bla r s :
(forall V : IP,
  (Prod_Mod (P:=PCFinit) SO_prod (Fibre_Mod (P:=PCFinit) PCFinit (r ~> s))
     (Fibre_Mod (P:=PCFinit) PCFinit r)) V --->
  (Fibre_Mod (P:=PCFinit) PCFinit s) V).
intros r s V.
simpl.
apply (fun y => PCF.App (fst y) (snd y)).*)

Program Instance PCFApp_struct (r s: TY): Module_Hom_struct
  (S:=Prod_Mod (P:=PCFinit) SO_prod
 (Fibre_Mod (P:=PCFinit) PCFinit (r ~> s))
     (Fibre_Mod (P:=PCFinit) PCFinit r))
 (T:=Fibre_Mod (P:=PCFinit) PCFinit s)
    (fun V y => PCF.App  (fst y) (snd y)).

Definition PCFApp (r s: TY) := Build_Module_Hom (PCFApp_struct r s).

Program Instance PCFLam_struct (r s: TY): Module_Hom_struct
  (S:= Fibre_Mod (P:=PCFinit)
     (IO_Der_Mod (P:=PCFinit)  PCFinit r) s)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit (r ~> s))
    (fun V => PCF.Lam (V:=V) (t:=r)(s:=s) ).
Next Obligation.
Proof.
  apply f_equal.
  apply PCF.subst_eq.
  simpl.
  intros u y.
  destruct y; simpl; auto.
  unfold PCF.inj_. simpl.
  set (H:= PCF.subst_eq_rename).
  apply eq_sym.
  apply H.
Qed.

Definition PCFLam (r s: TY) := Build_Module_Hom (PCFLam_struct r s).

Program Instance PCFRec_struct (t: TY) : Module_Hom_struct
  (S:= Fibre_Mod (P:=PCFinit) PCFinit (t ~> t))
  (T:= Fibre_Mod (P:=PCFinit) PCFinit t)
   (fun V => PCF.Rec (V:=V) (t:=t)).

Definition PCFRec (t: TY) := Build_Module_Hom (PCFRec_struct t).

Program Instance PCFttt_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit Bool)
    (fun V _ => PCF.Const V PCF.ttt).

Definition PCFttt := Build_Module_Hom PCFttt_struct.

Program Instance PCFfff_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit Bool)
    (fun V _ => PCF.Const V PCF.fff).

Definition PCFfff := Build_Module_Hom PCFfff_struct.

Program Instance PCFsucc_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit (Nat ~> Nat))
    (fun V _ => PCF.Const V PCF.succ).

Definition PCFsucc := Build_Module_Hom PCFsucc_struct.

Program Instance PCFnats_struct (m: nat) : Module_Hom_struct
   (S:=MOD_Term PCFinit SO_Terminal)
   (T:=Fibre_Mod (P:=PCFinit) PCFinit Nat)
    (fun V _ => PCF.Const V (PCF.Nats m)).

Definition PCFnats (m:nat) := Build_Module_Hom (PCFnats_struct m).

Program Instance PCFzero_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit (Nat ~> Bool))
    (fun V _ => PCF.Const V PCF.zero).

Definition PCFzero := Build_Module_Hom PCFzero_struct.

Program Instance PCFcondN_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit (Bool ~> Nat ~> Nat ~> Nat))
    (fun V _ => PCF.Const V PCF.condN).

Definition PCFcondN := Build_Module_Hom PCFcondN_struct.

Program Instance PCFcondB_struct : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit (Bool ~> Bool ~> Bool ~> Bool))
    (fun V _ => PCF.Const V PCF.condB).

Definition PCFcondB := Build_Module_Hom PCFcondB_struct.

Program Instance PCFBottom_struct (t: TY) : Module_Hom_struct
  (S:=MOD_Term PCFinit SO_Terminal)
  (T:=Fibre_Mod (P:=PCFinit) PCFinit t)
    (fun V _ => PCF.Bottom V t).

Definition PCFBottom t:= Build_Module_Hom (PCFBottom_struct t).

(** finally PCF has a structure as a representation *)

Program Instance PCF_rep_struct : PCFPO_rep_struct PCFinit := {
  App := PCFApp;
  Abs := PCFLam;
  Rec := PCFRec;
  ttt := PCFttt;
  fff := PCFfff;
  succ := PCFsucc;
  nats := PCFnats;
  zero := PCFzero;
  condN := PCFcondN;
  condB := PCFcondB;
  Bottom := PCFBottom
}.
Next Obligation.
Proof.
  apply PCF.clos.
  constructor.
  constructor.
Qed.
Next Obligation.
Proof.
  apply PCF.cp_App1.
  auto.
Qed.
Next Obligation.
Proof.
  apply PCF.cp_App2.
  auto.
Qed.
Next Obligation.
Proof.
  apply PCF.cp_Lam.
  auto.
Qed.
Next Obligation.
Proof.
  apply PCF.cp_Rec.
  auto.
Qed.

(** PCF is a representation of PCFPO *)

Definition PCF_rep : PCFPO_REP := Build_PCFPO_rep PCF_rep_struct.

(** for any representation R, we need PCFPO_rep_Hom PCF_rep R
    [ PCF_rep ---> R ]
*)
(** let's get a monad morphism first, add rep structure later *)

Section monad_hom.

Variable R: PCFPO_rep.

(**   the function [(PCF V t) -> (R V t)] *)
(**   no structure of morphism yet, i.e. later we should prove that
      this is a monotone map (in each fibre) *)

Definition init_d (V:IP) : PCF.BETA V ---> R V.
intros V t v.
simpl.
induction v; simpl.
apply (Bottom t V tt).
destruct c.
apply (nats n V tt).
apply (ttt V tt).
apply (fff V tt).
apply (succ V tt).
apply (zero V tt).
apply (condN V tt).
apply (condB V tt).
(*apply (weta (Monad_struct := R)).*)
apply (weta (Monad_struct := R) V t i).
apply (App s t  V (IHv1, IHv2)).
apply (Abs _ _ V IHv).
apply (Rec _ V IHv).
Defined.

(*
Definition init_d (V:IP) (t:TY):
 (PCF.PCF V t) -> (R V t).
intros V t v.
simpl.
induction v; simpl.
apply (Bottom t V tt).
destruct c.
apply (nats n V tt).
apply (ttt V tt).
apply (fff V tt).
apply (succ V tt).
apply (zero V tt).
apply (condN V tt).
apply (condB V tt).
(*apply (weta (Monad_struct := R)).*)
apply (weta (Monad_struct := R) V t i).
apply (App s t  V (IHv1, IHv2)).
apply (Abs _ _ V IHv).
apply (Rec _ V IHv).
Defined.

*)

(** a lemma *)

Lemma UARGH (s t:TY) (RR: * ---> R [t]) (V: IP)
                 (f:opt_TP s V ---> R V):
RR V tt = (kleisli f t) (((RR) (opt_TP s V)) tt).
Proof.
  intros.
  set (H:= @mod_hom_mkl _ _ _ R _ _ _
       (Term (C:=MOD _ SO)) (FIB_MOD R t R) _
         RR  ).
  simpl in *.
  rewrite (H (opt_TP s V) V f).
  auto.
Qed.
(**   would require init_d to be a morphism... :-)

 this lemma says
    [ i (M >>= f) = iM >>= (i o f) ]
   but of course it is not accepted by coq
*)
(*
Lemma kleisli_PCFsubst V t (M : PCF.BETA V t) W (f : V ---> PCF.BETA W):
        init_d (PCF.subst f M) =
     kleisli (Monad_struct := R) (f;; init_d (V:= W) ) _ (init_d M).
Proof.
  intros V t M.
  induction M;
  simpl; intros.
  rewrite <- (@UARGH _ _ (Bottom t)).
  assert (H:=mod_hom_kl).

Lemma kleisli_PCFsubst V (s t:TY) (M: PCF.PCF (opt_TP s V) t) f:
       init_d (PCF.subst f M) =
        kleisli (fun t => fun e => init_d (f t e))
                          (init_d M).
 *)
(**   this lemma is the same as preceding, but only for substitution of
      the additional variable *

     [ i (M [* := N] ) = iM [* := iN] ]

but the assertion is not strong enough for induction

*)
(*

Lemma helper (s t:TY) (V:PCF.ipo) N:
 (opt_TP_def_varinj (P:=R) t (V:=opt_TP s V) (W:=V)
      (IPsubst_map (R:=R) (V:=V) (r:=s) (init_d (V:=V) (t:=s) N))) ==
  IPsubst_map (init_d  (? N)).
*)

(*
Lemma substar_IPsubstar
(V : IP)
(s : TY)
(t : TY)
(M : PCF.PCF (opt_TP s V) t)
(N : PCF.PCF V s) :

 init_d (V:=V) (t:=t) (PCF.substar N M) =
         IPsubstar (R:=R) (r:=s) (init_d N) _ (init_d M).
Proof.
(*  unfold PCF.substar.
  unfold IPsubstar.*)
  intros V s t M.
  dependent induction M.

    simpl; intros.
    unfold IPsubstar.
    apply (@UARGH s t(Bottom t) V).

    simpl; intro N.
      destruct c; simpl;
      unfold IPsubstar;
      simpl.
      apply (@UARGH s Nat (nats n) V).
      apply (@UARGH s Bool ttt V).
      apply (@UARGH s Bool fff V).
      apply (@UARGH s _ succ V).
      apply (@UARGH s _ zero V).
      apply (@UARGH s _ condN V).
      apply (@UARGH s _ condB V).

    intros.
    unfold IPsubstar.
    set (H:= eta_kl (Monad_struct := R)).
    simpl in *.
    unfold PCF.substar.
    unfold ind_po_comp,PreOrder_comp,
       eq_ind_po,eq_PreOrder in *.
    simpl in *.
    rewrite H.
    simpl.
    destruct p; simpl; auto.

    intros N.
    simpl in *.
    unfold PCF.substar in IHM1,IHM2.
    rewrite IHM1.
    rewrite IHM2.
    unfold IPsubstar.
    set (H:= @mod_hom_mkl _ _ _ R _ _ _
                _ _ _ (App s0 t)).
    simpl in H.
    unfold eq_PreOrder,PreOrder_comp in H.
    simpl in H.
    set (H1 := H _ _ (IPsubst_map (init_d N))
               (init_d M1, init_d M2)).
    simpl in H1.
    simpl.
    rewrite H1. auto.

    intros N.
    simpl in *.
    set (H':= @mod_hom_mkl _ _ _ R _ _ _
              _ _ _ (Abs t s0)).
     simpl in H'.
     unfold eq_PreOrder,PreOrder_comp in H'.
     simpl in *.
     unfold IPsubstar.
     rewrite <- H'.
     apply f_equal.
     unfold der_mkl.
     simpl.
     unfold IPsubstar in IHM.

     unfold IPsubst_map.
     simpl.
     (*rewrite <- IHM.
(*   assert (H': opt_TP_def_varinj (IPsubst_map (init_d N)) =
                 IPsubst_map (init_d  (opt_TP_def_varinj ( N))).
*)
      (*
    intros N.
    simpl.
    unfold PCF.substar in IHM;
    simpl in IHM.
    rewrite IHM.
   *)
Admitted.
(*
rewrite  IHM.
    unfold IPsubst_map.
 unfold IPsubst_map_.
 unfold kleisli.
 simpl.

 N.
 unfold PCF.substar.
 unfold IPsubstar.
 simpl.
 unfold kleisli.

H' := beta
   : forall (r s : TY) (V : ind_po_obj TY) (y : R (opt_TP r V) s) (z : R V r),
     ((App r s) V) (((Abs r s) V) y, z) <<
     (IPsubstar (R:=R) (r:=r) (V:=V) z s) y
______________________________________(1/6)
((App s t) V)
  (((Abs s t) V) (bla1 (V:=opt_TP s V) (t:=t) M), bla1 (V:=V) (t:=s) N) <<
bla1 (V:=V) (t:=t) (PCF.substar M N)

*)
*)

(** IMPORTANT LEMMA: our function i: PCF -> R is a morphism *)

(*
Program Instance init_struct (V:IP) (t:TY):
PO_mor_struct (*PCF.BETA V t*) (*R V t*) (@init_d V t).
Next Obligation.
Proof.
  unfold Proper; red.
  intros y z H; simpl.
  induction H.
  apply POprf.
  transitivity (init_d y); auto.
  clear H0.
  clear IHclos_refl_trans_1n.
  clear z.
  induction H; simpl.
  induction H; simpl.

  Focus 2.
  set (H':= @weta _ _ _ _ R V t).
  apply H'; auto.

  Focus 2.
  apply (propag_App1 _  IHpropag).

  Focus 2.

  apply (propag_App2 (init_d (V:=V) (t:=s ~> t) M) IHpropag).

  Focus 2.
  apply (propag_Abs IHpropag).

  Focus 2.
  apply (propag_Rec IHpropag).

  rewrite substar_IPsubstar.
  set (H:= beta (PCFPO_rep_struct:=R)).
  simpl in *.
  apply H.
Qed.

Definition init V t := Build_PO_mor (init_struct V t).
*)
(*
R : PCFPO_rep
V : PCF.ipo
t : TY
Y : ind_po_obj TY
f : ind_po_mor (T:=TY) V (PCF.BETA Y)
______________________________________(1/6)
((Bottom t) Y) tt =
(kleisli (fun t0 : TY => PreOrder_comp (f t0) (init Y t0)) t)
  (((Bottom t) V) tt)

Lemma UARGH (s t:TY) (RR: * ---> R [t]) (V: IP)
                 (f:opt_TP s V ---> R V):
RR V tt = (kleisli f t) (((RR) (opt_TP s V)) tt).
*)
*)

(**  lemma, not important *)
Lemma UARGH2 (t:TY) (RR: * ---> R [t])
         (V Y:IP) (f: V ---> PCF.BETA Y) :
RR  Y  tt = (kleisli (f ;; init_d (V:=Y))) t (RR V tt).
Proof.
  intros; simpl.
  set (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (RR)).
  simpl in *.
  apply H.
Qed.
(** lemma, not important *)

Lemma UARGH3 (t t0: TY) (RR: * ---> R[t0]) (V:IP) (f:V ---> (opt_TP t V)):
((RR) (opt_TP t V)) tt =
(lift (f) t0) (((RR) V) tt).
intros t t0 RR V f.
  set (H:= @mod_hom_mkl _ _ _ R _ _ _
                _ _ _ (RR)).
  simpl in *.
  simpl in H.
  unfold lift.
  apply H.
Qed.

Lemma init_d_lift V t (v : PCF.PCF V t) W (f : V ---> W) :
      init_d (PCF.rename f v) = lift f t (init_d v).
Proof.
 intros V t v.
  induction v. intros; simpl.
   unfold lift.
   assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (Bottom t)).
   simpl in H.
   rewrite <- H.
   auto.

   intros; destruct c; simpl.
     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (nats n)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (ttt)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (fff)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (succ)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (zero)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (condN)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

     assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (condB)).
               simpl in H.
               unfold lift.
               rewrite <- H.
               auto.

    intros W f;
    simpl.
    assert (H:=lift_weta R).
    simpl in *.
    rewrite H.
    auto.

    intros W f.
    simpl.
    rewrite IHv1.
    rewrite IHv2.
    assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (App s t)).
               simpl in *.
               unfold lift.
               rewrite <- H.
               auto.

    intros W f.
    simpl in *.
    rewrite IHv.
    assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (Abs t s)).
               simpl in *.
               unfold lift.
               rewrite <- H.
               auto.
    apply f_equal.
    assert (H':=kleisli_oid (Monad_struct := R)).
    unfold Proper in H'.
    red in H'.
    simpl in *.
    apply H'.
      intros t1 y1.
      destruct y1;
      simpl;
      auto.
      assert (H2:=lift_weta R).
    simpl in *.
    rewrite H2.
    auto.

    intros W f.
    simpl in *.
    rewrite IHv.
    assert (H:= @mod_hom_mkl _ _ _ R _ _ _
               _ _ _ (Rec t)).
               simpl in *.
               unfold lift.
               rewrite <- H.
               auto.
Qed.

Lemma UARGH4 (t t0 : TY) Y v :
init_d (V:=opt_TP t Y) (t:=t0) (PCF.inj_ t v) =
(lift (@Some_TP _ t Y) t0) (init_d (V:=Y) (t:=t0) v).
Proof.
  intros.
  unfold PCF.inj_.
  assert (H:= init_d_lift).
  simpl in *.
  rewrite <- H.
  auto.
Qed.

Obligation Tactic := idtac.

Program Instance Init_mor_Monad_rep_struct : Monad_Hom_struct
      (P:=PCF_rep) (Q:=R) (@init_d).
(*    (fun V t => init V t).*)

Next Obligation.
Proof.
  intros V W f t v.
  generalize dependent W.
  simpl in *.
  induction v.
  intros Y f; simpl.
  apply (@UARGH2 t (Bottom t) _ _ f  ).

  intros Y f. simpl.
  destruct c; simpl.
    apply (@UARGH2 Nat (nats n) _ _ f).
    apply (@UARGH2 _ (ttt) _ _ f).
    apply (@UARGH2 _ fff _ _ f).
    apply (@UARGH2 _ succ _ _ f).
    apply (@UARGH2 _ zero _ _ f).
    apply (@UARGH2 _ condN _ _ f).
    apply (@UARGH2 _ condB _ _ f).

  intros Y f; simpl.
  set (H:= eta_kl (Monad_struct := R)).
  simpl in H.
  rewrite H. auto.

  intros Y f; simpl in *.
  rewrite IHv1.
  rewrite IHv2.
  set (H:= @mod_hom_mkl _ _ _ R _ _ _
                _ _ _ (App s t)).
  simpl in H.
  rewrite <- H.
  auto.

  intros Y f.
  simpl in *.
  rewrite  IHv.

  set (H2:=@mod_hom_mkl _ _ _ R _ _ _
                _ _ _ (Abs t s)).
    simpl in *.

    rewrite <- H2.
    apply f_equal.
    set (H'':= kleisli_oid (Monad_struct := R)).
    unfold Proper in H''.
    red in H''.
    simpl in H''.
    simpl in *.
    apply H''.

    intros t1 y1.
    simpl in *.
    destruct y1;
    simpl;
    auto.
    unfold lift.
    simpl.
    unfold PCF.inj_.
    simpl in *.
  simpl.
  simpl in IHv.
  assert (H4:=UARGH4).
  unfold PCF.inj_ in H4.
  rewrite H4.
  auto.

  intros Y f; simpl in *.
  rewrite IHv.
  set (H:= @mod_hom_mkl _ _ _ R _ _ _
                _ _ _ (Rec t)).
  simpl in H.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  intros V t v.
  simpl.
  auto.
Qed.

Definition INIT_monad_hom := Build_Monad_Hom Init_mor_Monad_rep_struct.

Lemma IRel_equal (V : IP) t (y z : V t) : y = z -> IRel (A:=V)(t:=t) y z.
Proof.
  intros V t y z H.
  rewrite H.
  reflexivity.
Qed.

Section INIT_monotone.

Hypothesis weta_monotone : forall V,
     iMonotone (weta (Monad_struct := R) V).

Instance INIT_monotone V : iMonotone (init_d (V:=V)).
Proof.
  unfold iMonotone,Proper.
  red.
  intros V t y z H.
  induction H.
  reflexivity.

  transitivity (init_d y);
  auto.

  clear IHclos_refl_trans_1n.
  clear H0.
  clear z.

  induction H.

  induction H. simpl.
  assert (H:=monad_hom_kl (Monad_Hom_struct:=INIT_monad_hom)).
  simpl in *.
  unfold PCF.substar.
  assert (H':=@IRel_Trans _ (R V) t).
  unfold Transitive in H'.
  apply H' with (init_d (PCF.subst (fun (t0 : TY) (x0 : (opt_TP s V) t0) =>
         match x0 in (opt _ _ r) return (PCF.PCF V r) with
         | some t1 v0 => PCF.Var (V:=V) (t:=t1) v0
         | none => N
         end) M)); try reflexivity.

  rewrite H. simpl.
  assert (H2:=beta (PCFPO_rep_struct:=R)).
  simpl in H2.
  unfold IOsubstar in H2.

  unfold IPsubst_map in H2.
  unfold opt_TP_default,opt_default in H2.
  assert (H3:=H2 s t V (init_d M) (init_d N)).
  apply H' with (kleisli (Monad_struct := R)
          (fun (t : TY) (v : opt_TP s V t) =>
           match v in (opt _ _ t0) return ((R V) t0) with
           | some t' v' => weta (Monad_struct := R) V t' v'
           | none => init_d (V:=V) (t:=s) N
           end) t (init_d (V:=opt_TP s V) (t:=t) M)).
           auto.
  apply IRel_equal.
  assert (Hk:=kleisli_oid (Monad_struct := R)).
  unfold Proper in Hk. red in Hk.
  simpl in Hk.
  apply Hk.
   intros t1 y1.
   simpl in *.
   destruct y1;
   simpl; auto.

(*  simpl in *.
  unfold weta in H2.
  rewrite <- H.
  apply H2.
  unfold PCF.substar.
  simpl.
  unfold P
*)

Focus 2.
  simpl.
  assert (H':=propag_App1 (PCFPO_rep_struct := R)).
    simpl in *. apply H'.
    auto.
Focus 2.
  simpl.
  assert (H':=propag_App2 (PCFPO_rep_struct := R)).
    simpl in *. apply H'.
    auto.
Focus 2.
  simpl.
  assert (H':=propag_Abs (PCFPO_rep_struct := R)).
    simpl in *. apply H'.
    auto.
Focus 2.
  simpl.
  assert (H':=propag_Rec (PCFPO_rep_struct := R)).
    simpl in *. apply H'.
    auto.

   simpl.
   apply weta_monotone.
   auto.
Qed.

End INIT_monotone.

Obligation Tactic := simpl; intros V y; try elim y; auto.

Program Instance INIT_repr_hom_s :
       PCFPO_rep_Hom_struct INIT_monad_hom.
Next Obligation.
Proof.
  intros t s z;
  elim z;
  simpl; auto.
Qed.
Next Obligation.
Proof.
  intros t s z;
  elim z;
  simpl; auto.
Qed.

Definition INIT_repr_hom := Build_PCFPO_rep_Hom INIT_repr_hom_s.

Lemma INIT_unique : forall f : PCF_rep ---> R,
           f == INIT_repr_hom.
Proof.
  simpl.
  intros f V t v.
  simpl in *.

  induction v.
  simpl.

  assert (H:= Bottom_Hom (PCFPO_rep_Hom_struct := f)).
  simpl in H.
  apply H.
  destruct c; simpl.
    set (H:= nats_Hom (PCFPO_rep_Hom_struct := f)n).
    simpl in H.
    apply H.
    set (H:= ttt_Hom (PCFPO_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= fff_Hom (PCFPO_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= succ_Hom (PCFPO_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= zero_Hom (PCFPO_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= condN_Hom (PCFPO_rep_Hom_struct := f)).
    simpl in H.
    apply H.
    set (H:= condB_Hom (PCFPO_rep_Hom_struct := f)).
    simpl in H.
    apply H.
  assert (H:=monad_hom_weta (Monad_Hom_struct := f)).
  simpl in H.
  apply H.
  set (H:= App_Hom (PCFPO_rep_Hom_struct := f)).
  simpl in *.
  rewrite <- IHv1.
  rewrite <- IHv2.
  apply (H _ _ _ (v1, v2)).

  simpl.
  rewrite <- (IHv).
  set (H:= Abs_Hom (PCFPO_rep_Hom_struct := f)).
  simpl in H.
  apply H.

  simpl in *.
  rewrite <- IHv.
  set (H:= Rec_Hom (PCFPO_rep_Hom_struct := f)).
  simpl in H.
  apply H.

Qed.

End monad_hom.

Program Instance PCFPO_INIT : Initial PCFPO_REP := {
  Init := PCF_rep;
  InitMor R := INIT_repr_hom R ;
  InitMorUnique R := @INIT_unique R
}.

End initial_rep.

(*
rogram Instance PCFPO_INIT : Initial PCFPO_REP := {
  InPit := PCF_rep
}.
Next Obligation.
simpl.
constructor.

*)


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 lv0)).
Admitted.
QuickChick conj13eqsynthconj6.


(* Definitions and generic properties of Hoare triples for proofs on (privileged) machine code. *)

Require Import ZArith.
Require Import Lia.
Require Import List.
Require Import Utils.
Require Import LibTactics.
Import ListNotations.

Require Import Memory.
Require Import Instr.
Require Import Lattices.
Require Import Concrete.
Require Import CodeGen.
Require Import Concrete.
Require Import ConcreteExecutions.
Require Import ConcreteMachine.
Require Import Coq.Arith.Compare_dec.

Section Triples.
Local Open Scope Z_scope.

Variable cblock : block privilege.
Hypothesis stamp_cblock : Mem.stamp cblock = Kernel.
Variable table : CSysTable.

Notation cstep := (cstep cblock).
Notation runsToEscape := (runsToEscape cblock).

Definition imemory : Type := list Instr.
Definition memory : Type := memory (val privilege) privilege.
Definition stack : Type := list CStkElmt.
Definition code := list Instr.
Definition state := CS.

(* ---------------------------------------------------------------- *)
(* Specs for self-contained code *)

(* ================================================================ *)
(* Hoare Triples *)

(* Instruction memory contains code [c] starting at address [pc]. *)
Fixpoint code_at (pc: Z) (im: imemory) (c: code): Prop :=
  match c with
  | nil     => True
  | i :: c' => index_list_Z pc im = Some i
               /\ code_at (pc + 1) im c'
  end.

Lemma code_at_compose_1: forall im c1 c2 n,
  code_at n im (c1 ++ c2) ->
  code_at n im c1.
Proof.
  induction c1; intros; simpl in *.
  intuition.
  intuition. eapply IHc1. eauto.
Qed.

Lemma code_at_compose_2: forall im c1 c2 n,
  code_at n im (c1 ++ c2) ->
  code_at (n + Z_of_nat (length c1)) im c2.
Proof.
  induction c1; intros; simpl in *.

  exact_f_equal H; lia.

  intuition.
  apply_f_equal IHc1; eauto; zify; lia.
Qed.

Lemma code_at_app : forall c2 c1 n,
  n = Z_of_nat (length c1) ->
  code_at n (c1 ++ c2) c2.
Proof.
  induction c2; intros.
  simpl. auto.
  simpl.
  split.
  rewrite index_list_Z_app. auto.
  subst n; auto.
  replace (c1 ++ a :: c2) with ((c1 ++ [a]) ++ c2).
  eapply IHc2.
  rewrite app_length. simpl. subst n; auto.
  zify; lia.
  rewrite app_ass. auto.
Qed.

Lemma code_at_id : forall c, code_at 0%Z c c.
Proof.
  intros. pattern c at 1.  replace c with ([]++c) by auto.
  eapply code_at_app.
  auto.
Qed.

(* Hoare triple for a list of instructions *)
Definition HT   (c: code)
                (P: memory -> stack -> Prop) (* pre-condition *)
                (Q: memory -> stack -> Prop) (* post-condition when code "falls through" *)
:= forall imem stk0 mem0 fh n n',
  code_at n fh c ->
  P mem0 stk0 ->
  n' = n + Z_of_nat (length c) ->
  exists stk1 mem1,
  Q mem1 stk1 /\
  runsToEnd cblock table
             (CState mem0 fh imem stk0 (n, handlerTag) true)
             (CState mem1 fh imem stk1 (n', handlerTag) true).

Inductive Outcome :=
| Success
| Failure.

Definition predicted_outcome (o: Outcome) raddr pc priv :=
  match o with
  | Success => priv = false /\ pc = raddr
  | Failure => priv = true  /\ pc = (-1, handlerTag)
  end.

Definition HTEscape raddr
  (c: code)
  (P: memory -> stack -> Prop)
  (Q: memory -> stack -> Prop * Outcome)
:= forall imem stk0 mem0 fh n,
  code_at n fh c ->
  P mem0 stk0 ->
  exists stk1 mem1 pc1 priv1,
  let (prop, outcome) := Q mem1 stk1 in
  prop /\
  predicted_outcome outcome raddr pc1 priv1 /\
  runsToEscape table
    (CState mem0 fh imem stk0 (n, handlerTag) true)
    (CState mem1 fh imem stk1 pc1 priv1).

Lemma HTEscape_strengthen_premise: forall r c (P' P: memory -> stack -> Prop) Q,
  HTEscape r c P  Q ->
  (forall m s, P' m s -> P m s) ->
  HTEscape r c P' Q.
Proof.
  introv HTPQ P'__P.
  unfold HTEscape; intros.
  edestruct HTPQ as [mem2 [stk2 [HR RTE2]]]; eauto.
Qed.

Lemma HTEscape_compose: forall r c1 c2 P Q R,
  HT         c1 P Q ->
  HTEscape r c2 Q R ->
  HTEscape r (c1 ++ c2) P R.
Proof.
  introv H_HT H_HTE.
  intro; intros.

  edestruct H_HT as [cache1 [stk1 [HQ Hstar1]]]; eauto.
  eapply code_at_compose_1; eauto.

  edestruct H_HTE as [stk2 [cache2 [pc2 [priv2 Hlet]]]]; eauto.
  eapply code_at_compose_2; eauto.

  exists stk2 cache2 pc2 priv2.
  destruct (R cache2 stk2).
  destruct Hlet as [? [Houtcome ?]].
  destruct o; unfold predicted_outcome in Houtcome; simpl; intuition; subst.
  - eapply rte_success.
    eapply runsUntilUser_trans; eauto.
    inv H2; eauto.
    apply runsToEnd_r in STAR.
    simpl in STAR. congruence.
  - eapply rte_fail.
    eapply runsToEnd_trans; eauto.
    inv H2; eauto.
    + apply runsUntilUser_r in STAR.
      simpl in STAR. congruence.
    + simpl. lia.
Qed.

Lemma HTEscape_compose_flip: forall r c1 c2 P Q R,
    HTEscape r c2 Q R ->
    HT c1 P Q ->
    HTEscape r (c1 ++ c2) P R.
Proof.
  intros. eapply HTEscape_compose; eauto.
Qed.

Lemma HTEscape_append: forall r c1 c2 P Q,
  HTEscape r c1 P Q ->
  HTEscape r (c1 ++ c2) P Q.
Proof.
  unfold HTEscape.
  intros.
  exploit code_at_compose_1; eauto.
Qed.

Lemma HT_compose: forall c1 c2 P Q R,
  HT   c1 P Q ->
  HT   c2 Q R ->
  HT   (c1 ++ c2) P R.
Proof.
  unfold HT   in *.
  intros c1 c2 P Q R HT1 HT2 imem stk0 mem0 fh0 n n' HC12 HP Hn'.
  subst.

  edestruct HT1 as [stk1 [mem1 [HQ RTE1]]]; eauto.
  apply code_at_compose_1 in HC12; eauto.

  edestruct HT2 as [stk2 [mem2 [HR RTE2]]]; eauto.
  apply code_at_compose_2 in HC12; eauto.

  eexists. eexists. intuition. eauto.
  replace (@nil CEvent) with (@nil CEvent++@nil CEvent) by reflexivity.
  eapply runsToEnd_trans; eauto.

  (* NC: why is this let-binding necessary ? *)
  let t := (rewrite app_length; zify; lia) in
  exact_f_equal RTE2; rec_f_equal t.
  (* Because 'tacarg's which are not 'id's or 'term's need to be
     preceded by 'ltac' and enclosed in parens.  E.g., the following
     works:

       exact_f_equal RTE2;
       rec_f_equal ltac:(rewrite app_length; zify; lia).

     See grammar at
     http://coq.inria.fr/distrib/8.4/refman/Reference-Manual012.html

   *)
Qed.

(* An alternate version, which works better when unifying pre-conditions *)
Lemma HT_compose_flip : forall c1 c2 P Q R,
                      HT c2 Q R ->
                      HT c1 P Q ->
                      HT (c1 ++ c2) P R.
Proof. intros. eauto using HT_compose. Qed.

Lemma HTEscape_weaken_conclusion: forall r c P (Q Q': memory -> stack -> Prop * Outcome),
  HTEscape r c P Q ->
  (forall m s, fst (Q m s) -> fst (Q' m s)) ->
  (forall m s, snd (Q m s) = snd (Q' m s)) ->
  HTEscape r c P Q'.
Proof.
  intros r c P Q Q' HTPQ Q__Q' O__O'.
  unfold HTEscape; intros.
  unfold HTEscape in HTPQ.
  edestruct HTPQ; eauto.
  destruct H1 as [mem2 [pc2 [priv2 HH]]].
  case_eq (Q mem2 x); intros. rewrite H1 in *.
  destruct HH as [HP0 [HOUT RTE]].
  exists x ; exists mem2; exists pc2 ; exists priv2.
  case_eq (Q' mem2 x); intros. intuition.
  replace P1 with (fst (Q' mem2 x)); [ | rewrite H2 ; eauto].
  eapply Q__Q'; eauto.
  rewrite H1; auto.
  unfold predicted_outcome in HOUT.
  {
  cases o; cases o0; subst; intuition.
    - constructor; auto.
    - assert (HCONT:= O__O' mem2 x); eauto.
      rewrite H1 in HCONT. rewrite H2 in HCONT. inv HCONT.
    - assert (HCONT:= O__O' mem2 x); eauto.
      rewrite H1 in HCONT. rewrite H2 in HCONT. inv HCONT.
    - constructor; auto.
  }
 eapply RTE.
Qed.

Lemma HTEscape_forall_exists : forall (T : Type) c pc
         (P : T -> memory -> stack -> Prop) (Q : memory -> stack -> Prop * Outcome),
       (forall x : T, HTEscape pc c (P x) Q) ->
       HTEscape pc c (fun (m : memory) (s : stack) => exists x, P x m s) Q.
Proof.
  intros.
  unfold HTEscape.
  intros imem mem0 stk0 fh0 n0 Hcode_at [x HPx].
  eapply H; eauto.
Qed.

(* ================================================================ *)
(* Lemmas on Hoare Triples *)

Lemma HT_strengthen_premise: forall c (P' P Q: memory -> stack -> Prop),
  HT   c P  Q ->
  (forall m s, P' m s -> P m s) ->
  HT   c P' Q.
Proof.
  intros c P' P Q HTPQ P'__P.
  intros imem mem0 stk0 fh0 n n' Hcode HP' Hn'.
  edestruct HTPQ as [mem2 [stk2 [HR RTE2]]]; eauto.
Qed.

Lemma HT_weaken_conclusion: forall c (P Q Q': memory -> stack -> Prop),
  HT   c P  Q ->
  (forall m s, Q m s -> Q' m s) ->
  HT   c P Q'.
Proof.
  intros ? ? ? ? HTPQ ?.
  intros imem mem0 stk0 fh0 n n' Hcode HP' Hn'.
  edestruct HTPQ as [stk2 [c2 [HR RTE2]]]; eauto.
Qed.

Lemma HT_consequence: forall c (P' P Q Q': memory -> stack -> Prop),
  HT   c P Q ->
  (forall m s, P' m s -> P m s) ->
  (forall m s, Q m s -> Q' m s) ->
  HT   c P' Q'.
Proof.
  intros.
  eapply HT_weaken_conclusion; eauto.
  eapply HT_strengthen_premise; eauto.
Qed.

(* A strengthened rule of consequence that takes into account that [Q]
   need only be provable under the assumption that [P] is true for
   *some* state.  This lets us utilize any "pure" content in [P] when
   establishing [Q]. *)
Lemma HT_consequence': forall c (P' P Q Q': memory -> stack -> Prop),
  HT   c P Q ->
  (forall m s, P' m s -> P m s) ->
  (forall m s, (exists m' s', P' m' s') -> Q m s -> Q' m s) ->
  HT   c P' Q'.
Proof.
  intros ? ? ? ? ? HTPQ HPP' HP'QQ'.
  intros imem mem0 stk0 fh0 n n' Hcode HP' Hn'.
  edestruct HTPQ as [stk2 [c2 [HR RTE2]]]; eauto.
  eexists. eexists. eexists.
  intuition.
  eapply HP'QQ'; eauto.
  eauto.
Qed.

Lemma HT_decide_join: forall T c c1 c2 P1 P2 P1' P2' Q (D: T -> Prop),
  (forall v, HT   c1 P1 Q -> ~ D v -> HT   c (P1' v) Q) ->
  (forall v, HT   c2 P2 Q ->   D v -> HT   c (P2' v) Q) ->
  (forall v, ~ D v \/ D v) ->
  HT   c1 P1 Q ->
  HT   c2 P2 Q ->
  HT   c (fun m s => exists v, (~ D v /\ P1' v m s) \/ (D v /\ P2' v m s)) Q.
Proof.
  intros ? c c1 c2 P1 P2 P1' P2' Q D spec1 spec2 decD HT1 HT2.
  unfold HT. intros imem mem0 stk0 fh0 n n' H_code_at HP neq.
  destruct HP as [v Htovornottov].
  pose (decD v) as dec. intuition.

  eapply spec1; eauto.
  eapply spec2; eauto.
Qed.

Lemma HT_decide_join': forall T (v: T) c c1 c2 P1 P2 P1' P2' Q (D: T -> Prop),
  (HT   c1 P1 Q -> ~ D v -> HT   c P1' Q) ->
  (HT   c2 P2 Q ->   D v -> HT   c P2' Q) ->
  (forall v, ~ D v \/ D v) ->
  HT   c1 P1 Q ->
  HT   c2 P2 Q ->
  (* Switched to implication here.  I think this is a weaker
     assumption, and it's closer to the form of the [ifNZ] spec I want
   *)
  HT   c (fun m s => (~ D v -> P1' m s) /\ (D v -> P2' m s)) Q.
Proof.
  intros ? v c c1 c2 P1 P2 P1' P2' Q D spec1 spec2 decD HT1 HT2.
  unfold HT. intros imem mem0 stk0 n n' H_code_at HP neq.
  (* destruct HP as [v [[HDv HP1'] | [HnDv HP2']]]. *)
  pose (decD v) as dec. intuition.
Qed.

(* Hoare triples are implications, and so this corresponds to the
   quantifier juggling lemma:

     (forall x, (P x -> Q)) ->
     ((exists x, P x) -> Q)

*)
Lemma HT_forall_exists: forall T c P Q,
  (forall (x:T), HT   c (P x) Q) ->
  HT   c (fun m s => exists (x:T), P x m s) Q.
Proof.
  intros ? c P Q HPQ.
  unfold HT.
  intros imem mem0 stk0 fh0 n n' Hcode_at [x HPx] neq.
  eapply HPQ; eauto.
(*
  (* Annoyingly, we can't use [HT_strengthen_premise] here, because
     the existential [x] in [exists (x:T), P x m s] is not introduced
     early enough :P.  I'm not alone:
     https://sympa.inria.fr/sympa/arc/coq-club/2013-01/msg00055.html *)
  intros ? c P Q HPQ.
  eapply HT_strengthen_premise.
  eapply HPQ.
  intros m s [x HPx].
  (* Error: Instance is not well-typed in the environment of ?14322 *)
  (* instantiate (1:=x). *)
  (* And similar problems with: *)
  (* exact HPx. *)
*)
Qed.

(* The other direction (which I don't need) is provable from
   [HT_strengthen_premise] *)
Lemma HT_exists_forall: forall T c P Q,
  HT   c (fun m s => exists (x:T), P x m s) Q ->
  (forall (x:T), HT   c (P x) Q).
Proof.
  intros ? c P Q HPQ x.
  eapply HT_strengthen_premise.
  eapply HPQ.
  intuition.
  eauto.
Qed.

Lemma HT_fold_constant_premise: forall (C:Prop) c P Q ,
  (C -> HT c P Q) ->
  HT c (fun m s => C /\ P m s) Q.
Proof.
  unfold HT.
  iauto.
Qed.

End Triples.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Semantics Require Import
     Static.TypeEquality
     Static.TypeOf
.

From ExtensibleCompiler.Syntax Require Import
     Terms.If2
     Types.BoolType
.

From ExtensibleCompiler.Syntax.Types Require Import
     BoolType
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Functor
     ProgramAlgebra
     SubFunctor
     Types
     UniversalProperty
.

Local Open Scope SubFunctor.

Section If2.

  Context
    {T}
    `{Functor T}
    `{! T supports BoolType}

    {TypeEquality__T : forall R,
        ProgramAlgebra ForTypeEquality T R (TypeEqualityResult T)}
  .

  Definition typeOf__If2
    : forall R, MixinAlgebra If2 R (TypeOfResult T)
    := fun _ rec '(MkIf2 c t e) =>
         match rec c with
         | Some cType =>
           if isBoolType (proj1_sig cType)
           then
             match (rec t, rec e) with
             | (Some tType, Some eType) =>
               if typeEquality (proj1_sig tType) eType
               then Some tType
               else None
             | _ => None
             end
           else None
         | None => None
         end.

  Global Instance TypeOf__If2
    : forall R, ProgramAlgebra ForTypeOf If2 R (TypeOfResult T)
    := fun _ => {| programAlgebra := typeOf__If2 _ |}.

  Global Instance WellFormedMendlerProgramAlgebra__TypeOf__If2
    : WellFormedMendlerProgramAlgebra TypeOf__If2.
  Proof.
    constructor.
    move => T' T'' f rec [] //.
  Qed.

End If2.


Require Export prop_16.

(** The following theorem states that [x~f -> x=f] *)
(* TODO: XXX bring this from the machine checked proofs of the ACM paper  *)
Axiom Example10_B: forall (x  F z : Bool), [bol x] ~ [bol (const F z )] ->  x ## (const F  z).
Axiom beq_nat_sym: forall n m: nat, (n =? m)%nat = (m =? n)%nat.
Axiom clos_name_do_not_occur: forall n t, ^? t = true -> occur_name_msg n t = false.

(** Unforgeability of a commitment key presented in Proposition 11 of the JCS submission *)
Proposition unforgeCommitKey: forall n t t1, beq_nat n 4 = false -> Fresh (cons n nil) [msg t] = true ->
                                             closMsg t = true ->
                                             (length (mVarMsg t1) <=? 1)%nat = true ->
                                             mVarMsg t1 = (cons n nil) ->
                                             t #? O = FAlse ->
                                             let k := (kc (nonce n)) in
                                             let c := (comm t k) in
                                             ({{n := c}} t1) #? k ## FAlse.
Proof.  intros.
        pose proof(compHid_latest n n O t (compl t) [msg t, msg (compl t)]).
        repeat rewrite complEql in H5. repeat rewrite IFTRUE_M in H5.
        assert(assumption_H3: closMylist [msg O, msg t, msg (compl t)] = true /\
                              closMylist [msg t, msg (compl t)] = true /\
                              Fresh (n ::nil) ([msg O, msg t, msg (compl t), msg t, msg (compl t)]) = true /\
                              Fresh (n ::nil) ([msg O, msg t, msg (compl t), msg t, msg (compl t)]) = true).
        simpl. rewrite H1. simpl. simpl.
        unfold Fresh. simpl. unfold Fresh in H0. simpl in H0.
        assert (occur_name_msg n t = false).
        destruct (occur_name_msg n t).
        simpl in H0. inversion H0.
        Require Import Bool.
        rewrite andb_false_r. reflexivity. reflexivity.
        rewrite H6.
        simpl.
        rewrite H6 in H0; auto.
        (* rewrite H6. simpl. *)
        apply H5 in assumption_H3.
        simpl in assumption_H3.
        (** apply funcApp with pi1 *)
        funappf1 pi1 3 assumption_H3.
        repeat rewrite proj1 in assumption_H3.

        (** apply RESTR **)
        restr_proj_in 4 assumption_H3.

        (** apply FuncApp for submsg_msg **)
        apply funcApp_latest with (p:= 1) (n:= n) (t:=t1) in assumption_H3.
        simpl in assumption_H3.
        Ltac funapp_f2m_new_in g n1 n2 H:= apply FUNCApp_f2m with (f := g) (p1:= n1) (p2:= n2) in H ; simpl in H.
        funapp_f2m_new_in comm 2 4 assumption_H3.
        funapp_eqm_in 2 1 assumption_H3.
        do 5 dropLast_in assumption_H3.

        (** Prove RHS of formula 1 reduces to false *)
        assert((comm (compl t) (fooAxioms.k n)) #?
                     (comm t {{n := comm (compl t) (fooAxioms.k n)}} (t1)) ## FAlse).
        rewrite <- compBind.
        apply Msgneql in H1.
        rewrite H4 in H1. red_in H1. rewrite Example14_M' in H1.
        rewrite H1. redg. reflexivity. rewrite H6 in assumption_H3.

        (* Prove (t1[c1] #? (kc n)) ## FAlse *)
        rewrite <- IFTFb.
        assert( c #? c ## TRue).
        apply EQmsg. reflexivity.
        rewrite <- H7.
        unfold c at 3.
        pose proof(eqbrmsg_bol ((Mvar 4) #? (comm t (Mvar 0))) FAlse 1 2 0).
        simpl in H8.
        Require Export prop_13.
        inversion H1.
        apply sub_clos with (n:=0) (s:= (Mvar 1)) in H1.
        rewrite H1 in H8.
        inversion H10.
        apply sub_clos with (n:=0) (s:= (Mvar 2)) in H10.
        rewrite H10 in H8.
        apply Forall_ELM_EVAL_B3 with (n:= 2) (b:= k) in H8.
        simpl in H8.
        inversion H11.
        apply sub_clos with (n:=2) (s:= k) in H11.
        repeat rewrite H11 in H8.
        apply Forall_ELM_EVAL_B3 with (n:= 1) (b:= ({{n := c}} (t1))) in H8.
        simpl in H8.
        inversion H12.
        apply sub_clos with (n:= 1) (s:= ({{n := c}} (t1))) in H12.
        repeat rewrite H12 in H8.
        apply Forall_ELM_EVAL_B3 with (n:= 4) (b:= c) in H8.
        simpl in H8.
        inversion H13.
        apply sub_clos with (n:= 4) (s:= c) in H13.
        repeat rewrite H13 in H8.
        rewrite single_var_sub in H8.
        unfold k.
        rewrite <- H8.
        apply Example10_B with (z:= FAlse) in assumption_H3.
        unfold const in assumption_H3.
        unfold c.
        unfold k.
        unfold fooAxioms.k in assumption_H3.
        rewrite assumption_H3.
        redg.
        reflexivity; try auto.
        rewrite beq_nat_sym; auto. auto. auto. simpl. rewrite H.
        apply clos_name_do_not_occur with (n:=4) in H14.
        rewrite H14; try auto.
        auto. auto. Qed.


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

(***
Modulus : 2^213 - 3
Base: 53.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 53 + 1/4;
    bitwidth := 64;
    s := 2^213;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


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

(***
Modulus : 2^444 - 17
Base: 55.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 55 + 1/2;
    bitwidth := 64;
    s := 2^444;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e511m187_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 3 *)

Require Import Frap Pset3Sig.

Set Implicit Arguments.

Theorem predicate_abstraction_simulates : forall pc state action
  (pc0 : pc) (st0 : state)
  (actionOf : pc -> action -> pc -> Prop)
  (doAction : action -> state -> state -> Prop)
  (pa : predicate_abstraction state action),
  predicate_abstraction_sound doAction pa
  -> simulates (paR pa)
               (actionSys pc0 st0 actionOf doAction)
               (predicate_abstract pc0 actionOf pa).
Proof.
Admitted.

(* Optional part: using predicate abstraction for another example *)

Import Program2 ZArith.

(* This is not the right abstraction. :-) *)
Definition sys_pa : predicate_abstraction state action := {|
  Predicates := $0;
  Rules := $0 $+ (LockOK, [])
              $+ (AssignA, [])
              $+ (IfFalse, [])
              $+ (IfTrue, [])
              $+ (UnlockOK, [])
              $+ (IncA, [])
              $+ (WhileFalse, [])
              $+ (WhileTrue, [])
|}.

Opaque Zplus. (* Important to keep Coq from trying too hard to help and
               * unfolding the definition of addition for integers! *)

Theorem sys_ok : forall np npo,
  invariantFor (sys np npo) (fun st => fst st = Unlock2 -> (snd st).(HasLock) = true).
Proof.
Admitted.


From Coq Require Import Morphisms.
From Tactical Require Import ProofAutomation.
From Transitions Require Import Relations.

Import RelationNotations.

Generalizable All Variables.

Class NonError {A B T} (r:relation A B T) :=
  non_erroring: forall x, ~r x (Err B T).

Instance nonError_bind
  `{NonError A B T1 r1} `{forall x, @NonError B C T2 (r2 x)}:
  NonError (and_then r1 r2).
Proof.
  unfold NonError, not, and_then in *.
  (intuition idtac); propositional; eauto.
Qed.

Instance nonError_or
         `{NonError A B T r1} `{!NonError r2} :
  NonError (r1 + r2)%rel.
Proof.
  unfold NonError, not, rel_or in *; intros.
  (intuition idtac); propositional; eauto.
Qed.

Instance nonError_equiv A B T :
  Proper (@requiv A B T ==> iff) NonError.
Proof.
  firstorder.
Qed.

Instance nonError_star
         `{NonError A A T r1} :
  NonError (seq_star r1).
Proof.
  unfold NonError, not in *; intros.
  remember (Err A T).
  induction H0; try congruence; eauto.
Qed.

Instance nonError_bind_star
         `{forall x, @NonError A A T (r1 x)} :
  forall x, NonError (bind_star r1 x).
Proof.
  unfold NonError, not in *; intros.
  remember (Err A T).
  induction H0; try congruence; eauto.
Qed.

Instance nonError_puts `(f: A -> A) :
  NonError (puts f).
Proof.
  unfold NonError, not, puts; intros.
  congruence.
Qed.

Instance nonError_reads `(f: A -> T) :
  NonError (reads f).
Proof.
  unfold NonError, not, reads; intros.
  congruence.
Qed.

Instance nonError_none A T :
  @NonError A A T none.
Proof.
  unfold NonError, not, none; intros.
  auto.
Qed.

Definition rel_apply `(r:relation A B T) :
  A -> B -> T -> Prop := fun s s' v => r s (Val s' v).


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e255m765_4limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.