Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Syntax.
Require Import bedrock2.Semantics.
Require Import bedrock2.BasicC64Semantics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ZRange.
Import API.Compilers.

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

(* Declares default parameters for the bedrock2 backend specific to systems with
a 64-bit word size. *)

Section Defaults_64.
  Definition machine_wordsize := 64.

  (* Define how to split mul/multi-return functions *)
  Definition possible_values
    := prefix_with_carry [machine_wordsize; 2 * machine_wordsize]%Z.
  Instance no_select_size : no_select_size_opt :=
    no_select_size_of_no_select machine_wordsize.
  Instance split_mul_to : split_mul_to_opt :=
    split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Instance split_multiret_to : split_multiret_to_opt :=
    split_multiret_to_of_should_split_multiret machine_wordsize possible_values.
  Let wordsize_bytes := Eval vm_compute in (machine_wordsize / 8)%Z.
  Instance default_parameters : Types.parameters :=
    {| semantics := BasicC64Semantics.parameters;
       varname_gen := default_varname_gen;
       error := expr.var Defaults.ERROR;
       word_size_in_bytes := wordsize_bytes;
    |}.
  Instance default_parameters_ok : Types.ok.
  Proof.
    constructor.
    { exact BasicC64Semantics.parameters_ok. }
    { reflexivity. }
    { reflexivity. }
    { reflexivity. }
    { apply prefix_name_gen_unique. }
  Defined.
End Defaults_64.

Module Notations.
  Notation "'uint64,uint64'" := (ident.Literal
                                   (r[0 ~> 18446744073709551615]%zrange,
                                    r[0 ~> 18446744073709551615]%zrange)%core) : expr_scope.
  Notation "'uint64'" :=
    (ident.Literal (t:=Compilers.zrange) r[0 ~> 18446744073709551615]%zrange) : expr_scope.
End Notations.


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 conj20synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv2 (plus Zero (Succ lv1))) (plus Zero (Succ lv1)))).
Admitted.
QuickChick conj20synthconj5.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat .
From mathcomp Require Import bigop ssralg div ssrnum ssrint finset ssrnum ssrnat finmap tuple.

Require Import Premeas Meas Posrat Aux finfun_fixed SeqOps.

Definition dep_cast {A} {B : A -> Type} {x y : A}  (z : B x) (heq : x = y) : B y.
  rewrite -heq; apply z.
Defined.

Lemma cast_existT : forall {A} {P : A -> Type} {x1} {x2} (heq : x1 = x2) (p : P x1),
    existT P x1 p = existT P x2 (dep_cast p heq).
intros.
destruct heq.
simpl.
done.
Qed.

Class type (T : eqType) :=
  {
    denomT : T -> finType;
    tprod : T -> T -> T;
    Hprod : forall t1 t2, denomT (tprod t1 t2) = [finType of (denomT t1) * (denomT t2)]
                                               }.

Section RDef.
  Context (N : choiceType) (T : choiceType) `{type T}.

  Fixpoint Reaction (ns : list (N * T)) (n : N * T) :=
    match ns with
      | nil => meas (denomT n.2)
      | n' :: ns' => (denomT n'.2 -> Reaction ns' n)
                                   end.

  Fixpoint detReaction (ns : list (N * T)) (n : N * T) : Type :=
    match ns with
      | nil => (denomT n.2)
      | n' :: ns' => (denomT n'.2 -> detReaction ns' n)
                                   end.

  Fixpoint lift_det {ns n} (r : detReaction ns n) {struct ns} : Reaction ns n.
  destruct ns; simpl in *.
  apply (ret r).
  apply (fun a => lift_det _ _ (r a)).
  Defined.

  Definition rbind {ns} {ns'} {n n'} (r : Reaction ns n) (k : denomT n.2 -> Reaction (ns ++ ns') n') : Reaction (ns ++ ns') n'.
    induction ns; simpl in *.
    induction ns'; simpl in *.
    apply (mbind r k).
    intro; apply IHns'.
    apply (fun n2 => k n2 X).
    intro; apply IHns.
    apply r; apply X.
    apply (fun n2 => k n2 X).
  Defined.

  Fixpoint detReaction_subst {ns ns'} {n n'} (r : detReaction ns n) (k : Reaction (n :: (ns ++ ns')) n')  {struct ns}
    : Reaction (n :: (ns ++ ns')) n'.
    induction ns.
    simpl in *.
    apply (fun _ => (k r)).
    simpl in *.
    intros x y.
    apply (detReaction_subst _ _ _ _  (r y) (fun z => k z y) x).
  Defined.

  Fixpoint React_eq ns n (r1 r2 : Reaction ns n) {struct ns} : Prop.
    destruct ns; simpl in *.
    apply (r1 = r2).
    apply (forall x, React_eq _ _ (r1 x) (r2 x)).
  Defined.

  Definition subst_arg (ns : list (N * T)) (n n' : N) : list (N * T) :=
  map (fun a => if a.1 == n then (n', a.2) else a) ns.

  Definition React_subst_arg {ns f} (r : Reaction ns f) (n n' : N) : Reaction (subst_arg ns n n') f.
  induction ns.
  apply r.
  simpl in *.
  destruct (a.1 == n).
  simpl in *.
  apply (fun x => IHns (r x)).
  apply (fun x => IHns (r x)).
  Defined.

  Definition React_subst_val {ns f} (r : Reaction ns f) (n n' : N) : Reaction ns (if f.1 == n then n' else f.1, f.2).
  induction ns.
  apply r.
  simpl in *.
  destruct (f.1 == n).
  apply (fun x => IHns (r x)).
  apply (fun x => IHns (r x)).
  Defined.

  Definition Reaction_Perm {t1 t2 t'} (r : Reaction t1 t') : Perm t1 t2 -> Reaction t2 t'.
    intro HR.
    induction HR; simpl in *.
    apply r.
    apply (fun x => IHHR (r x)).
    apply (fun x y => r y x).
    apply IHHR2; apply IHHR1; apply r.
  Defined.

  Definition Reaction_pair {ns} {n n'} t (k1 : Reaction ns n) (k2 : Reaction ns n') : (Reaction ns (t, tprod n.2 n'.2)) * (detReaction ((t, tprod n.2 n'.2) :: ns) n) * (detReaction ((t, tprod n.2 n'.2) :: ns) n').
    induction ns; simpl in *.
    rewrite !Hprod //=.
    apply (k1 ** k2, fst, snd).
    rewrite !Hprod //= in IHns.
    set ih := fun t => IHns (k1 t) (k2 t).
    split.
    split.
    apply (fun t => (ih t).1.1).
    rewrite Hprod //=.
    apply (fun p x => (ih x).1.2 p).
    rewrite Hprod //=.
    apply (fun p x => (ih x).2 p).
  Defined.

Definition reaction :=
  { ns : (list (N * T) * bool * (N * T)) & Reaction ns.1.1 ns.2 }.

Definition reaction_perm (r : reaction) {ns} (Hp : Perm (tag r).1.1 ns) : reaction.
    destruct r; simpl in *.
    econstructor.
    instantiate (1 := (ns, x.1.2, x.2)).
    simpl.
    eapply (Reaction_Perm r Hp).
Defined.

Definition rct {ns n} b (r : Reaction ns n) : reaction := existT _ (ns, b, n) r.
Definition drct {ns n} b (r : detReaction ns n) : reaction := existT _ (ns, b, n) (lift_det r).

Definition reaction_pair (r1 r2 : reaction) (n : N) : (tag r1).1.1 = (tag r2).1.1 -> reaction * reaction * reaction.
intro.
destruct r1, r2; simpl in *.
rewrite H0 in r.
move: (Reaction_pair n r r0) => p.
apply (existT _ (_, false, _) p.1.1, existT (fun ns => Reaction ns.1.1 ns.2) (_,x.1.2,_) (lift_det p.1.2), existT (fun ns => Reaction ns.1.1 ns.2) (_, x0.1.2, _) (lift_det  p.2)).
Defined.

Definition reaction_weak (r : reaction) (n : N * T) : reaction.
    destruct r.
    econstructor.
    instantiate (1 := (n :: x.1.1, x.1.2, x.2)).
    simpl.
    apply (fun _ => r).
Defined.

Definition reaction_subst_arg (r : reaction) (n n' : N) : reaction.
    destruct r.
    econstructor.
    instantiate (1 := (subst_arg x.1.1 n n', x.1.2, x.2)).
    simpl in *.
    apply React_subst_arg.
    apply r.
Defined.

Definition reaction_subst (r : reaction) (n n' : N) : reaction.
    destruct r.
    econstructor.
    instantiate (1 := (subst_arg x.1.1 n n', x.1.2, (if x.2.1 == n then n' else x.2.1, x.2.2))).
    simpl.
    apply React_subst_arg.
    apply React_subst_val.
    apply r.
Defined.

Definition reaction_dep (r : reaction) (n : N) := n \in map fst (tag r).1.1.

Definition rlist := list (reaction + N).

Definition rlist_subst_arg (r : rlist) (n n' : N) : rlist :=
  map (fun a => match a with | inr m => inr m | inl r => inl (reaction_subst_arg r n n') end) r.

Definition rlist_subst (r : rlist) (n n': N) : rlist :=
  map (fun a => match a with | inr m => inr (if m == n then n' else m) | inl r => inl (reaction_subst r n n') end) r.

  Fixpoint RHiddens (r : rlist) : seq N :=
    match r with
      | nil => nil
      | inr _ :: rs => RHiddens rs
      | inl (existT p _) :: rs =>
        if p.1.2 then RHiddens rs else p.2.1 :: RHiddens rs
                                                       end.

Fixpoint ROutputs (r : rlist) : seq N:=
    match r with
      | nil => nil
      | inr _ :: rs => ROutputs rs
      | inl (existT p _) :: rs =>
        if p.1.2 then p.2.1 :: ROutputs rs else ROutputs rs
                                                       end.

  Fixpoint RInputs (r : rlist) : seq N:=
    match r with
    | nil => nil
    | inr n :: rs => n :: RInputs rs
    | inl _ :: rs => RInputs rs
                             end.

    Definition chan_of (x : reaction + N) :=
      match x with
        | inr a => a
        | inl (existT t _) => t.2.1
                                end.

  Definition RChans (r : rlist) : seq N:=
    map chan_of r.

  Definition RArgs (r : rlist) : seq N :=
    flatten (map (fun x =>
                    match x with
                      | inl r => map fst (tag r).1.1
                      | inr _ => nil end) r).

  Definition rlist_nub (r : rlist) :=
    filter (fun p =>
              match p with
                | inl _ => true
                | inr i => i \notin (ROutputs r) end) r.

  Definition rlist_comp (r1 r2 : rlist) := rlist_nub (r1 ++ r2).
  Definition rlist_hide (rs : rlist) (i : N -> bool) : rlist :=
    map (fun r =>
           match r with
           | inl (existT (a, b, c) r) => if i c.1 then inl (existT (fun ns => Reaction ns.1.1 ns.2) (a, false, c) r) else inl (existT (fun ns => Reaction ns.1.1 ns.2) (a, b, c) r)
           | inr m => inr m end) rs.
    Definition r_compat (r1 r2 : rlist) :=
      forall x, (x \in RChans r1) && (x \in RChans r2) ->
                                                        [|| ((x \in RInputs r1) && (x \in ROutputs r2)) |
                                                         ((x \in RInputs r2) && (x \in ROutputs r1))].

  Definition rlist_nub_hide (r : rlist) (chans1 chans2 : seq N) : rlist :=
    pmap (fun rct =>
            match rct with
            | inl (existT (a,b,c) r) => if (c.1 \in chans1) && (c.1 \in chans2) then
                                          Some (inl (existT (fun ns => Reaction ns.1.1 ns.2) (a, false, c) r)) else
                                          Some rct
            | inr i => if (i \in chans1) && (i \in chans2) then None else Some (inr i)
                                                                               end) r.
  Definition rlist_comp_hide r1 r2 :=
    let c1 := RChans r1 in
    let c2 := RChans r2 in
    (rlist_nub_hide r1 c1 c2) ++ (rlist_nub_hide r2 c1 c2).

  Definition use_dominates (rs : rlist) (h : N) (c : N) :=
    all (fun ri =>
           match ri with
             | inl r => (h \in map fst ((tag r).1.1)) ==> (c \in map fst ((tag r).1.1))
             | inr _ => true end) rs.

Notation "G ~> c b D" := (inl (existT (fun ns => Reaction ns.1.1 ns.2) (G, b, c) D)) (at level 80, c at level 9, b at level 9).

Inductive r_rewr_bi : rlist -> rlist -> Prop :=
| rewr_bi_trans : forall r1 r2 r3, r_rewr_bi r1 r2 -> r_rewr_bi r2 r3 -> r_rewr_bi r1 r3
| rewr_bi_sym : forall r1 r2, r_rewr_bi r1 r2 -> r_rewr_bi r2 r1
| rewr_perm : forall rs rs', Perm rs rs' -> r_rewr_bi rs rs'
| rewr_add_ch : forall c rs f g (r : Reaction g f) b,
    c \in g ->
    r_rewr_bi ((g ~> f b r) :: rs)
              (((c :: g) ~> f b (fun _ => r)) :: rs)
| rewr_r_perm : forall rs r {ns} (H : Perm _ ns), r_rewr_bi (inl r :: rs) (inl (reaction_perm r H) :: rs)
| rewr_ext : forall rs G c b (k k' : Reaction G c),
      React_eq _ _ k k' ->
      r_rewr_bi ((G ~> c b k) :: rs)
             ((G ~> c b k') :: rs)
  | rewr_fold : forall rs G1 G2 h (r : Reaction G1 h) n (k : (denomT h.2 -> Reaction (G1 ++ G2) n)) (b : bool) ,
      h.1 \notin RChans rs ->
      h.1 != n.1 ->
      r_rewr_bi (((G1 ++ G2) ~> n b (rbind r k)) :: rs)
                ((G1 ~> h false r) :: ((h :: (G1 ++ G2)) ~> n b k) :: rs)
  | rewr_pair : forall n rs (r1 r2 : reaction) (H : (tag r1).1.1 = (tag r2).1.1),
      n \notin RChans rs ->
      let p := reaction_pair r1 r2 n H in
      r_rewr_bi (inl r1 :: inl r2 :: rs) (inl p.1.1 :: inl p.1.2 :: inl p.2 :: rs)
  | rewr_subst : forall (rs : rlist) ns ns' b1 b2 h f (r : detReaction ns h) (k : Reaction (h :: (ns ++ ns')) f),
      r_rewr_bi
        [:: (ns ~> h b1 (lift_det r)), (h :: (ns ++ ns') ~> f b2 k) & rs]
        [:: (ns ~> h b1 (lift_det r)), (h :: (ns ++ ns') ~> f b2 (detReaction_subst r k)) & rs]
  | rewr_hid_ws :
      forall g1 g2 h (d : Reaction g1 h) c (d' : Reaction (g1 ++ g2) c) b rs,
        r_rewr_bi
         [:: (g1 ~> h false d), ((h :: (g1 ++ g2)) ~> c b (fun _ => d')) & rs]
         [:: (g1 ~> h false d), (((g1 ++ g2)) ~> c b d') & rs]
  | rewr_addrem :
      forall rs h g1 (r : Reaction g1 h),
        all (fun x => x \in RChans rs) (map fst g1) ->
        h.1 \notin RChans rs ->
        r_rewr_bi
          ((g1 ~> h false r) :: rs)
          (rs).

  Inductive r_rewr : rlist -> rlist -> Prop :=
  | rewr_bi_r : forall r1 r2, r_rewr_bi r1 r2 -> r_rewr r1 r2
  | rewr_bi_l : forall r1 r2, r_rewr_bi r1 r2 -> r_rewr r2 r1
  | rewr_refl : forall r, r_rewr r r
  | rewr_trans : forall r1 r2 r3, r_rewr r1 r2 -> r_rewr r2 r3 -> r_rewr r1 r3
  | rewr_weak : forall n (rs : rlist) (r : reaction) (r' : reaction),
      n \in (tag r).1.1 ->
      reaction_dep r' (tag r).2.1 ->
      r_rewr (inl r' :: inl r :: rs)
             (inl (reaction_weak r' n) :: inl r :: rs)
  | rewr_str : forall (rs : rlist) (r : reaction) ns b f (k : Reaction ns f) n,
      (all (fun x => x \in ns) (tag r).1.1) ->
      n = (tag r).2 ->
      r_rewr (inl (existT (fun ns => Reaction ns.1.1 ns.2) (n :: ns, b, _) (fun _ => k)) :: inl r :: rs)
             (inl (existT (fun ns => Reaction ns.1.1 ns.2) (ns, b, _) k) :: inl r :: rs)
  | rewr_str_inp : forall (rs : rlist) (i : N) ns b f (k : Reaction ns f) t,
      r_rewr (inl (existT (fun ns => Reaction ns.1.1 ns.2) ((i, t) :: ns, b, _) (fun _ => k)) :: inr i :: rs)
             (inl (existT (fun ns => Reaction ns.1.1 ns.2) (ns, b, _) k) :: inr i :: rs)
  | rewr_rename : forall rs n n',
      n \notin RInputs rs ->
      n \notin ROutputs rs ->
      n' \notin RChans rs ->
      n' \notin RArgs rs ->
      r_rewr rs (rlist_subst rs n n')
  | rewr_congr : forall rs1 rs2 rs3,
      r_compat rs3 rs1 ->
      r_compat rs3 rs2 ->
      r_rewr (rlist_comp_hide rs3 rs1) (rlist_comp_hide rs3 rs2).

End RDef.

Add Parametric Relation (N T : choiceType) `{type T} : (@rlist N T _) (@r_rewr N T _)
    reflexivity proved by (@rewr_refl _ _ _)
    transitivity proved by (@rewr_trans _ _ _) as r_rewr_rel.

Arguments r_rewr [N T H].
Arguments r_rewr_bi [N T H].
Arguments rct [N T H].
Arguments drct [N T H].
Arguments rbind [N T H ].
Arguments lift_det [N T H].
Arguments Reaction [N T H].
Arguments RChans [N T H].
Arguments ROutputs [N T H].
Arguments RInputs [N T H].
Arguments RHiddens [N T H].
Arguments chan_of [N T H].

Notation "G ~> c 'vis' D" := (inl (existT (fun ns => Reaction ns.1.1 ns.2) (G, true, c) D)) (at level 80).

Notation "G ~> c 'dvis' D" := (inl (existT (fun ns => Reaction ns.1.1 ns.2) (G%SEQ, true, c) (lift_det G c D))) (at level 80).

Notation "G ~> c 'hid' D" := (inl (existT (fun ns => Reaction ns.1.1 ns.2) (G, false, c) D)) (at level 80).

Notation "G ~> c 'dhid' D" := (inl (existT (fun ns => Reaction ns.1.1 ns.2) (G%SEQ, false, c) (lift_det G c D))) (at level 80).

Notation "x1 ~~> x2" := (r_rewr x1 x2) (at level 40).

Notation "x ||| y" := (rlist_comp_hide _ _ x y) (at level 40).
Notation "x |||v y" := (rlist_comp _ _ x y) (at level 40).

Section Liftings.
  Context {N T : choiceType} `{type T}.

Notation "G ~> c b D" := (inl (existT (fun ns => Reaction ns.1.1 ns.2) (G, b, c) D)) (at level 80, c at level 9, b at level 9).

  Lemma rewr_subst_eq (rs : rlist N T) (ns ns2 ns' : seq (N * T)) (b1 b2 : bool) (h f : N * T) (r : detReaction N T ns h) (k : Reaction ns2 f) (k' : Reaction (h :: ns ++ ns') f) :
  existT (fun ns => Reaction ns.1.1 ns.2) (ns2, b2, f) k =
  existT (fun ns => Reaction ns.1.1 ns.2) (h :: ns ++ ns', b2, f) k' ->
  r_rewr_bi [:: ns ~> h b1 (lift_det ns h r), ns2 ~> f b2 k & rs]
            [:: ns ~> h b1 lift_det ns h r, h :: ns ++ ns' ~> f b2 detReaction_subst N T r k' & rs].
    intro.
    rewrite H0.
    apply rewr_subst.
  Qed.

    Lemma lift_det0  b h (f : denomT h.2) :
      existT (fun (ns : seq (N * T) * bool * (N * T)) => Reaction ns.1.1 ns.2) (nil, b, h) (ret f) =
      existT (fun (ns : seq (N * T) * bool * (N * T)) => Reaction ns.1.1 ns.2) (nil, b, h) (lift_det nil h f).
      done.
    Qed.

    Lemma lift_det1 (n : N * T) b h (f : denomT n.2 -> denomT h.2) :
      existT (fun (ns : seq (N * T) * bool * (N * T)) => Reaction ns.1.1 ns.2) ([:: n], b, h) (fun x => ret (f x)) =
      existT (fun ns => Reaction ns.1.1 ns.2) ([:: n], b, h) (lift_det  [:: n] h f).
      done.
    Qed.

    Lemma lift_det2 (n n' : N * T) b h (f : denomT n.2 -> denomT n'.2 -> denomT h.2) :
      existT (fun (ns : seq (N * T) * bool * (N * T)) => Reaction ns.1.1 ns.2) ([:: n; n'], b, h) (fun x y => ret (f x y)) =
      existT (fun ns => Reaction ns.1.1 ns.2) ([:: n; n'], b, h) (lift_det  [:: n; n'] h f).
      done.
    Qed.

    Lemma lift_det3 (n n' n'' : N * T) b h (f : denomT n.2 -> denomT n'.2 -> denomT n''.2 -> denomT h.2) :
      existT (fun (ns : seq (N * T) * bool * (N * T)) => Reaction ns.1.1 ns.2) ([:: n; n'; n''], b, h) (fun x y z => ret (f x y z)) =
      existT (fun ns => Reaction ns.1.1 ns.2) ([:: n; n'; n''], b, h) (lift_det  [:: n; n'; n''] h f).
      done.
    Qed.

    Lemma lift_bind t f (m : meas (denomT t)) (k : denomT t -> meas (denomT f.2)) (n : N) :
      @React_eq _ _ _ nil f (mbind m k) (rbind nil nil (n,t) f m k).
      rewrite /rbind //=.
    Qed.

    Check rbind.

    Lemma lift_bind1 (p : N * T) t f (n : N) (m : denomT p.2 -> meas (denomT t)) (k : denomT p.2 -> denomT t -> meas (denomT f.2)) :
      @React_eq _ _ _ [:: p] f (fun x => mbind (m x) (k x))
                               (rbind [:: p] nil (n,t) f m (fun n2 p2 => k p2 n2)).
      rewrite /rbind //=.
    Qed.

End Liftings.

Ltac get_rs :=
  match goal with
  | [ |- @r_rewr _ _ _ ?rs _] => rs
                                   end.

  (* n may be either a nat or a name; if a nat, just return the nat; if something else, find the index of the reaction with the corresponding name *)
  Ltac r_idx_of n :=
    match (type of n) with
    | nat => n
    | _ =>
      let rs := get_rs in
      let i := eval compute in (ofind rs (fun m => chan_of m == n)) in
        match i with
            | Some ?a => a
            | None => fail "sequent not found: " n
                            end
             end.

Ltac get_args0 :=
    match goal with
    | [ |- @r_rewr _ _ _ (inl ?r :: _) _ ] => constr:((tag r).1.1)
        end.

Ltac get_args1 :=
    match goal with
    | [ |- @r_rewr _ _ _ (_ :: (inl ?r) :: _) _ ] => constr:((tag r).1.1)
        end.

  (* n may be either a nat or a name; if a nat, return the nat; if something else, find the index of the argument that matches the name in the first reaction *)
  Ltac arg_idx_of n :=
    match (type of n) with
    | nat => n
    | _ =>
      let args := get_args0 in
      let i := eval compute in (ofind args (fun p => p.1 == n)) in
            match i with
                | Some ?a => a
                | None => fail "argument not found: " n
                                end
             end.

  (* move 'from' to 'to' *)
  Ltac r_move from to :=
   let i := r_idx_of from in
   let j := r_idx_of to in
   etransitivity; [apply rewr_bi_r; apply rewr_perm; apply (Perm_swap_irrel i j) | idtac]; rewrite /swap /=.

  (* move arguments 'from' to 'to'  in the first reaction *)
  Ltac arg_move from to :=
   let i := arg_idx_of from in
   let j := arg_idx_of to in
   etransitivity; [apply rewr_bi_r; apply (rewr_r_perm _ _ _ _ (Perm_swap i j _)) | idtac]; rewrite /swap /=.

    (* move 'n' to front arg *)
  Ltac arg_focus n :=
    let i := arg_idx_of n in
    arg_move i 0%N.

  (* if x and y have the same arguments, take their product and name it n *)
  Ltac r_prod x y n := r_move x 0%N; r_move y 0%N; etransitivity; [
                     apply rewr_bi_r; apply: (rewr_pair _ _ n); done | simpl].

  (* move 'n' (name or index) to 0 and execute t, and move it back *)
    Ltac r_at n t := r_move n 0%N; t; r_move n 0%N.

    Ltac r_weak_ n t := rewrite (rewr_weak _ _ (n, t)); [idtac | done | done]; rewrite /=.

    (* weaken reaction n1, which uses reaction n2, by arg 'n' of type t (which must be in n2) *)
    Ltac r_weak_by n1 n2 n t :=
      r_move n1 0%N;
      r_move n2 1%N;
      r_weak_ n t.

    (* find arg in n2 that does not appear in n1 *)
    Ltac r_find_weak n1 n2 k :=
      r_move n1 0%N;
      r_move n2 1%N;
      let args1 := get_args0 in
      let args2 := get_args1 in
      let chk := eval compute in (n2 \in map fst args1) in
        match chk with
        | false => fail "reaction value " n2 " not found in " n1
        | true =>
        let x := eval compute in (ofind_val args2 (fun x => x \notin args1)) in
        k x
        end.

    Ltac r_weak n1 n2 :=
      r_find_weak n1 n2
        ltac:(fun p =>
           let j := eval compute in p in
           match j with
           | Some ?p1p2 => r_weak_by n1 n2 constr:(p1p2.1) constr:(p1p2.2); r_weak n1 n2
           | None => idtac
           | _ => idtac "hello" j
                    end).

    Ltac ensure_arg_prefix ns ctr :=
      match ns with
      | nil => idtac
      | (?x :: ?xs) =>
        arg_move x ctr; ensure_arg_prefix xs (S ctr)
                                          end.

    (* substute f`/eterministic x into y *)
Ltac get_val0 :=
  match goal with
  | [ |- r_rewr (inl ?r :: _) _] => constr:((tag r).2)
                                           end.

    Ltac r_subst x y :=
      r_weak y x;
      r_move y 0%N;
      let a := get_args1 in
      let ys := eval compute in (map fst a) in
      ensure_arg_prefix ys 0%N;
      arg_focus x;
      r_move x 0%N;
      let b := get_args1 in
      let xs := eval compute in (map fst b) in
      rewrite ?lift_det0 ?lift_det1 ?lift_det2 ?lift_det3;
      let h := get_val0 in
      let zs := eval compute in (extract_right_cons_cat h a b) in
      match zs with
          | None => fail "subst failure"
          | Some ?z =>
            etransitivity; [ apply rewr_bi_r; apply: (rewr_subst_eq _ _ _ z); apply erefl | idtac]; simpl
                                                                                end.

    Ltac r_str_ := etransitivity; [apply rewr_str; done | idtac].

    (* drop n2 from n1 *)
    Ltac r_str n1 n2 :=
      r_move n1 0%N;
      r_move n2 1%N;
      arg_focus n2;
      r_str_.

    Ltac r_str_inp n1 n2 :=
      r_move n1 0%N;
      r_move n2 1%N;
      arg_focus n2;
      rewrite rewr_str_inp.

    Ltac r_weakstr n1 n2 :=
      r_weak n1 n2;
      r_str n1 n2.

    (* rename : rename x to y; requires x is a hidden action *)
    Ltac r_rename x y := etransitivity; [apply (rewr_rename _ _ _ x y); done | idtac]; simpl.

    (* ext : operates on the first reaction. *)
    Ltac r_ext m tm :=
      r_move m 0%N;
      etransitivity; [apply rewr_bi_r; apply rewr_ext; instantiate (1 := tm); rewrite /React_eq //= | idtac].

  Arguments rbind [N T H ].

  (* if 'm' is a bind, lift the bind to fresh arg 'n' of type 't' *)
    Ltac unfold_bind0 n midn midty :=
    match goal with
    | [ |- @r_rewr _ _ _ (inl (existT _ (_, _, ?to) (mbind ?m ?k)) :: ?rs) _] =>
      etransitivity; [
        apply rewr_bi_r; apply: (@rewr_ext _ _ _ _ _ _ _ _ (rbind nil nil (midn, midty) to _ _)); done | idtac]
    end;
    etransitivity; [ apply rewr_bi_r; apply rewr_fold; done | idtac]; rewrite /rct /=.

    Ltac unfold_bind1 n midn midty :=
    match goal with
    | [ |- @r_rewr _ _ _ (inl (existT _ (?ns, _, ?to) (fun x => mbind ?m ?k)) :: ?rs) _] =>
      etransitivity; [
        apply rewr_bi_r; apply: (@rewr_ext _ _ _ _ _ _ _ _ (rbind ns nil (midn, midty) to _ _)); done | idtac]
    end;
    etransitivity; [ apply rewr_bi_r; apply rewr_fold; done | idtac]; rewrite /rct /=.

    Ltac unfold_bind2 n midn midty :=
    match goal with
    | [ |- @r_rewr _ _ _ (inl (existT _ (?ns, _, ?to) (fun x y => mbind ?m ?k)) :: ?rs) _] =>
      etransitivity; [
        apply rewr_bi_r; apply: (@rewr_ext _ _ _ _ _ _ _ _ (rbind ns nil (midn, midty) to _ _)); done | idtac]
    end;
    etransitivity; [ apply rewr_bi_r; apply rewr_fold; done | idtac]; rewrite /rct /=.

    Ltac unfold_bind3 n midn midty :=
    match goal with
    | [ |- @r_rewr _ _ _ (inl (existT _ (?ns, _, ?to) (fun x y z => mbind ?m ?k)) :: ?rs) _] =>
      etransitivity; [
        apply rewr_bi_r; apply: (@rewr_ext _ _ _ _ _ _ _ _ (rbind ns nil (midn, midty) to _ _)); done | idtac]
    end;
    etransitivity; [ apply rewr_bi_r; apply rewr_fold; done | idtac]; rewrite /rct /=.

    Ltac unfold_bind4 n midn midty :=
    match goal with
    | [ |- @r_rewr _ _ _ (inl (existT _ (?ns, _, ?to) (fun x y z w => mbind ?m ?k)) :: ?rs) _] =>
      etransitivity; [
        apply rewr_bi_r; apply: (@rewr_ext _ _ _ _ _ _ _ _ (rbind ns nil (midn, midty) to _ _)); done | idtac]
    end;
    etransitivity; [ apply rewr_bi_r; apply rewr_fold; done | idtac]; rewrite /rct /=.

    Ltac unfold_bind n midn midty :=
    r_move n 0%N;
    match goal with
    | [ |- @r_rewr _ _ _ (inl (existT _ (?ns, _, ?to) _) :: _) _] =>
      match ns with
        | nil => unfold_bind0 n midn midty
        | _ :: nil => unfold_bind1 n midn midty
        | _ :: _ :: nil => unfold_bind2 n midn midty
        | _ :: _ :: _ :: nil => unfold_bind3 n midn midty
      end
        end.

    (* remove redundant 'm' *)
    Ltac r_remove m :=
      r_move m 0%N;
      etransitivity; [apply rewr_bi_r; apply (rewr_addrem _ _); done | idtac]; simpl.

    Ltac r_clean :=
      match goal with
      | [ |- @r_rewr _ _ _ ?rs _ ] =>
        let p := eval compute in (ofind_val (RHiddens rs) (fun n => n \notin RArgs _ _ rs) ) in
            match p with
              | Some ?n => r_remove n
              | _ => fail "no more to clean"
            end
              end.

    Ltac r_align_rec rs c :=
      match rs with
        | nil => idtac
        | ?r :: ?rs' =>
          r_move (chan_of r) c;
          r_align_rec rs' (S c)
                      end.

    Ltac r_align :=
      match goal with
      | [ |- @r_rewr _ _ _ _ ?rs] => r_align_rec rs 0%N
                                                 end.

  (* TODO: fold *)

  (* TODO: dep *)

  (* TODO: comp? *)

  (* TODO: unprod *)

  (* TODO: add *)


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(** ** FMsetC_SAT is undecidable *)

(*
  Undecidability Result(s):
    Finite Multiset Constraint Solvability (FMsetC_SAT)
*)

Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.SetConstraints.FMsetC.
Require Undecidability.SetConstraints.Reductions.H10UC_SAT_to_FMsetC_SAT.

Require Import Undecidability.DiophantineConstraints.H10C_undec.

(* Undecidability of Finite Multiset Constraint Solvability *)
Theorem FMsetC_SAT_undec : undecidable FMsetC_SAT.
Proof.
  apply (undecidability_from_reducibility H10UC_SAT_undec).
  exact H10UC_SAT_to_FMsetC_SAT.reduction.
Qed.

Check FMsetC_SAT_undec.


Require Import ReferencesImpl.
Require Import CapabilitiesAppl.
Require Import IndicesImpl.
Require Import ObjectsAppl.
Require Import SystemStateAppl.
Require Import SemanticsDefinitionsAppl.
Require Import RefSetsAppl.
Require Import SemanticsAppl.
Require Import ExecutionAppl.
Require Import AccessEdgeAppl.
Require Import AccessGraphsAppl.
Require Import SequentialAccessAppl.
Require Import CapSetsAppl.

Require Import Subsystem.
Require Import SubsystemImpl.

Module NatSubsystem <:
  SubsystemType NatReference NatRefSet NatAccessEdge NatAccessGraph NatSeqAcc NatCapability  NatCapSet NatIndex NatObject NatState NatSemDefns NatSemantics NatExecution :=
  MakeSubsystem NatReference NatRefSet NatAccessEdge NatAccessGraph NatSeqAcc NatCapability  NatCapSet NatIndex NatObject NatState NatSemDefns NatSemantics NatExecution.


(*|
##########################################
Coq identity term which is not ``eq_refl``
##########################################

:Link: https://stackoverflow.com/q/35157052
|*)

(*|
Question
********

I am still wondering what it means that a term of the equality type
``eq`` in Coq can be different from ``eq_refl``.

Is the following term an example for this?

.. code-block:: coq

    ((fun x:nat => eq_refl x) 2).

This term is syntactically different from ``eq_refl``, but
nevertheless it computes to ``eq_refl``.

Does there exist examples of terms which do not compute to
``eq_refl``?

P.S. Its not a homework question ;-)
|*)

(*|
Answer
******

As you point out, ``(fun x => eq_refl x) 2`` is *not* actually
different from ``eq_refl 2``, since both expressions compute to the
same thing.

Answering your second question is a bit delicate, because it can be
interpreted in many different ways. Here's one possibility (which I
think is the one you had in mind):

    Are there any type ``T`` and terms ``x y : T``, such that there is
    a proof ``e`` of ``@eq T x y`` in the empty context that does
    *not* compute to ``@eq_refl T z`` (where ``z : T`` is the result
    of computing ``x`` and ``y``)?

I believe that the answer to this question is no. It should be
possible to prove it formally by arguing that, since Coq's theory is
strongly normalizing, ``e`` must have a normal form ``e'``, and that
all normal forms that have type ``eq`` must be ``eq_refl``.

Note that, if drop the requirement that ``e`` is typed in the empty
context, this does not hold anymore. For instance, consider the proof
term of ``forall n, n + 0 = n``.
|*)

Fixpoint plus_n_0 n : n + 0 = n :=
  match n return n + 0 = n with
  | 0 => eq_refl 0
  | S n' => match plus_n_0 n' in _ = m return S (n' + 0) = S m with
            | eq_refl => eq_refl (S (n' + 0))
            end
  end.

(*|
In the successor branch, we use the ``match`` to produce a proof of
``S (n' + 0) = S n'`` which does *not* compute to ``eq_refl``. This
happens because the ``match`` cannot reduce the ``plus_n_0 n'`` term,
since it's a function applied to a variable. However, if we apply
``plus_n_0`` to any concrete natural number (say, ``1729``), the
resulting proof will compute to ``eq_refl 1729`` (try it!).

Another thing worth pointing out is that, when arguing that every
closed proof of equality computes to ``eq_refl``, we had to reason
*outside* of Coq's logic, appealing to a normalization argument that
we cannot phrase as a Coq proposition: note that, because Coq
identifies terms up to convertibility, there's no way of writing a
proposition ``P : nat -> Prop`` such that ``P n`` holds if and only if
``n`` is a Coq term in normal form.

Given this fact, you may wonder if there's anyway of establishing that
result *inside* Coq's logic; that is,

.. code-block:: coq

    forall T (x : T) (e : x = x), e = eq_refl x,

or, paraphrased in English, "every proof of equality is equal to
``eq_refl``". As it turns out, this statement is *independent* of
Coq's logic, which means that it cannot be proved nor disproved within
Coq itself.

It may seem at first that this contradicts what I said earlier. But
recall that we can always add new axioms to Coq's logic if they don't
contradict results that can be proved inside the logic. This means
that it is perfectly fine to assume that there exists *some* type
``T``, *some* term ``x : T``, and *some* proof ``e`` of ``x = x`` such
that ``e <> eq_refl x``. If we added this axiom, then the argument I
gave earlier would no longer apply, since there would be normal forms
of equality proofs that would be syntactically different from
``eq_refl`` (namely, ``e``).

The fact that we cannot establish this result inside Coq's logic (and
similar formal systems, such as Martin-Löf's type theory) is exactly
what enables homotopy type theory. HoTT postulates the existence of
the univalence axiom, which allows one to produce provably different
proofs of equality.

**Edit** It is important to remember that there are two notions of
equality in Coq: *definitional equality* (i.e., terms that are equal
by simplification) and *propositional equality* (i.e., terms that we
can relate by ``=``). Definitionally equal terms are interchangeable
for Coq, whereas propositionally equal terms must be exchanged with an
explicit rewriting step (or using the ``match`` statement, as seen
above).

I was a bit lax in the discussion above about the difference between
these two variants. There are cases where proofs of equality are
propositionally equal even if they aren't so definitionally. For
instance, consider the following alternate proof of reflexivity for
``nat``:
|*)

Fixpoint eq_refl_nat (n : nat) : n = n :=
  match n return n = n with
  | 0 => eq_refl 0
  | S n' => match eq_refl_nat n' in _ = m return S n' = S m with
            | eq_refl => eq_refl (S n')
            end
  end.

(*|
The term ``eq_refl_nat`` is *not* definitionally equal to ``eq_refl``:
we cannot obtain ``eq_refl`` from ``eq_refl_nat`` just by
simplification. However, both are *propositionally* equal: as it turns
out, for ``nat``, it is possible to show that ``forall n (e : n = n),
e = eq_refl``. (As I mentioned above, this cannot be shown for
arbitrary Coq types.)

----

**Q:** your function ``eq_refl_nat`` is an example for a function
which is propositionally equal to ``eq_refl`` but not definitionally
equal. Is my simpler function above, ``fun x:nat => eq_refl x``, of
the same kind?

**A:**
No, because that is definitionally equal to ``eq_refl``, although it relies on a feature that was added to Coq only recently: eta conversion. You can try to write
|*)

Check (eq_refl : (fun n : nat => eq_refl n) = @eq_refl nat).

(*|
which has the effect of testing whether two things are definitionally
equal.

**A:** Regarding "It should be possible to prove it formally by
arguing that, since Coq's theory is strongly normalizing," Coq's
theory may be strongly normalizing, but Coq's implementation is not.
Closing a proof of equality with ``Qed`` will have it not reducing to
``eq_refl``. You can also break subject reduction using coinductive
types, so I suspect you can use this to block equality reduction.
|*)


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.ftc.Continuity.

Section Definitions.

(**
* Derivatives

We will now proceed toward the development of differential calculus.
To begin with, the main notion is that of derivative.

At this stage we will not define a notion of differentiable function,
mainly because the natural definition (that of being a function which
has some derivative) poses some technical problems; thus, we will
postpone that part of our work to a subsequent stage.

Derivative is a binary relation in the type of partial functions,
dependent (once again) on a compact interval with distinct
endpoints#. #%\footnote{%As before, we do not define pointwise
differentiability, mainly for coherence reasons.  See Bishop [1967]
for a discussion on the relative little interest of that concept.%}.%
The reason for requiring the endpoints to be apart is mainly to be
able to derive the usual properties of the derivative
relation---namely, that any two derivatives of the same function must
coincide.

%\begin{convention}% Let [a,b:IR] with [a [<] b] and denote by [I] the
interval [[a,b]].  Throughout this chapter, [F, F', G, G'] and [H]
will be partial functions with domains respectively [P, P', Q, Q'] and
[R].
%\end{convention}%
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Variable F : PartIR.
(* begin hide *)
Let P := Dom F.
(* end hide *)

Definition Derivative_I F' (P':=Dom F') := included I (Dom F) and included I (Dom F') and
 (forall e, [0] [<] e -> {d : IR | [0] [<] d | forall x y, I x -> I y -> forall Hx Hy Hx',
 AbsIR (x[-]y) [<=] d -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e[*]AbsIR (y[-]x)}).

End Definitions.

Arguments Derivative_I [a b].

Section Basic_Properties.

(**
** Basic Properties
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

(**
Like we did for equality, we begin by stating a lemma that makes proofs of derivation easier in practice.
*)

Lemma Derivative_I_char : forall F F' (P:=Dom F) (P':=Dom F'),
 included I (Dom F) -> included I (Dom F') ->
 (forall e,  [0] [<] e -> {d : IR | [0] [<] d | forall x y, I x -> I y -> forall Hx Hy Hx',
 AbsIR (x[-]y) [<=] d -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e[*]AbsIR (y[-]x)}) ->
 Derivative_I Hab' F F'.
Proof.
 (* begin hide *)
 unfold Hab in |- *.
 intros.
 repeat (split; auto).
Qed.
(* end hide *)

(**
Derivative is a well defined relation; we will make this explicit for both arguments:
*)

Variables F G H : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
Let R := Dom H.
(* end hide *)

Lemma Derivative_I_wdl : Feq I F G ->
 Derivative_I Hab' F H -> Derivative_I Hab' G H.
Proof.
 intros H0 H1.
 elim H0; intros incF H0'.
 elim H0'; intros incG Heq.
 elim H1; intros incF' H2.
 elim H2; intros incH H3.
 clear H0' H1 H2.
 apply Derivative_I_char; auto.
 intros e He.
 elim (H3 e He); clear H3; intros d H1 H2.
 exists d; auto.
 intros x y H3 H4 Hx Hy Hx' H5.
 astepl (AbsIR (F y (incF y H4) [-]F x (incF x H3) [-]H x Hx'[*] (y[-]x))); auto.
Qed.

Lemma Derivative_I_wdr : Feq I F G ->
 Derivative_I Hab' H F -> Derivative_I Hab' H G.
Proof.
 intros H0 H1.
 elim H0; intros incF H0'.
 elim H0'; intros incG Heq.
 elim H1; intros incH H2.
 elim H2; intros incF0 H3.
 apply Derivative_I_char; auto.
 intros e He.
 elim (H3 e He); clear H3; intros d H3 H4.
 exists d; auto.
 intros x y H5 H6 Hx Hy Hx' H7.
 astepl (AbsIR (H y Hy[-]H x Hx[-]F x (incF x H5) [*] (y[-]x))); auto.
Qed.

(* begin hide *)
Let Derivative_I_unique_lemma :
  forall x : IR,
  Compact Hab x ->
  forall d : IR,
  [0] [<] d -> {y : IR | AbsIR (x[-]y) [<=] d | Compact Hab y and y[-]x [#] [0]}.
Proof.
 intros x Hx d Hd.
 elim (less_cotransitive_unfolded _ _ _ Hab' x); intro.
  exists (Max a (x[-]d [/]TwoNZ)); auto.
   eapply leEq_wdl.
    2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
    apply less_leEq; apply shift_minus_less'; apply shift_less_plus.
    apply less_leEq_trans with (x[-]d [/]TwoNZ).
     apply minus_resp_less_rht.
     apply pos_div_two'; assumption.
    simpl in |- *.
    apply rht_leEq_Max.
   apply shift_leEq_minus.
   simpl in |- *.
   astepl (Max a (x[-]d [/]TwoNZ)).
   apply less_leEq.
   apply Max_less; [ assumption | astepr (x[-][0]) ].
   apply minus_resp_less_rht; apply pos_div_two; assumption.
  split.
   split.
    apply lft_leEq_Max.
   apply Max_leEq.
    apply less_leEq; assumption.
   apply leEq_transitive with x.
    apply shift_minus_leEq; apply shift_leEq_plus'; astepl ZeroR.
    apply less_leEq; apply pos_div_two; assumption.
   inversion_clear Hx; assumption.
  apply less_imp_ap; apply shift_minus_less; astepr x; apply Max_less.
   assumption.
  apply shift_minus_less; apply shift_less_plus'; astepl ZeroR.
  apply pos_div_two with (eps := d); assumption.
 exists (Min b (x[+]d [/]TwoNZ)).
  apply leEq_wdl with (Min b (x[+]d [/]TwoNZ) [-]x).
   apply less_leEq.
   apply shift_minus_less.
   rstepr (x[+]d).
   eapply leEq_less_trans.
    apply Min_leEq_rht.
   apply plus_resp_less_lft.
   apply pos_div_two'; assumption.
  apply eq_symmetric_unfolded.
  eapply eq_transitive_unfolded; [ apply AbsIR_minus | apply AbsIR_eq_x ].
  apply less_leEq; apply shift_less_minus; astepl x; apply less_Min.
   assumption.
  astepl (x[+][0]); apply plus_resp_less_lft.
  apply pos_div_two; assumption.
 split.
  split.
   apply leEq_Min.
    auto.
   apply leEq_transitive with x.
    inversion_clear Hx; auto.
   astepl (x[+]ZeroR); apply plus_resp_leEq_lft; apply less_leEq; apply pos_div_two; assumption.
  apply Min_leEq_lft.
 apply Greater_imp_ap.
 apply shift_less_minus; astepl x.
 astepr (Min b (x[+]d [/]TwoNZ)); apply less_Min.
  assumption.
 astepl (x[+][0]); apply plus_resp_less_lft; apply pos_div_two; assumption.
Qed.
(* end hide *)

(**
Derivative is unique.
*)

Lemma Derivative_I_unique : Derivative_I Hab' F G -> Derivative_I Hab' F H ->
 Feq I G H.
Proof.
 intros H0 H1.
 elim H0; intros incF H2.
 elim H2; intros incG H3.
 elim H1; intros incF' H6.
 elim H6; intros incH H4.
 clear H0 H2 H6.
 apply eq_imp_Feq; auto.
 intros x H0 Hx Hx'.
 apply cg_inv_unique_2.
 apply AbsIR_approach_zero; intros e H2.
 elim (H3 _ (pos_div_two _ _ H2)).
 intros dg H6 H7.
 elim (H4 _ (pos_div_two _ _ H2)).
 clear H4 H3; intros dh H3 H4.
 set (d := Min (Min dg dh) [1]) in *.
 elim (Derivative_I_unique_lemma x H0 d).
  intros y Hy' Hy''.
  elim Hy''; clear Hy''; intros Hy'' Hy.
  apply mult_cancel_leEq with (AbsIR (y[-]x)).
   apply AbsIR_pos; assumption.
  eapply leEq_wdl.
   2: apply AbsIR_resp_mult.
  set (Hxx := incF x H0) in *.
  set (Hyy := incF y Hy'') in *.
  apply leEq_wdl with (AbsIR (F y Hyy[-]F x Hxx[-]H x Hx'[*] (y[-]x) [-]
    (F y Hyy[-]F x Hxx[-]G x Hx[*] (y[-]x)))).
   2: apply un_op_wd_unfolded; rational.
  eapply leEq_transitive.
   apply triangle_IR_minus.
  rstepr (e [/]TwoNZ[*]AbsIR (y[-]x) [+]e [/]TwoNZ[*]AbsIR (y[-]x)).
  apply plus_resp_leEq_both; [ apply H4 | apply H7 ]; try assumption;
    eapply leEq_transitive; try apply Hy'; unfold d in |- *; eapply leEq_transitive.
     apply Min_leEq_lft.
    apply Min_leEq_rht.
   apply Min_leEq_lft.
  apply Min_leEq_lft.
 unfold d in |- *; repeat apply less_Min; [ assumption | assumption | apply pos_one ].
Qed.

(**
Finally, the set where we are considering the relation is included in the domain of both functions.
*)

Lemma derivative_imp_inc : Derivative_I Hab' F G -> included I P.
Proof.
 intro H0.
 inversion_clear H0; assumption.
Qed.

Lemma derivative_imp_inc' : Derivative_I Hab' F G -> included I Q.
Proof.
 intro H0.
 elim H0; intros H1 H2.
 inversion_clear H2; assumption.
Qed.

(**
Any function that is or has a derivative is continuous.
*)

Variable Hab'' : a [<=] b.

Lemma deriv_imp_contin'_I : Derivative_I Hab' F G -> Continuous_I Hab'' G.
Proof.
 intro derF.
 elim derF; intros incF H0.
 elim H0; intros incG derivFG.
 clear derF H0.
 split.
  Included.
 intros e He.
 elim (derivFG _ (pos_div_two _ _ He)); intros d posd Hde; clear derivFG.
 exists d. auto. intros x y H0 H1 Hx Hy H2.
  set (Hx' := incF _ H0) in *.
 set (Hy' := incF _ H1) in *.
 apply equal_less_leEq with (a := ZeroR) (b := AbsIR (y[-]x)); intros.
   3: apply AbsIR_nonneg.
  apply mult_cancel_leEq with (AbsIR (y[-]x)); auto.
  rstepr (e [/]TwoNZ[*]AbsIR (y[-]x) [+]e [/]TwoNZ[*]AbsIR (y[-]x)).
  eapply leEq_wdl.
   2: apply AbsIR_resp_mult.
  apply leEq_wdl with (AbsIR (F y Hy'[-]F x Hx'[-]G x Hx[*] (y[-]x) [+]
    (F x Hx'[-]F y Hy'[-]G y Hy[*] (x[-]y)))).
   2: eapply eq_transitive_unfolded.
    2: apply AbsIR_inv.
   2: apply AbsIR_wd; rational.
  eapply leEq_transitive.
   apply triangle_IR.
  apply plus_resp_leEq_both.
   auto.
  apply leEq_wdr with (e [/]TwoNZ[*]AbsIR (x[-]y)).
   apply Hde; auto.
   eapply leEq_wdl.
    apply H2.
   apply AbsIR_minus.
  apply mult_wdr; apply AbsIR_minus.
 apply leEq_wdl with ZeroR.
  apply less_leEq; auto.
 astepl (AbsIR [0]).
 apply AbsIR_wd.
 apply eq_symmetric_unfolded; apply x_minus_x.
 apply pfwdef.
 apply cg_inv_unique_2.
 apply AbsIR_eq_zero.
 apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
  apply H3.
 apply AbsIR_minus.
Qed.

Lemma deriv_imp_contin_I : Derivative_I Hab' F G -> Continuous_I Hab'' F.
Proof.
 intro derF.
 elim derF; intros incF H2; elim H2; clear H2; intros incG deriv.
 split; auto.
 intros e He.
 elim deriv with e; auto.
 clear deriv; intros d posd Hd.
 set (contG := deriv_imp_contin'_I derF) in *.
 set (M := Norm_Funct contG) in *.
 set (D := Min d (Min ([1] [/]TwoNZ) (e[/] _[//]
   mult_resp_ap_zero _ _ _ (two_ap_zero IR) (max_one_ap_zero M)))) in *.
 exists D.
  unfold D in |- *; repeat apply less_Min.
    auto.
   apply (pos_half IR).
  apply div_resp_pos; auto.
  apply shift_less_mult' with (two_ap_zero IR).
   apply pos_two.
  astepl ZeroR.
  eapply less_leEq_trans.
   2: apply rht_leEq_Max.
  apply pos_one.
 intros x y H0 H1 Hx Hy H2.
 apply leEq_wdl with (AbsIR (F x Hx[-]F y Hy[-]G y (incG _ H1) [*] (x[-]y) [+]
   G y (incG _ H1) [*] (x[-]y))).
  2: apply AbsIR_wd; rational.
 eapply leEq_transitive.
  apply triangle_IR.
 rstepr (e [/]TwoNZ[+]e [/]TwoNZ).
 apply plus_resp_leEq_both.
  apply leEq_transitive with (e[*]AbsIR (x[-]y)).
   apply Hd; auto.
   apply leEq_transitive with D.
    eapply leEq_wdl; [ apply H2 | apply AbsIR_minus ].
   unfold D in |- *; apply Min_leEq_lft.
  rstepr (e[*][1] [/]TwoNZ).
  apply mult_resp_leEq_lft.
   apply leEq_transitive with D; auto.
   unfold D in |- *; eapply leEq_transitive; [ apply Min_leEq_rht | apply Min_leEq_lft ].
  apply less_leEq; auto.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
 apply leEq_transitive with (Max M [1][*]AbsIR (x[-]y)).
  apply mult_resp_leEq_rht.
   2: apply AbsIR_nonneg.
  eapply leEq_transitive.
   2: apply lft_leEq_Max.
  unfold M in |- *; apply norm_bnd_AbsIR; auto.
 apply shift_mult_leEq' with (max_one_ap_zero M).
  eapply less_leEq_trans; [ apply pos_one | apply rht_leEq_Max ].
 eapply leEq_wdr.
  eapply leEq_transitive.
   apply H2.
  unfold D in |- *.
  eapply leEq_transitive; apply Min_leEq_rht.
 rational.
Qed.

End Basic_Properties.

(**
If [G] is the derivative of [F] in a given interval, then [G] is also the derivative of [F] in any smaller interval.
*)

Lemma included_imp_deriv : forall a b Hab c d Hcd F F',
 included (compact c d (less_leEq _ _ _ Hcd)) (compact a b (less_leEq _ _ _ Hab)) ->
 Derivative_I Hab F F' -> Derivative_I Hcd F F'.
Proof.
 intros a b Hab c d Hcd F F' H H0.
 elim H0; clear H0; intros incF H0.
 elim H0; clear H0; intros incF' H0.
 apply Derivative_I_char.
   apply included_trans with (Compact (less_leEq _ _ _ Hab)); auto.
  apply included_trans with (Compact (less_leEq _ _ _ Hab)); auto.
 intros e He; elim (H0 e He); intros e' He'.
 exists e'; auto.
Qed.


Set Implicit Arguments.
Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.Infrastructure.
Require Import GMuAnnot.Equations.
Require Import TLC.LibLN.
Require Import TLC.LibEnv.

(** * Regularity *)
(**
Defines basic properties of well formed types and typing judgement.
*)

(** * Properties of well-formedness of a type in an environment *)

(** If a type is well-formed in an environment then it is locally closed. *)

Lemma type_from_wft : forall Σ E T,
  wft Σ E T -> type T.
Proof.
  induction 1; eauto.
Qed.

#[export] Hint Resolve type_from_wft.

(* Lemma values_decidable : forall t, *)
(*     term t -> *)
(*     (value t \/ ~ (value t)). *)
(*   induction t; intro H; *)
(*   inversion H; subst; try solve [ *)
(*                      right; intro Hv; inversion Hv *)
(*                    | left; econstructor *)
(*                           ]. *)
(*   -  *)
(*   - match goal with *)
(*     | H: term t |- _ => rename H into Ht end. *)
(*     apply IHt in Ht. *)
(*     destruct Ht as [Hv | Hv]. *)
(*     + left; constructor*. *)
(*     + right. intro Hv'. inversion* Hv'. *)
(*   - match goal with *)
(*     | H: term t1 |- _ => rename H into Ht1 end. *)
(*     match goal with *)
(*     | H: term t2 |- _ => rename H into Ht2 end. *)
(*     apply IHt1 in Ht1. *)
(*     apply IHt2 in Ht2. *)
(*     destruct Ht1; *)
(*       destruct Ht2; *)
(*       try solve [ left; econstructor; eauto *)
(*                 | right; intro Hv; inversion Hv; congruence ]. *)
(*   - left; econstructor. *)
(*     econstructor; eauto. *)
(*   - left; econstructor. *)
(*     econstructor; eauto. *)
(* Qed. *)

Ltac IHap IH := eapply IH; eauto;
                try (unfold open_ee; rewrite <- open_ee_var_preserves_size);
                try (unfold open_te; rewrite <- open_te_var_preserves_size);
                cbn; lia.

(* Lemma wft_weaken : forall Σ Δ E F G T, *)
(*     wft Σ Δ (E & G) T -> *)
(*     ok (E & F & G) -> *)
(*     wft Σ Δ (E & F & G) T. *)
(*   introv Hwft Hok. gen_eq K: (E & G). gen E F G. *)
(*   induction Hwft; intros; subst; auto. *)
(*   - (* case: var *) *)
(*     apply (@wft_var Σ (E0 & F & G) X).  apply* binds_weaken. *)
(*   - (* case: all *) *)
(*     apply_fresh* wft_all as X. apply_ih_bind* H0. *)
(*   - econstructor; eauto. *)
(* Qed. *)

#[export] Hint Resolve subst_tt_type subst_te_term subst_ee_term.
#[export] Hint Resolve subst_te_value subst_ee_value.

Lemma okt_is_ok : forall Σ Δ E, okt Σ Δ E -> ok E.
  introv. intro Hokt.
  induction Hokt; eauto.
Qed.
#[export] Hint Extern 1 (ok _) => apply okt_is_ok.

Lemma wft_from_env_has_typ : forall Σ Δ x vk U E,
    okt Σ Δ E -> binds x (bind_var vk U) E -> wft Σ Δ U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
  - false (empty_push_inv H).
  - destruct (eq_push_inv H) as [? [? ?]]; subst. clear H.
    lets [[? HT] | [? HB]]: binds_push_inv B.
    + inversion* HT.
    + apply* IHE.
Qed.

Lemma wft_strengthen_typ : forall Σ D1 D2 U T,
    U \notin fv_typ T ->
    wft Σ (D1 |,| [tc_var U]* |,| D2) T -> wft Σ (D1 |,| D2) T.
Proof.
  introv Ufresh Hwft. gen_eq G: (D1 |,| [tc_var U]* |,| D2). gen D2.
  induction Hwft; intros D2 EQ; cbn in Ufresh; subst; auto.
  - apply* wft_var.
    repeat destruct_in_app;
      unfold is_var_defined; eauto using List.in_or_app.
    cbn in H. intuition. inversions H0. exfalso; eauto using in_singleton_self.
  - (* todo: binds_cases tactic *)
    match goal with
    | H: forall X, X \notin L -> ?P3 -> forall F0, ?P1 -> ?P2 |- _ =>
      rename H into H_ctxEq_implies_wft end.
    apply_fresh* wft_all as Y.
    lets* IH: H_ctxEq_implies_wft Y (D2 |, tc_var Y).
    + lets [Hfv | Hfv]: fv_open T2 (typ_fvar Y) 0;
        cbn in Hfv; unfold open_tt; rewrite Hfv; eauto.
  - econstructor; eauto.
Qed.

Lemma wft_strengthen_equation : forall Σ D1 D2 ϵ T,
    wft Σ (D1 |,| [tc_eq ϵ]* |,| D2) T ->
    wft Σ (D1 |,| D2) T.
  introv Hwft. gen_eq G: (D1 |,| [tc_eq ϵ]* |,| D2). gen D2.
  induction Hwft; intros D2 EQ; subst; auto.
  - apply* wft_var.
    unfold is_var_defined in *.
    lets [Hin | Hin]: List.in_app_or H.
    + apply List.in_or_app; left~.
    + lets [? | ?]: List.in_app_or Hin.
      * inversion H0; false*.
      * apply List.in_or_app; right~.
  - apply_fresh wft_all as X.
    lets IH: H0 X (D2 |, tc_var X); auto.
  - econstructor; eauto.
Qed.

Lemma wft_strengthen_equations : forall Σ D1 Deqs D2 T,
    wft Σ (D1 |,| Deqs |,| D2) T ->
    (forall eq, List.In eq Deqs -> exists ϵ, eq = tc_eq ϵ) ->
    wft Σ (D1 |,| D2) T.
  induction Deqs; introv Hwft Heqs.
  - clean_empty_Δ. auto.
  - destruct a.
    + lets [? ?]: Heqs (tc_var A); auto with listin.
      false~.
    + fold_delta.
      apply IHDeqs.
      * apply* wft_strengthen_equation.
        repeat rewrite List.app_assoc in *; eauto.
      * intros eq1 Hin.
        lets Hl: Heqs eq1.
        apply Hl.
        cbn. right~.
Qed.

Lemma wft_strengthen_typ_many : forall Σ As Δ T,
    wft Σ (Δ |,| tc_vars As) T ->
    (forall A, List.In A As -> A \notin fv_typ T) ->
    wft Σ Δ T.
  induction As as [| Ah Ats]; introv Hwft Asfresh.
  - cbn in *. clean_empty_Δ.
    trivial.
  - cbn in *. fold_delta. fold_delta.
    apply* IHAts.
    lets W: wft_strengthen_typ Σ (Δ |,| tc_vars Ats) emptyΔ.
    clean_empty_Δ.
    apply~ W.
Qed.
(* Lemma wft_strengthen : forall Σ Δ E F x U T, *)
(*  wft Σ Δ (E & (x ~: U) & F) T -> wft Σ (E & F) T. *)
(* Proof. *)
(*   introv Hwft. gen_eq G: (E & (x ~: U) & F). gen F. *)
(*   induction Hwft; intros F EQ; subst; auto. *)
(*   - *)
(*     match goal with *)
(*     | H: binds _ _ _ |- _ => *)
(*       rename H into Hbinds_bindtyp end. *)
(*     apply* (@wft_var). *)
(*     destruct (binds_concat_inv Hbinds_bindtyp) as [?|[? Hbinds2]]. *)
(*     + apply~ binds_concat_right. *)
(*     + destruct (binds_push_inv Hbinds2) as [[? ?]|[? ?]]. *)
(*       * subst. false. *)
(*       * apply~ binds_concat_left. *)
(*   - (* todo: binds_cases tactic *) *)
(*     match goal with *)
(*     | H: forall X, X \notin L -> forall F0, ?P1 -> ?P2 |- _ => *)
(*       rename H into H_ctxEq_implies_wft end. *)
(*     apply_fresh* wft_all as Y. apply_ih_bind* H_ctxEq_implies_wft. *)
(*   - econstructor; eauto. *)
(* Qed. *)

Lemma okt_implies_okgadt : forall Σ Δ E, okt Σ Δ E -> okGadt Σ.
  induction 1; auto.
Qed.

Ltac find_ctxeq :=
  match goal with
  | H: _ & _ ~ _ = _ & _ ~ _ |- _ =>
    rename H into Hctx_eq
  end.

Lemma okt_push_var_inv : forall Σ Δ E x vk T,
  okt Σ Δ (E & x ~ bind_var vk T) -> okt Σ Δ E /\ wft Σ Δ T /\ x # E.
Proof.
  introv O; inverts O.
  - false* empty_push_inv.
  - find_ctxeq. lets (?&M&?): (eq_push_inv Hctx_eq). subst. inverts~ M.
Qed.

Lemma okt_is_wft : forall Σ Δ E x vk T,
    okt Σ Δ (E & x ~ bind_var vk T) -> wft Σ Δ T.
  introv Hokt.
  inversion Hokt.
  - false* empty_push_inv.
  (* - lets (?&?&?): eq_push_inv H. false*. *)
  - lets (?&?&?): eq_push_inv H. subst.
    match goal with Heq: bind_var ?k1 ?T1 = bind_var ?k2 ?T2 |- _ => inversions* Heq end.
Qed.

Lemma okt_strengthen : forall Σ Δ E x vk U F,
    okt Σ Δ (E & (x ~ bind_var vk U) & F) -> okt Σ Δ (E & F).
  introv O. induction F using env_ind.
  - rewrite concat_empty_r in *. lets*: (okt_push_var_inv O).
  - rewrite concat_assoc in *.
    (* lets Hinv: okt_push_inv O; inversions Hinv. *)
    (* + lets (?&?): (okt_push_typ_inv O). *)
    (*   applys~ okt_sub. *)
    (* + match goal with *)
    (*   | H: exists T, v = bind_var T |- _ => *)
    (*     rename H into Hexists_bindvar end. *)
      (* inversions Hexists_bindvar. *)
    (* lets (?&?&?): (okt_push_var_inv O). *)
    destruct v.
    inversions O.
    + false* empty_push_inv.
    + apply eq_push_inv in H.
      destruct H as [? [? ?]]. subst.
      match goal with
      | [ H: bind_var ?vk1 ?T = bind_var ?vk2 ?t |- _ ] => inversions H
      end.
      applys~ okt_typ.
Qed.

Lemma okt_strengthen_delta_var : forall Σ D1 D2 E X,
    X # E ->
    X \notin fv_env E ->
    okt Σ (D1 |,| [tc_var X]* |,| D2) E -> okt Σ (D1 |,| D2) E.
  introv FXE FXTE O. induction E using env_ind.
  - constructor.
    lets*: okt_implies_okgadt.
  - destruct v as [T].
    inversions O.
    + lets*: empty_push_inv H.
    + lets [? [? ?]]: eq_push_inv H.
      match goal with
      | H: bind_var ?vk1 ?A = bind_var ?vk2 ?B |- _ => inversions H
      end.
      lets [? ?]: notin_env_inv FXTE.
      constructor; auto.
      * apply wft_strengthen_typ with X; auto.
      * apply notin_domΔ_eq.
        apply notin_domΔ_eq in H5.
        destruct H5.
        apply notin_domΔ_eq in H5.
        intuition.
Qed.

Lemma okt_is_type : forall Σ Δ E x vk T,
    okt Σ Δ (E & x ~ bind_var vk T) -> type T.
  introv Hokt. apply okt_is_wft in Hokt. apply* type_from_wft.
Qed.

Lemma wft_type : forall Σ Δ T,
    wft Σ Δ T -> type T.
Proof.
  induction 1; eauto.
Qed.

Lemma wft_weaken : forall Σ D1 D2 D3 T,
    wft Σ (D1 |,| D3) T ->
    wft Σ (D1 |,| D2 |,| D3) T.
  introv WT. gen_eq K: (D1 |,| D3). gen D3.
  induction WT; auto; introv EQ.
  - constructor. unfold is_var_defined in *.
    subst.
    lets [? | ?]: List.in_app_or H;
      auto using List.in_or_app.
  - apply_fresh* wft_all as Y.
    assert (Yfr: Y \notin L); eauto.
    lets: H0 Yfr (D3 |, tc_var Y).
    assert (Hassoc: ((D1 |,| D2) |,| (D3 |, tc_var Y)) = (((D1 |,| D2) |,| D3) |,| [tc_var Y]*));
      auto using List.app_assoc.
    rewrite <- Hassoc.
    apply H1. subst. auto using List.app_assoc.
  - apply* wft_gadt.
Qed.

Ltac destruct_app_list :=
  match goal with
  | [ H: List.In ?X (?L ++ ?K) |- _ ] =>
    apply List.in_app_or in H; destruct H
  end.

Lemma wft_subst_tb : forall Σ D1 D2 Z P T,
  wft Σ (D1 |,| [tc_var Z]* |,| D2) T ->
  wft Σ D1 P ->
  wft Σ (D1 |,| D2) (subst_tt Z P T).
Proof.
  introv WT WP; gen_eq G: (D1 |,| [tc_var Z]* |,| D2). gen D2.
  induction WT; intros; subst; simpl subst_tt; auto.
  - case_var*.
    + lets Hw: wft_weaken D1 D2 emptyΔ.
      repeat rewrite List.app_nil_r in *.
      apply* Hw.
    + constructor. unfold is_var_defined in *.
      repeat destruct_app_list; auto using List.in_or_app.
      cbn in H. destruct H.
      * congruence.
      * contradiction.
  - apply_fresh* wft_all as Y.
    lets: wft_type.
    rewrite* subst_tt_open_tt_var.
    lets* IH: H0 Y (D2 |, tc_var Y).
  - apply* wft_gadt.
    + introv Tin.
      apply List.in_map_iff in Tin.
      destruct Tin as [U [? Tin]]; subst.
      apply* H0.
    + apply List.map_length.
Qed.

Lemma wft_open : forall Σ Δ U T1,
  wft Σ Δ (typ_all T1) ->
  wft Σ Δ U ->
  wft Σ Δ (open_tt T1 U).
Proof.
  introv WA WU. inversions WA. pick_fresh X.
  rewrite* (@subst_tt_intro X).
  lets K: (@wft_subst_tb Σ Δ emptyΔ X).
  clean_empty_Δ.
  apply* K.
Qed.

(** ** GADT environment properties *)

#[export] Hint Resolve okt_is_ok.

Lemma gadt_constructor_ok : forall Σ Name Tarity Ctors Ctor Carity CargType CretTypes,
    binds Name (mkGADT Tarity Ctors) Σ ->
    List.nth_error Ctors Ctor = Some (mkGADTconstructor Carity CargType CretTypes) ->
    okGadt Σ ->
    okConstructorDef Σ Tarity (mkGADTconstructor Carity CargType CretTypes).
  introv Hbind Hlist HokG.
  inversion HokG as [Hok HokG'].
  apply* HokG'.
  apply* List.nth_error_In.
Qed.

Lemma wft_subst_tb_many : forall Σ (As : list var) (Us : list typ) Δ (T : typ),
    length As = length Us ->
      wft Σ (Δ |,| tc_vars As) T ->
      (forall U, List.In U Us -> wft Σ Δ U) ->
      (* (forall A, List.In A As -> A \notin dom E) -> *)
      DistinctList As ->
      wft Σ Δ (subst_tt_many As Us T).
  induction As as [|Ah Ats];
    introv Hlen HwftT WwftUs HD;
    destruct Us as [|Uh Uts]; inversion Hlen.
  - cbn in *.
    clean_empty_Δ.
    auto.
  - cbn in *. inversions HD.
    apply IHAts; eauto with listin.
    fold (tc_vars Ats) in HwftT.
    fold ((Δ |,| tc_vars Ats) |,| [tc_var Ah]*) in HwftT.
    lets W: wft_subst_tb Σ (Δ |,| tc_vars Ats) emptyΔ.
    clean_empty_Δ.
    apply~ W.
    rewrite <- (List.app_nil_l (Δ |,| tc_vars Ats)).
    apply~ wft_weaken.
Qed.

Lemma wft_open_many : forall Δ Σ Alphas Ts U,
    length Alphas = length Ts ->
    DistinctList Alphas ->
    (* (forall A : var, List.In A Alphas -> A \notin dom E) -> *)
    (forall A : var, List.In A Alphas -> A \notin fv_typ U) ->
    (forall (A : var) (T : typ), List.In A Alphas -> List.In T Ts -> A \notin fv_typ T) ->
    (forall T : typ, List.In T Ts -> wft Σ Δ T) ->
    wft Σ (Δ |,| tc_vars Alphas) (open_tt_many_var Alphas U) ->
    wft Σ Δ (open_tt_many Ts U).
  introv Hlen Hdistinct FU FT WT WU.
  rewrite* (@subst_tt_intro_many Alphas).
  - lets Htb: (@wft_subst_tb_many Σ Alphas Ts).
    specializes_vars Htb.
    apply* Htb.
Qed.

Hint Rewrite in_union : fsets.

Lemma notin_fv_wf : forall Σ Δ X T,
    wft Σ Δ T -> (~ is_var_defined Δ X) -> X \notin fv_typ T.
Proof.
  induction 1 as [ | ? ? ? Hbinds | | | |];
    introv Fr; simpl; eauto.
  - rewrite notin_singleton. intro. subst. contradiction.
  - notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_tt_open Y).
    apply* H0.
    cbn.
    intro HF.
    destruct HF as [HF | HF].
    + inversions HF.
      assert (X \notin \{ X}); eauto using in_singleton_self.
    + contradiction.
  - intro Hin.
    lets* Hex: in_fold_exists Hin.
    destruct Hex as [Hex | Hex].
    + destruct Hex as [T [Tin fvT]].
      lets* Hf: H0 T Tin.
    + apply* in_empty_inv.
Qed.

Lemma typing_regular : forall Σ Δ E e T TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T ->
    okt Σ Δ E /\ term e /\ wft Σ Δ T.
Proof.
  intro Hbounds.
  introv Typ.
  lets Typ2: Typ.
  induction Typ as [ |
                   |
                   | ? ? ? ? ? ? ? ? ? IH
                   |
                   | ? ? ? ? ? ? ? ? ? IH
                   | | | |
                   | ? ? ? ? ? ? ? IHval ? IH
                   | ? ? ? ? ? ? ? ? ? ? ? ? IH
                   |
                   |
                   ];
    try solve [splits*].
  - splits*. apply* wft_from_env_has_typ.
  - subst. destruct IHTyp as [Hokt [Hterm Hwft]]; auto.
    splits*.
    lets* HG: okt_implies_okgadt Hokt.
    lets* GADTC: gadt_constructor_ok HG.
    inversions GADTC.
    rewrite rewrite_open_tt_many_gadt.
    econstructor; eauto.
    + introv TiL.
      lets* TiL2: TiL. apply List.in_map_iff in TiL2.
      inversion TiL2 as [CretT [Heq CiC]]. subst.
      let usedvars := gather_vars in
      lets* EAlphas: exist_alphas (usedvars) (length Ts).
      inversion EAlphas as [Alphas [A1 [A2 A3]]].
      lets* HH: H9 Alphas CiC.
      apply (@wft_open_many Δ Σ Alphas Ts); auto.
      * introv Ain; lets~ FA: A3 Ain.
      * introv Ain Tin; lets~ FA: A3 Ain.
        eauto using fv_typs_notin.
      * eauto.
    + rewrite List.map_length. trivial.
  - pick_fresh y.
    copyTo IH IH1.
    assert (yL: y \notin L); eauto.
    lets~ [? [? ?]]: IH yL.
    splits*.
    + apply_folding E okt_strengthen.
    + econstructor.
      * apply* okt_is_type.
      * intros.  apply* IH1.
    + econstructor; eauto.
      apply* okt_is_wft.
  - splits*.
    destruct~ IHTyp2 as [? [? Hwft]]. inversion* Hwft.
  - copyTo IH IH1.
    pick_fresh_gen (L \u fv_env E \u dom E) y.
    add_notin y L. lets~ HF: IH Fr0. destructs~ HF.
    splits*.
    * rewrite <- (List.app_nil_l Δ).
      apply okt_strengthen_delta_var with y; eauto.
    * apply* term_tabs. intros. apply* IH1.
    * apply_fresh* wft_all as Y.
      add_notin Y L. lets~ HF: IH1 Y Fr1. destruct* HF.
  - subst. splits*. destruct~ IHTyp as [? [? Hwft]].
    copyTo Hwft Hwft2.
    inversions Hwft.
    match goal with
    | IH: forall X : var, X \notin L -> ?conclusion |- _ =>
      pick_fresh Y; add_notin Y L; lets HW: IH Y Fr0
    end.
    apply* wft_open.
  - splits*.
    destruct~ IHTyp as [? [? Hwft]]. inversion* Hwft.
  - splits*.
    destruct~ IHTyp as [? [? Hwft]]. inversion* Hwft.
  - pick_fresh y.
    copyTo IH IH1.
    specializes IH1 y. destructs~ IH1.
    splits*.
    + apply_folding E okt_strengthen.
    + econstructor. apply* okt_is_type.
      intros. apply* IH.
      intros. apply* IHval.
  - destructs~ IHTyp.
    pick_fresh y.
    assert (yFr: y \notin L); eauto.
    lets IH1: H yFr.
    destructs~ IH1.
    splits*.
    econstructor; auto.
    introv HxiL. lets HF: H x HxiL. destructs~ HF.
  - destruct~ IHTyp as [Hokt [Hterme HwftT]].
    splits*.
    + econstructor; eauto.
      2: {
        lets* OKG: okt_implies_okgadt Hokt.
        inversions OKG.
        lets*: H6 H0.
        destruct Defs as [|Def0].
        1: {
          destruct H. false*.
        }

        destruct ms as [|cl0].
        1: {
          false*.
        }

        lets [Alphas [? [?]]]: exist_alphas L (Carity Def0).
        pick_fresh x.
        lets~ : H4 Def0 cl0 Alphas x.
        - cbn. auto.
        - destruct H10; eauto.
          + apply* H3. cbn. auto.
          + destruct H11.
          apply* type_from_wft.
      }
      intros cl clin Alphas x Hlen Hdist Afresh xfresh xAlphas.
      destruct cl as [clA clT].
      cbn.
      apply F2_from_zip in H4; eauto.
      lets* [Def [DefIn [DefIn2 HDef]]]: forall2_from_snd clin.
      cbn in HDef.
      cbn in Hlen.
      lets Hlen2: H2 DefIn2.
      cbn in Hlen2.
      assert (Hlen3: length Alphas = Carity Def); try lia.
      lets~ HF: HDef Alphas x Hlen3 Hdist Afresh.
      lets~ [? [? ?]]: HF xfresh xAlphas.
      lets~ HT: H3 Def (clause clA clT) Alphas x.
    + assert (ms <> []*).
      * lets gadtOk: okt_implies_okgadt Hokt.
        inversion gadtOk as [? okDefs].
        lets [defNEmpty okDef]: okDefs H0.
        intro.
        destruct Defs; subst; eauto. cbn in H1. lia.
      * destruct ms as [ | cl1 rest]; [ contradiction | idtac ].
        apply F2_from_zip in H3; eauto.
        lets* [Def [DefIn [DefIn2 HDef]]]: forall2_from_snd cl1 H3;
          eauto with listin.

        (* May want a tactic 'pick_fresh Alphas' *)
        lets* [Alphas [A1 [A2 A3]]]: exist_alphas (Carity Def).
        instantiate (1:=L \u fv_typ Tc) in A3.
        pick_fresh x.

        assert (Afresh: (forall A : var, List.In A Alphas -> A \notin L));
          [ introv Ain; lets*: A3 Ain | idtac ].
        assert (xfresh: x \notin L); eauto.

        assert (xfreshA: x \notin from_list Alphas); eauto.

        lets* HTyp: HDef A1 A2 Afresh xfresh xfreshA.
        lets~ [? [? Hwft2]]: H4 HTyp.
        apply wft_strengthen_typ_many with Alphas; auto.
        -- rewrite <- (List.app_nil_l (Δ |,| tc_vars Alphas)).
           eapply wft_strengthen_equations.
           ++ clean_empty_Δ.
              apply Hwft2.
           ++ introv Hin.
              unfold equations_from_lists in Hin.
              rewrite zipWithIsMappedZip in Hin.
              apply List.in_map_iff in Hin.
              destruct Hin as [[U V] [Heq Hin]]. subst.
              eauto.
        -- introv Ain. lets*: A3 Ain.
Qed.

(** The reduction relation is restricted to well-formed objects. *)

(* does not seem to be helpful for proving safety, just a useful result on its own, but let's ignore it while there are more pressing theorems to prove *)
(* Lemma red_regular : forall t t', *)
(*   red t t' -> term t /\ term t'. *)
(* Proof. *)
(*   induction 1; split; autos* value_regular. *)
(*   - inversions H. pick_fresh y. rewrite* (@subst_ee_intro y). *)
(*   - inversions H. pick_fresh Y. rewrite* (@subst_te_intro Y). *)
(*   - inversions H. pick_fresh y. rewrite* (@subst_ee_intro y). *)
(*   - inversions H. auto. *)
(*   - inversions H. auto. *)
(*   - inversions IHred. econstructor. *)
(* Qed. *)

Lemma typing_implies_term : forall Σ Δ E e T TT,
    {Σ, Δ, E} ⊢(TT) e ∈ T ->
    term e.
  introv Typ.
  lets* TR: typing_regular Typ.
Qed.

Lemma Tgen_from_any : forall Σ Δ E TT e T,
    {Σ, Δ, E} ⊢(TT) e ∈ T ->
    {Σ, Δ, E} ⊢(Tgen) e ∈ T.
  introv Typ.
  applys~ typing_eq T TT.
  - apply teq_reflexivity.
  - lets* : typing_regular Typ.
Qed.


Require Import list_examples.

Definition tail_body := Cdr (Deref (Var 0)).

Inductive tail_spec : Spec cfg :=
  tail_claim : forall H r y x l env, exp_val tail_spec
  tail_body (Addr r::env)
    (asP H (rep_list l y :* list_seg (x::nil) y (Addr r)))
    (fun v => constraint (v = y) :* litP H).

Lemma tail_proof : sound lam_step tail_spec.
Proof. list_solver. Qed.


From RelationAlgebra Require Import
     monoid
     kat
     kat_tac
     prop
     rel
     srel
     comparisons
     rewriting
     normalisation.

From CTree Require Import
	   CTree
     Eq
     Eq.Trace
 	   Interp.Interp.

Import CTree.
Import CTreeNotations.
Open Scope ctree.

Variant E : Type -> Type :=
  | Coin      : E unit
  | ReqTea    : E unit
  | ReqCoffee : E unit
  | Tea       : E unit
  | Coffee    : E unit
.

Notation state := (ctree E void).

Definition vending : state :=
  cofix F :=
    trigger Coin;;
    brD2
      (trigger ReqTea;;
       vis Tea (fun _ => F))
      (trigger ReqCoffee;;
       vis Coffee (fun _ => F))
.

Definition reapoff : state :=
  cofix F :=
    brD2
    (trigger Coin;;
     trigger ReqTea;;
     vis Tea (fun _ => F))
    (trigger Coin;;
     trigger ReqCoffee;;
     vis Coffee (fun _ => F))
.

Theorem distinguishable : ~ (vending ≲ reapoff).
Proof.
  intros H.
  setoid_rewrite ctree_eta in H. play in H.
  setoid_rewrite bind_ret_l in EQ.
  apply trans_brD_inv in TR as (? & TR). destruct x0. inv_trans.
  - play in EQ. inv_trans. discriminate.
  - eapply ssim_brD_l_inv with (x := Fin.F1) in EQ.
    play in EQ. inv_trans. discriminate.
  Unshelve. all: auto.
Qed.

Theorem coffee_ssim : reapoff ≲ vending.
Proof.
  coinduction R CH.
  setoid_rewrite ctree_eta. cbn. setoid_rewrite bind_ret_l.
  apply step_ss_brD_l. intros.
  destruct x.
  - rewrite bind_trigger. apply step_ss_vis; auto. intros _.
    step. apply step_ss_brD_r with (x := Fin.F1).
    upto_bind_eq. now apply step_ss_vis.
  - rewrite bind_trigger. apply step_ss_vis; auto. intros _.
    step. apply step_ss_brD_r with (x := Fin.FS Fin.F1).
    upto_bind_eq. now apply step_ss_vis.
Qed.

Tactic Notation "play" "using" tactic(tac) :=
  __trace_play using tac.

Tactic Notation "play" := __trace_play.

Tactic Notation "play" "in" hyp(H) :=
  __trace_play in H.

Theorem coffee_traceq : traceq vending reapoff.
Proof.
  split; red; intros.
  - red. revert s H. coinduction R CH. intros.
    do 3 red. cbn.
    destruct s; auto. play in H.
    destruct s.
    2: play; now step.
    setoid_rewrite bind_ret_l in H.
    play in H. apply trans_brD_inv in TR as [].
    destruct x2; inv_trans; subst.
    + play using (apply trans_brD21; etrans).
      step. play.
      step. destruct s; auto. play in H. play.
    + play using (apply trans_brD22; etrans).
      step. play.
      step. destruct s; auto.
      play in H. play.
  - pose proof (ssim_tracincl _ _ coffee_ssim); auto.
Qed.


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

(***
Modulus : 2^191 - 19
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 32;
    bitwidth := 32;
    s := 2^191;
    c := [(1, 19)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    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 Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Import Blech.Category.Bsh.
Require Import Blech.Category.Funct.
Require Import Blech.Category.Prod.
Require Import Blech.Category.PSh.
Require Import Blech.Category.CoPSh.
Require Import Blech.Category.Op.
Require Import Blech.Functor.Yo.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.
Import ProdNotations.
Import OpNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition CoSpec [C: Category] (A: PSh C): CoPSh C := {|
  op (u: C) := (∀ x, Bsh (A x) (Yo C u x)) /~ {| equiv f g := ∀ t, f t == g t |} ;
  map _ _ x y _ z := x ∘ y _ z ;
|}.

Next Obligation.
Proof.
  admit.
Admitted.

Next Obligation.
Proof.
  intros ? ? p.
  apply compose_compat.
  1: reflexivity.
  apply (proj2_sig (y o1)).
  auto.
Qed.

Next Obligation.
Proof.
  intros ? ? ? ? ?.
  cbn in *.
  apply compose_compat.
  1: reflexivity.
  apply H.
Qed.

Next Obligation.
Proof.
  exists.
  all: cbn.
  all: try (intros; Reflect.category;reflexivity).
  - intros.
    intros ? ? p ? ? ?.
    cbn in *.
    apply compose_compat.
    2: reflexivity.
    apply p.
Qed.


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 conj18eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj18eqsynthconj4.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y PX P T : Universe, ((wd_ A B /\ (wd_ PX A /\ (wd_ P A /\ (wd_ P B /\ (wd_ Y A /\ (wd_ Y B /\ (wd_ X A /\ (wd_ X B /\ (wd_ P PX /\ (wd_ X PX /\ (col_ A B PX /\ (col_ PX A T /\ (col_ P X PX /\ (col_ Y PX A /\ col_ Y T P)))))))))))))) -> col_ Y A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal33.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (IHx:@eq natural (fac x) (qfac x (Succ Zero))):@eq natural (mult (fac x) x) (qfac x x).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal33_fac_eq_qfac_124_qfac_mult/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

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


Require Import List.
Require Import Arith.

Require Import CCP.
Require Import FB.
Require Import Common.

(** * Compiling FB to CCP *)

Definition compile (e : FB.expr) : CCP.expr := e.

Hint Constructors CCP.Sem : fb_ccp.

Lemma look_up_equiv :
forall Gamma sigma pe clo pclo v addr
  (PCLO   : Gamma pclo = Some (pe, clo))
  (LOOKUP : look_up sigma clo v = addr),
  CCP.look_up sigma Gamma pclo v = addr.
Proof with isa.
intros.
destruct v as [n | n]...
rewrite PCLO...
Qed.

Lemma map_env_equiv :
forall Gamma sigma pe clo pclo vs addrs
  (PCLO   : Gamma pclo = Some (pe, clo))
  (MAPENV : map_env sigma clo vs = addrs),
  CCP.map_env sigma Gamma pclo vs = addrs.
Proof with isa.
intros.
rewrite <- MAPENV.
clear MAPENV.
induction vs...
rewrite IHvs.
destruct (map_env sigma clo vs)...
cutrewrite (CCP.look_up sigma Gamma pclo a = look_up sigma clo a)...
  destruct a...
  rewrite PCLO...
Qed.

Lemma look_up_nil :
forall Gamma sigma pclo v addr
  (MAPENV : look_up sigma nil v = Some addr),
  CCP.look_up sigma Gamma pclo v = Some addr.
Proof with isa; eauto.
intros.
destruct v...
destruct n; discriminate.
Qed.

Lemma map_env_nil :
forall sigma vs addrs
  (MAPENV : map_env sigma nil vs = Some addrs)
  Gamma pclo,
  CCP.map_env sigma Gamma pclo vs = Some addrs.
Proof with isa; try discriminate.
induction vs...
destruct addrs...
destruct (map_env sigma nil vs)...
destruct (look_up sigma nil a)...
rewrite IHvs with (addrs := addrs)...
destruct (map_env sigma nil vs)...
destruct a...
destruct (nth n sigma)...
inversion MAPENV; subst...
destruct n...
destruct (map_env sigma nil vs)...
destruct (look_up sigma nil a)...
congruence.
Qed.

Lemma make_closure_equiv :
forall sigma (clo : addresses) Gamma pclo clo lf pe clo0
  (PCLO : Gamma pclo = Some (pe, clo))
  (MAKE : make_closure (Expr := CCP.expr) sigma clo lf = Some clo0),
  CCP.make_closure sigma Gamma pclo lf = Some clo0.
Proof with isa; eauto.
intros.
unfold make_closure in MAKE.
unfold CCP.make_closure.
destruct lf...
remember (map_env sigma clo0 v) as X.
destruct X; try discriminate.
symmetry in HeqX.
apply map_env_equiv with (Gamma := Gamma) (pe := pe) (pclo := pclo)
  in HeqX...
rewrite HeqX...
Qed.

Lemma make_closure_equiv2 :
forall sigma (clo : addresses) Gamma pclo clo lf pe
  (PCLO : Gamma pclo = Some (pe, clo)),
  make_closure (Expr := CCP.expr) sigma clo lf =
  CCP.make_closure sigma Gamma pclo lf.
Proof with isa.
intros.
destruct lf...
cutrewrite (map_env sigma clo0 v = CCP.map_env sigma Gamma pclo v)...
induction v...
rewrite IHv...
destruct (CCP.map_env sigma Gamma pclo v)...
cutrewrite (look_up sigma clo0 a = CCP.look_up sigma Gamma pclo a)...
destruct a...
rewrite PCLO...
Qed.

Lemma make_closures_equiv :
forall sigma (clo : addresses) Gamma pclo clo lfs pe clos
  (PCLO : Gamma pclo = Some (pe, clo))
  (MAKE : make_closures (Expr := CCP.expr) sigma clo lfs = Some clos),
  CCP.make_closures sigma Gamma pclo lfs = Some clos.
Proof with isa.
intros.
rewrite <- MAKE.
clear MAKE.
induction lfs...
rewrite IHlfs...
destruct (make_closures sigma clo0 lfs)...
erewrite <- make_closure_equiv2; eauto.
Qed.

Lemma make_closure_nil :
forall sigma clo Gamma p lf
  (MAKE : make_closure (Expr := CCP.expr) sigma nil lf = Some clo),
  CCP.make_closure sigma Gamma p lf = Some clo.
Proof with isa; eauto.
intros.
destruct lf.
unfold make_closure in MAKE.
unfold CCP.make_closure.
remember (map_env sigma nil v) as X.
symmetry in HeqX.
destruct X; try discriminate.
apply map_env_nil with (Gamma := Gamma) (pclo := p) in HeqX.
rewrite HeqX...
Qed.

Lemma make_closures_nil :
forall lfs sigma clos Gamma p
  (MAKE : make_closures (Expr := CCP.expr) sigma nil lfs = Some clos),
  CCP.make_closures sigma Gamma p lfs = Some clos.
Proof with isa; try discriminate.
induction lfs...
remember (make_closures sigma nil lfs) as mcs; symmetry in Heqmcs;
  destruct mcs...
rewrite IHlfs with (clos := g)...
remember (make_closure sigma nil a) as mc; destruct mc...
symmetry in Heqmc; eapply make_closure_nil in Heqmc.
rewrite Heqmc...
Qed.

Hint Resolve look_up_equiv map_env_equiv map_env_nil look_up_nil
             make_closure_equiv make_closures_equiv
             make_closure_nil make_closures_nil
           : fb_ccp.

Definition heap_from_config (c : FB.config) : CU.heap :=
match c with
| FB.Config g _ _ _ _ => g
| FB.Enter g _ _ _ => g
end.

Definition BH_remains (Gamma Delta : FB.heap): Prop :=
forall p pclo
  (BH   : Gamma p = Some (Black_hole, pclo)),
  Delta p = Some (Black_hole, pclo).

Lemma doesnt_touch_BH :
forall Config Value
  (EVAL : FB.Sem Config Value),
  match Value with (V, _, _) =>
    match (Config, V) with
    | (FB.Config g _ _ _ _, CU.Val_con d _ _) => BH_remains g d
    | (FB.Config g _ _ _ _, CU.Val_pap d _ _) => BH_remains g d
    | (FB.Enter g _ _ _, CU.Val_con d _ _) => BH_remains g d
    | (FB.Enter g _ _ _, CU.Val_pap d _ _) => BH_remains g d
    end
  end.
Proof with unfold BH_remains in *; isa; eauto with fb_ccp.
intros.
induction EVAL...
(* App3 *)
destruct (eq_nat_dec p p0); subst.
rewrite BH in ONHEAP; discriminate.
unfold set.
destruct (eq_nat_dec p0 p) as [ EQ | ]...
rewrite EQ in n; tauto.
apply IHEVAL.
unfold clog.
destruct (eq_nat_dec p0 p)...
rewrite BH...
(* App4 *)
destruct Value...
destruct p0...
destruct v as [Delta0 | Delta0]; isa;
  (apply IHEVAL2; unfold set; destruct (eq_nat_dec p0 p); subst;
  [rewrite BH in ONHEAP1; discriminate | ]; apply IHEVAL1; unfold clog;
  destruct (eq_nat_dec p0 p); try rewrite BH)...
(* Let *)
destruct Value...
destruct p...
destruct v as [Delta0 | Delta0]...
apply IHEVAL...
destruct (In_dec eq_nat_dec p addrs)...
apply FRESH in i; rewrite i in BH; discriminate.
rewrite <- BH; apply alloc_nin...
apply IHEVAL...
destruct (In_dec eq_nat_dec p addrs)...
apply FRESH in i; rewrite i in BH; discriminate.
rewrite <- BH; apply alloc_nin...
(* Case_of *)
destruct Value...
destruct p...
destruct v as [Delta0 | Delta0]...
Qed.

Definition lfn_remains (Gamma Delta : FB.heap): Prop :=
forall p pclo clovars bind e
  (LFN  : Gamma p = Some (Lf_n clovars bind e, pclo)),
  Delta p = Some (Lf_n clovars bind e, pclo).

Lemma doesnt_touch_lfn :
forall Config Value
  (EVAL : FB.Sem Config Value),
  match Value with (V, _, _) =>
    match (Config, V) with
    | (FB.Config g _ _ _ _, CU.Val_con d _ _) => lfn_remains g d
    | (FB.Config g _ _ _ _, CU.Val_pap d _ _) => lfn_remains g d
    | (FB.Enter g _ _ _, CU.Val_con d _ _) => lfn_remains g d
    | (FB.Enter g _ _ _, CU.Val_pap d _ _) => lfn_remains g d
    end
  end.
Proof with unfold lfn_remains in *; isa; eauto with fb_ccp.
intros.
induction EVAL...
(* App3 *)
destruct (eq_nat_dec p p0); subst.
rewrite LFN in ONHEAP; discriminate.
unfold set.
destruct (eq_nat_dec p0 p) as [ EQ | ]...
rewrite EQ in n; tauto.
apply IHEVAL.
unfold clog.
destruct (eq_nat_dec p0 p) as [ EQ | ]...
rewrite EQ in n0; tauto.
(* App4 *)
destruct Value...
destruct p0...
destruct v as [Delta0 | Delta0]; isa;
  (apply IHEVAL2;
  unfold set;
  destruct (eq_nat_dec p0 p); subst;
  [ rewrite LFN in ONHEAP1; discriminate
  | apply IHEVAL1; unfold clog; destruct (eq_nat_dec p0 p) as [ EQ | ];
    [ rewrite EQ in n; tauto | trivial ]]).
(* Let *)
destruct Value...
destruct p...
destruct v as [Delta0 | Delta0]...
apply IHEVAL...
destruct (In_dec eq_nat_dec p addrs)...
apply FRESH in i; rewrite i in LFN; discriminate.
rewrite <- LFN; apply alloc_nin...
apply IHEVAL...
destruct (In_dec eq_nat_dec p addrs)...
apply FRESH in i; rewrite i in LFN; discriminate.
rewrite <- LFN; apply alloc_nin...
(* Case_of *)
destruct Value...
destruct p...
destruct v as [Delta0 | Delta0]...
Qed.

Ltac exists3 a b c := exists a; exists b; exists c.
Ltac destruct3 H a b c := destruct H as [a [b [c H]]].

Lemma invariant :
forall Config Value
  (EVAL : FB.Sem Config Value),
  match Config with
  | FB.Config Gamma e sigma args clo =>
    match clo with
    | nil => forall p, CCP.Sem (CCP.Config Gamma e sigma args p) Value
    | (_::_) => forall p
      (PCLO : Gamma p = Some (Black_hole, clo)
           \/ exists clovars, exists bind, exists pe,
              Gamma p = Some (Lf_n clovars bind pe, clo)),
      CCP.Sem (CCP.Config Gamma e sigma args p) Value
    end
  | FB.Enter Gamma p args sigma =>
      CCP.Sem (CCP.Enter Gamma p args sigma) Value
  end.
Proof with isa; eauto with fb_ccp.
intros.
induction EVAL; isa; try destruct clo as [ | c cs]; isa; eauto with fb_ccp.
(* Cons *)
apply CCP.Cons; destruct PCLO...
destruct3 H clovars bind0 pe...
(* Accum *)
apply CCP.Accum with (p := p) (new_args := new_args);
  destruct PCLO...
destruct3 H clovars bind0 pe...
destruct3 H clovars bind0 pe...
(* App2 *)
eauto with fb_ccp.
apply CCP.App2 with (e := e) (bind := bind) (clo := c :: cs)
  (clovars := clovars)...
apply IHEVAL; right; exists3 clovars bind e...
(* App3 *)
apply CCP.App3 with (clovars := clovars) (e := e) (clo := c :: cs)...
apply IHEVAL with (p0 := p).
left; unfold clog.
destruct (eq_nat_dec p p); intuition...
rewrite ONHEAP...
(* App4 *)
destruct clo_e...
eapply CCP.App4...
eapply IHEVAL1...
left; unfold clog.
destruct (eq_nat_dec p p); intuition...
rewrite ONHEAP1...
(* Let *)
destruct current_clo as [ | d ds]...
apply CCP.Let with (closures := closures) (addrs := addrs);
  destruct PCLO...
destruct3 H clovars bind0 pe...
apply IHEVAL; left;
  destruct (In_dec eq_nat_dec p addrs);
  [ apply FRESH in i; rewrite H in i; discriminate
  | rewrite <- H; apply alloc_nin ]...
apply IHEVAL; right;
  destruct3 H clovars bind0 pe;
  exists3 clovars bind0 pe;
  destruct (In_dec eq_nat_dec p addrs);
  [ apply FRESH in i; rewrite H in i; discriminate
  | rewrite <- H; apply alloc_nin ]...
(* Case_of *)
apply CCP.Case_of with (bind := bind) (Delta := Delta) (e0 := e0)
  (C := C) (addrs := addrs) (theta := theta) (args0 := args0)
  (fake_bot0 := fake_bot0)...
apply IHEVAL2...
destruct PCLO...
left; assert (BH := doesnt_touch_BH _ _ EVAL1); unfold BH_remains in *...
right; destruct3 H clovars bind1 pe; exists3 clovars bind1 pe;
  assert (BH := doesnt_touch_lfn _ _ EVAL1);
  unfold lfn_remains in *...
Qed.

Lemma correctness :
forall e Value
  (FBSEM : FB.Sem (FB.Config empty_heap e nil (nil, 0) nil) Value),
  CCP.Sem (CCP.Config empty_heap e nil (nil, 0) 0) Value.
Proof.
intros.
assert (I := invariant (<< empty_heap, e, nil, (nil, 0), nil >>)
  Value FBSEM); simpl in *; auto.
Qed.


From hahn Require Import Hahn.
Require Import Events.
Require Import Classical.

Tactic Notation "destruct_seq" constr(x)
       "as" "[" ident(y) ident(z) "]" :=
  apply seq_eqv_l in x; destruct x as [y x];
  apply seq_eqv_r in x; destruct x as [x z].

Tactic Notation "destruct_seq_l" constr(x)
       "as" ident(y) :=
  apply seq_eqv_l in x; destruct x as [y x].

Tactic Notation "destruct_seq_r" constr(x)
       "as" ident(y) :=
  apply seq_eqv_r in x; destruct x as [x y].

Section Props.
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Lemma ntid_tid_set_inter s thread :
  s ⊆₁ s ∩₁ NTid_ thread ∪₁ s ∩₁ Tid_ thread.
Proof using.
  ins.
  rewrite <- set_inter_union_r.
  unfolder. ins. splits; auto.
  destruct (classic (tid x = thread)); eauto.
Qed.
End Props.

Lemma dom_rel_to_cond {A} r (s t : A -> Prop) :
  dom_rel (r ⨾ ⦗t⦘) ⊆₁ s -> t ⊆₁ dom_cond r s.
Proof using.
  unfold dom_cond; unfolder.
  intro H; ins; desf; eapply H; eauto.
Qed.

Lemma dom_cond_to_rel {A} r (s t : A -> Prop) :
  t ⊆₁ dom_cond r s -> dom_rel (r ⨾ ⦗t⦘) ⊆₁ s.
Proof using.
  unfold dom_cond; unfolder.
  intro H; ins; desf; eapply H; eauto.
Qed.


Require Import List.
Require Import String.
Import ListNotations.

Require Import VerdiTactics.
Require Import HandlerMonad.
Require Import Net.
Require Import Util.

Section Notary.
  Parameter secret_key : string.
  Parameter sigPK : string -> string.

  Inductive Name :=
  | Notary : Name
  | Client : Name.

  Definition all_nodes := [Notary; Client].

  Definition Name_eq_dec : forall a b : Name, {a = b} + {a <> b}.
    decide equality.
  Qed.

  Definition Data := unit.
  Definition init_data (n : Name) : Data := tt.

  Theorem In_Nodes :
    forall (n : Name), (In n all_nodes).
  Proof.
    destruct n; [left|right;left]; auto.
   Qed.

  Theorem NoDup_Nodes : NoDup all_nodes.
  Proof.
    repeat constructor; auto.
    intro. destruct H. discriminate. destruct H.
   Qed.

  Global Instance Notary_BaseParams : BaseParams :=
    {
      data   := Data ;
      input  := unit ;
      output := string;

      sigPK := sigPK
    }.

  Definition magic : string := "magic".
  Definition staple s : string := magic ++ s.
  Definition Handler (node _:Name) (msg:string) (_:Data)
    : (list string * Data * list (Name * string) * list (@cryptoEvent Name))
    :=
    match node with
    | Notary => ([],   tt, [], [Sign secret_key (staple msg)])
    | Client => ([msg], tt, [], [Verify (sigPK secret_key) msg])
  end.
  Definition inputHandler (_:Name) (_:unit) (d:Data)
    : (list string * Data * list (Name * string) * list (@cryptoEvent Name))
    := ([], d, [], [Random secret_key])
  .

  Global Instance Notary_MultiParams : MultiParams Notary_BaseParams :=
    {
      name := Name ;
      msg  := string ;
      msg_eq_dec := string_dec ;
      name_eq_dec := Name_eq_dec ;
      nodes := all_nodes;
      all_names_nodes := In_Nodes ;
      no_dup_nodes := NoDup_Nodes ;
      init_handlers := init_data ;
      net_handlers := Handler;
      input_handlers := inputHandler
    }.

  Definition magical s := exists t, s=staple t.
  Lemma magical_staple : forall s, magical (staple s).
    intros; unfold magical, staple. exists s.
  Qed.

  Lemma signed_magic : forall st trace,
    refl_trans_n1_trace step_m step_m_init st trace ->
    forall n s, In (n, Sign secret_key s) (nwCrypto st) -> magical s.
    intros until 1.
    remember step_m_init as s0 in H.
    induction H; [subst; unfold step_m_init; simpl; intros; exfalso; auto|].
    inversion H0; subst net net'. {
      unfold net_handlers in *; simpl in *.
      case_eq (pDst p); intro e; rewrite e in *; simpl in *. {
        injection H1; clear H1; intros until n; revert n; subst; simpl in *.
        intros.
        destruct H1.
        - injection H1; clear H1; intros; subst. apply magical_staple.
        - eapply IHrefl_trans_n1_trace; eauto.
      } {
        injection H1; clear H1; intros; subst.
        unfold mark_cevents_src in *; simpl in *.
        destruct H8; [discriminate|]; eauto.
      }
    } {
      injection H1; clear H1; intros; subst; eauto.
    }
  Qed.

  Goal forall st trace, step_m_star step_m_init st trace ->
    forall (n:Name) (ss:list string), In (n, inr ss) trace ->
    forall s, In s ss -> magical s.
  Proof.
    intros.
    unfold step_m_star in *.
    specialize (refl_trans_1n_n1_trace H); clear H; intro H.
    remember step_m_init as s0 in H.
    induction H; [inversion H0|]; rewrite Heqs0 in *; clear Heqs0.
    destruct (in_app_or _ _ _ H0); try eauto.
    inversion H2. {
      unfold net_handlers in *; simpl in *.
      case_eq (pDst p); intro e; rewrite e in *; clear e; simpl in *;
        injection H4; clear H4; intros; subst; simpl in *;
        destruct H3; intuition;
        injection H3; clear H3; intros; subst; simpl in *; [exfalso; auto|].
      eapply signed_magic; [eauto|].
      intuition. rewrite H3 in *; clear H3.
      edestruct H6; clear H6.
      - left. eauto.
      - right. admit. (* TODO: do not sign anything before random number generation succeeds. Then from right of H2 (left is constructor mismatch). *)
      - intro. destruct H1; [discriminate|]. admit. (* TODO: prove that secret key is never leaked. by induction on steps. *)
      - discriminate H1.
      - admit. (* Anomaly: Signature and its instance do not match. Please report. *)
      (* replace ? (pBody p) by intuition; eapply H3.*)
   } {
    unfold net_handlers in *; subst; simpl in *.
    destruct H3; intuition; discriminate.
   }
  Qed.

End Notary.


(* Test of inference of elimination predicate for "if" *)
(* submitted by Robert R Schneck *)

Axiom bad : false = true.

Definition try1 : False :=
  match bad in (_ = b) return (if b then False else True) with
  | refl_equal => I
  end.

Definition try2 : False :=
  match bad in (_ = b) return ((if b then False else True):Prop) with
  | refl_equal => I
  end.

Definition try3 : False :=
  match
    bad in (_ = b) return ((fun b' : bool => if b' then False else True) b)
  with
  | refl_equal => I
  end.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e382m105_12limbs.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.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^291 - 19
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 32;
    bitwidth := 32;
    s := 2^291;
    c := [(1, 19)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    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.


(** * Stdlib functions using [nat] instead of [int] *)

(** [nat] are unary numbers, so this highly inefficient!
    These operations are unsafe when numbers exceed [max_int] in OCaml.
  *)

(* begin hide *)
From Coq.extraction Require Import
     ExtrOcamlIntConv.

From SimpleIO Require Import
     IO_Monad
     IO_Stdlib.

Import IO.Notations.

Set Warnings "-extraction-opaque-accessed,-extraction".
(* end hide *)

Definition print_nat : nat -> IO unit :=
  fun n => print_int (int_of_nat n).

Definition prerr_nat : nat -> IO unit :=
  fun n => prerr_int (int_of_nat n).

Definition read_nat : IO nat :=
  IO.map nat_of_int read_int.

Definition read_nat_opt : IO (option nat) :=
  IO.map (option_map nat_of_int) read_int_opt.

Definition output_nat : out_channel -> nat -> IO unit :=
  fun h n => output_string h (ostring_of_int (int_of_nat n)).

Definition output_byte_nat : out_channel -> nat -> IO unit :=
  fun h n => output_byte h (int_of_nat n).

Definition input_byte_nat : in_channel -> IO nat :=
  fun h => IO.map nat_of_int (input_byte h).

Definition incr_ref_nat : ref nat -> IO unit :=
  fun r =>
    n <- read_ref r;;
    write_ref r (Nat.succ n).

(** N.B.: 0 decreases to 0. *)
Definition decr_ref_nat : ref nat -> IO unit :=
  fun r =>
    n <- read_ref r;;
    write_ref r (Nat.pred n).

Definition exit_nat {a} : nat -> IO a :=
  fun n => exit (int_of_nat n).