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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Section  Myhill_nerode.
Set Implicit Arguments.
Load Automata.

Definition surj (X Y :Type)  (f :X-> Y) :=

   forall y:Y,  exists x:X, f(x) = y.

Record Fin_Equiv (A:Set) := make_eq {
rel :> A->A->Prop;

 Eq_refl : forall x:A, rel x x;

 Eq_trans : forall (x y z :A), rel x y -> rel y z -> rel x z;
 Eq_sym  : forall (x y :A) , rel x y -> rel y x

} .

Record fin_eq_class (a:Alphabet)(n:nat) :=

 {
     fin_func :> Word a -> Fin n;

     fin_surj : surj  (fin_func)

 }.

Definition congruence (a:Alphabet) (X:Type) (f : Word a-> X)

     :=  forall (x y  aa:Word a), f x = f y -> f (x++ aa) = f (y++ aa).

Definition belongs (a:Alphabet)(X:Type) (f: Word a -> X)(l:Language a) := forall (x y aa:Word a),

    f x = f y -> l x = l y.

Record Myhill_rel (a:Alphabet)(n:nat)(L:Language a):=

   {
      myhill_func :> fin_eq_class a n;

     myhill_congruent : congruence myhill_func;
     myhill_belongs : belongs (myhill_func ) L

    }.

Definition suffix_congruence (a:Alphabet)(u v :Word a)(l:Language a):=

  forall ( w :Word a) , l (u ++ w) = l(v++w).

Definition eq_suffix_cong (a:Alphabet) (X:Type) (f :Word a -> X) (l:Language a):=

    forall (u v :Word a) , f u = f v <-> suffix_congruence u v l.

Definition eq_suffix_cong1 (a:Alphabet)(X:Type) (f:Word a -> X) (l:Language a):=
   forall (u v :Word a), f u =f v -> suffix_congruence u v l.

Record Nerode_rel (a:Alphabet)(n:nat) (L:Language a) :=
   {
      nerode_func :> fin_eq_class a n ;

      nerode_equiv : eq_suffix_cong nerode_func L

   }.
(*
Lemma nerode1 : forall (a:Alphabet)(n:nat)(L:Language a)

        (f:Nerode_rel a n)(w:Word a),  *)

Record Nerode_rel_weak (a:Alphabet)(n:nat) (L:Language a) :=

   { nerode_func_weak :> fin_eq_class a n;

     nerode_equiv_weal:eq_suffix_cong1 nerode_func_weak L

   }.

Definition dfa_connected (a:Alphabet)(n:nat)(d:dfa n a) := isconnected d.

Print dfa_connected.
Require Import List.

(* From automaton section - reachability *)

Lemma reachable0 : forall (a:Alphabet) (n:nat) (d:dfa n a),

         reachable d(q0 d).
intros.
unfold reachable.
exists nil.
simpl.
reflexivity.
Qed.

Lemma reachable_step : forall (a:Alphabet) (n:nat) (d:dfa n a)(x:Fin n)(c:Fin a) ,
         reachable d (x) -> reachable d (delta d x c).

intros.
unfold reachable in *.
destruct H.
induction x0.
simpl in *.

exists (c::nil).
simpl in *.
rewrite H.
reflexivity.

simpl in *.
simpl in H.
inversion H.
simpl in *.

exists (a0::x0 ++(c ::nil)).
simpl.

admit.
(* true *)
(* !!!*)

Qed.
Lemma myhill_suffix : forall (a:Alphabet) (L:Language a),

Definition ff (a:Alphabet)(n:nat)(d:dfa n a):= fun w:Word a=> (q0 d).

End Myhill_nerode.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Export XR_R.
Require Export XR_Rinv.
Require Export XR_Rmult.
Local Open Scope R_scope.
Definition Rdiv (r1 r2:R) : R := r1 * / r2.
Infix "/" := Rdiv   : R_scope.


(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Set Warnings "-notation-overridden,-parsing,-implicit-core-hint-db".
From Coq Require Import Strings.String.
From LF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import MoreStlc.

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

(* ----------------------------------------------------------------- *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | Top   : ty
  | Base  : string -> ty
  | Arrow : ty -> ty -> ty
  (* record types *)
  | RNil : ty
  | RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | rproj : tm -> string -> tm
  (* record terms *)
  | rnil :  tm
  | rcons : string -> tm -> tm -> tm.

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty RNil
  | RTcons : forall i T1 T2,
        record_ty (RCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm rnil
  | rtcons : forall i t1 t2,
        record_tm (rcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTop :
        well_formed_ty Top
  | wfBase : forall i,
        well_formed_ty (Base i)
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (Arrow T1 T2)
  | wfRNil :
        well_formed_ty RNil
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (RCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

(** Substitution and reduction are as before. *)

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 =>  abs y T (if eqb_string x y then t1
                             else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | rproj t1 i => rproj (subst x s t1) i
  | rnil => rnil
  | rcons i t1 tr2 => rcons i (subst x s t1) (subst x s tr2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ----------------------------------------------------------------- *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (abs x T t)
  | v_rnil : value rnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (rcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | RCons i' T Tr' =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | rcons i' t tr' =>
      if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr --> tr' ->
        (rproj tr i) --> (rproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (rproj tr i) --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        (rcons i t1 tr2) --> (rcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        (rcons i v1 tr2) --> (rcons i v1 tr2')

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

(* ################################################################# *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ================================================================= *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: Top
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    Arrow S1 S2 <: Arrow T1 T2
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (RCons i T1 T2) ->
    RCons i T1 T2 <: RNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    RCons i S1 Sr2 <: RCons i T1 Tr2
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (RCons i1 T1 (RCons i2 T2 Tr3)) ->
    i1 <> i2 ->
       RCons i1 T1 (RCons i2 T2 Tr3)
    <: RCons i2 T2 (RCons i1 T1 Tr3)

where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

(* ================================================================= *)
(** ** Examples *)

Module Examples.
Open Scope string_scope.

Notation x := "x".
Notation y := "y".
Notation z := "z".
Notation j := "j".
Notation k := "k".
Notation i := "i".
Notation A := (Base "A").
Notation B := (Base "B").
Notation C := (Base "C").

Definition TRcd_j  :=
  (RCons j (Arrow B B) RNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  RCons k (Arrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (Arrow C TRcd_kj)
          (Arrow C RNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars, standard (subtyping_example_1)  *)
Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  unfold TRcd_kj, TRcd_j.
  eapply S_Trans. eapply S_RcdPerm... discriminate.
  auto.
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_2)  *)
Example subtyping_example_2 :
  subtype (Arrow Top TRcd_kj)
          (Arrow (Arrow C C) TRcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto.
  eapply S_Arrow... apply subtyping_example_1.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_3)  *)
Example subtyping_example_3 :
  subtype (Arrow RNil (RCons j A RNil))
          (Arrow (RCons k B RNil) RNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  eapply S_Arrow...
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (subtyping_example_4)  *)
Example subtyping_example_4 :
  subtype (RCons x A (RCons y B (RCons z C RNil)))
          (RCons z C (RCons y B (RCons x A RNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  eapply S_Trans. apply S_RcdDepth. apply S_Refl... eapply S_RcdPerm...
  discriminate. auto. auto. eapply S_Trans. eapply S_RcdPerm... discriminate.
  eapply S_RcdDepth... eapply S_RcdPerm... discriminate.
Qed.
(** [] *)

End Examples.

(* ================================================================= *)
(** ** Properties of Subtyping *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  - (* RCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...  inversion H0; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve_by_invert.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (eqb_string i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eqb_stringP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (eqb_stringP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars, standard (rcd_types_match_informal)

    Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_rcd_types_match_informal : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, standard, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (Arrow V1 V2) ->
     exists U1 U2,
       (U=(Arrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (Arrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros; try solve_by_invert; subst.
  - inversion H; subst. exists V1, V2...
  - destruct IHHs2 with V1 V2 as [U1 [U2 [HA [HU1 HU2]]]]...
    apply IHHs1 in HA as [U3 [U4 [HA [HU3 HU4]]]]. subst.
    exists U3, U4...
  - inversion HeqV; subst. exists S1, S2...
Qed.
(** [] *)

(* ################################################################# *)
(** * Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- var x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- abs x T11 t12 \in Arrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in Arrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- app t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- rproj t i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- rnil \in RNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- rcons i t tr \in RCons i T Tr

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ================================================================= *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star, standard (typing_example_0)  *)
Definition trcd_kj :=
  (rcons k (abs z A (var z))
           (rcons j (abs z B (var z))
                      rnil)).

Example typing_example_0 :
  has_type empty
           (rcons k (abs z A (var z))
                     (rcons j (abs z B (var z))
                               rnil))
           TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity.
  apply wfBase. apply T_RCons. apply T_Abs. apply wfBase. apply T_Var.
  reflexivity. apply wfBase. apply T_RNil. apply RTnil. apply rtnil.
  apply RTcons. apply rtcons.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (typing_example_1)  *)
Example typing_example_1 :
  has_type empty
           (app (abs x TRcd_j (rproj (var x) j))
                   (trcd_kj))
           (Arrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  eapply T_App. apply T_Abs... apply wfRCons...
  unfold trcd_kj, TRcd_j. eapply T_Sub. eapply T_RCons...
  eapply S_Trans. eapply S_RcdPerm... discriminate. eapply S_RcdDepth...
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (typing_example_2)  *)
Example typing_example_2 :
  has_type empty
           (app (abs z (Arrow (Arrow C C) TRcd_j)
                           (rproj (app (var z)
                                            (abs x C (var x)))
                                    j))
                   (abs z (Arrow C C) trcd_kj))
           (Arrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  eapply T_App. apply T_Abs. apply wfArrow... apply wfRCons...
  unfold TRcd_j. eapply T_Proj. eapply T_App... apply T_Var...
  reflexivity. apply T_Abs... unfold trcd_kj, TRcd_j.
  eapply T_Sub. eapply T_RCons... eapply S_Trans. apply S_RcdPerm...
  discriminate. apply S_RcdDepth...
Qed.
(** [] *)

End Examples2.

(* ================================================================= *)
(** ** Properties of Typing *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  induction Htyp; intros; subst; try solve_by_invert.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (eqb_string i i0).
    + (* i is first *)
      inversion H1. subst. exists t...
    + (* i in tail *)
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Progress *)

(** **** Exercise: 3 stars, standard (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (Arrow T1 T2) ->
     value s ->
     exists x S1 s2,
        s = abs x S1 s2.
Proof with eauto.
  intros. remember (Arrow T1 T2).
   generalize dependent T2. generalize dependent T1.
  induction H; intros; try solve_by_invert...
  subst. apply sub_inversion_arrow in H1 as [U1 [U2 [HA[HU1 HU2]]]].
  eapply IHhas_type...
Qed.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists (app t1 t2')...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists (app t1' t2)...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists (rproj t' i)...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists (rcons i t tr')...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists (rcons i t' tr)...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t --> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 --> t1'] for some term [t1'].  Then [t1 t2 -->
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 --> t2'] for some term [t2'].  Then [t1 t2 -->
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 -->
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr -->
        tr'] for some term [tr'], then [tr.i --> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i --> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_ty
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 --> t1'] for some term [t1'].  Then [{i=t1, tr}
          --> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr --> tr'] for some term [tr'].  Then [{i=t1,
            tr} --> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (var x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (var x) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  - (* T_Var *)
    exists T...
  - (* T_Sub *)
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (app t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (Arrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (app t1 t2) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  - (* T_App *)
    exists T1...
  - (* T_Sub *)
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (abs x S1 t2) T ->
     (exists S2, subtype (Arrow S1 S2) T
              /\ has_type (update Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (abs x S1 t2) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (rproj t1 i) Ti ->
  exists T Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (rproj t1 i) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Proj *)
    assert (well_formed_ty Ti) as Hwf.
    { (* pf of assertion *)
      apply (wf_rcd_lookup i T Ti)...
      apply has_type__wf in H... }
    exists T, Ti...
  - (* T_Sub *)
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U, Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (rcons i ti tr) T ->
  exists Si Sr,
    subtype (RCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (rcons i ti tr) as t.
  induction Hty;
    inversion Heqt; subst...
  - (* T_Sub *)
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri, Rr...
  - (* T_RCons *)
    assert (well_formed_ty (RCons i T Tr)) as Hwf.
    { (* pf of assertion *)
      apply has_type__wf in Hty1.
      apply has_type__wf in Hty2... }
    exists T, Tr...  Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (abs x S1 s2) (Arrow T1 T2) ->
     subtype T1 S1
  /\ has_type (update empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Context Invariance *)

Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (rproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (rcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (rcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold update, t_update. destruct (eqb_stringP x x0)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  - (* T_Abs *)
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  - (* var *)
    rename s into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (eqb_stringP x y)...
    + (* x=y *)
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      destruct (subtype__wf _ _ Hsub)...
  - (* app *)
    destruct (typing_inversion_app _ _ _ _ Htypt)
      as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  - (* abs *)
    rename s into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (Arrow T1 T2)... apply T_Abs...
    destruct (eqb_stringP x y).
    + (* x=y *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst.  rewrite false_eqb_string...
  - (* rproj *)
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  - (* rnil *)
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  - (* rcons *)
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (RCons s Ti Tr)...
    apply T_RCons...
    + (* record_ty Tr *)
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    + (* record_tm ([x:=v]t2) *)
      inversion Hrcdt2; subst; simpl...  Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t --> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  - (* T_Proj *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t --> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr --> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_ty tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

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


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal18.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
Cons n x.

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil))) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil)))))) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


Require Import String.
Require Import Names.
Require Import Arith.
Require Import Bool.
Require Import Functors.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType :+: BType.

  Definition tex1' : DType D := tnat' _. (* Nat *)
  Definition tex1 := proj1_sig tex1'.
  Definition tex2' : DType D := tbool' _. (* Bool *)
  Definition tex2 := proj1_sig tex2'.

  Eval compute in ("Evaluating 'tnat == tnat' as an 'TNat.").
  Eval compute in (eq_DType D tex1 tex1').
  Eval compute in ("Evaluating 'tbool == tbool' as an 'TBool.").
  Eval compute in (eq_DType D tex2 tex2').
  Eval compute in ("Evaluating 'tbool == tnat' as an 'TBool.").
  Eval compute in (eq_DType D tex2 tex1').

End Type_Test_Section.

Section Test_Section.

  Definition E := Arith :+: Bool.

  Definition ex_1 : Names.Exp E :=
    (add' _ (lit' _ 1) (lit' _ 2)).
  Definition ex_2 : Names.Exp E :=
    (add' _ (lit' _ 5) (lit' _ 0)).
  Definition ex_3 : Names.Exp E :=
    (cond' _ (blit' _ true) ex_1 ex_2).
  Definition ex_4 : Names.Exp E :=
    (cond' _ (blit' _ false) ex_1 ex_2).

  Definition test_typeof e :=
    match (typeof D E e) with
      | Some t1 => DTypePrint _ (proj1_sig t1)
      | None => "Type Error!"
    end.

  Eval compute in ("The type of '1 + 2' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_1)).
  Eval compute in ("The type of '145 + 2346' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_2)).
  Eval compute in ("The type of 'true' should be tbool.").
  Eval compute in (test_typeof (blit _ true)).
  Eval compute in ("The type of 'if true then (1 + 2) else (5 + 0)' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_3)).
  Eval compute in ("The type of 'if false then (1 + 2) else (5 + 0)' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_4)).

  Eval compute in (ExpPrint E (proj1_sig ex_1)).
  Eval compute in (ExpPrint E (proj1_sig ex_2)).
  Eval compute in (ExpPrint E (proj1_sig ex_3)).
  Eval compute in (ExpPrint E (proj1_sig ex_4)).

  Definition V := StuckValue :+: BotValue :+: NatValue :+: BoolValue.

  Eval compute in ("Evaluating '1 + 2'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_1) nil))).
  Eval compute in ("Evaluating '5 + 0'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_2) nil))).
  Eval compute in ("Evaluating 'if true then (1 + 2) else (5 + 0)'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_3) nil))).
  Eval compute in ("Evaluating 'if false then (1 + 2) else (5 + 0)'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_4) nil))).

  Definition WFV := (WFValue_Bot D V) ::+:: (WFValue_VI D V) ::+:: (WFValue_VB D V).

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D) E.
    intros; eauto 200 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T, FAlgebra EvalName T (evalR V) E.
    eauto 500 with typeclass_instances.
  Defined.

  Lemma Soundness_Alg typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name (sig (UP'_P2 (eval_alg_Soundness_P D V E WFV unit
      (fun _ _ => True) E (Functor_Plus Arith Bool) tt typeof_rec eval_rec
      f_algebra f_algebra))) E.
    eauto 100 with typeclass_instances.
  Defined.

  Lemma soundness : forall (e : Exp E),
    forall T, typeof D E (proj1_sig e) = Some T ->
      WFValueC D V WFV (eval V E (proj1_sig e) nil) T.
  Proof.
    intro; apply eval_Soundness with (eval_Soundness_alg_F := Soundness_Alg);
      eauto 550 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith :+: Bool Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


(* https://softwarefoundations.cis.upenn.edu/lf-current/Basics.html *)

Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday) friday.
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b_1:bool) (b_2:bool) : bool :=
  match b_1 with
  | true => b_2
  | false => false
  end.

Definition orb (b_1:bool) (b_2:bool) : bool :=
  match b_1 with
  | true => true
  | false => b_2
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition negb' (b:bool) : bool :=
  if b then false
  else true.

Definition andb' (b_1:bool) (b_2:bool) : bool :=
  if b_1 then b_2
  else false.

Definition orb' (b_1:bool) (b_2:bool) : bool :=
  if b_1 then true
  else b_2.

Definition nandb (b_1:bool) (b_2:bool) : bool :=
  if b_1 then (if b_2 then false else true)
  else true.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b_1:bool) (b_2:bool) (b_3:bool) : bool :=
  if b_1 then (if b_2 then b_3 else false)
  else false.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.

Check true
  : bool.
Check (negb true)
  : bool.
Check negb
  : bool -> bool.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

Definition is_red (c : color) : bool :=
  match c with
  | black => false
  | white => true
  | primary red => true
  | primary _ => false
  end.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

Module TuplePlayground.

Inductive bit : Type :=
  | zero
  | one.

Inductive nybble : Type :=
  | bits (b_0 b_1 b_2 b_3 : bit).

Check (bits one zero one zero)
  : nybble.

Definition all_zero (nb : nybble) : bool :=
  match nb with
  | (bits zero zero zero zero) => true
  | (bits _ _ _ _) => false
  end.

Compute (all_zero (bits one zero one zero)).

Compute (all_zero (bits zero zero zero zero)).

End TuplePlayground.

Module NatPlayground.

Inductive nat : Type :=
  | Zero
  | Successor (n : nat).

Definition predecessor (n:nat) : nat :=
  match n with
  | Zero => Zero
  | Successor n' => n'
  end.

End NatPlayground.

Check (S (S (S (S O)))).

Definition minus_two (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minus_two 4).

Check S : nat -> nat.
Check pred : nat -> nat.
Check minus_two : nat -> nat.

Fixpoint even (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n:nat) : bool :=
  negb (even n).

Example test_odd1: odd 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_odd2: odd 4 = false.
Proof. simpl. reflexivity. Qed.

Example test_odd3: odd (S 2) = true.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Compute (plus 3 2).

Fixpoint mult (n m : nat) : nat :=
  match n with
  | O => O
  | S n' => plus m (mult n' m)
  end.

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O , _ => O
  | S _ , O => n
  | S n', S m' => minus n' m'
  end.

End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => 1
  | S p => mult n (factorial p)
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                      (at level 50, left associativity)
                      : nat_scope.
Notation "x - y" := (minus x y)
                      (at level 50, left associativity)
                      : nat_scope.
Notation "x * y" := (mult x y)
                      (at level 40, left associativity)
                      : nat_scope.

Check ((0 + 1) + 1) : nat.

Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
          | O => true
          | _ => false
          end
  | S n' => match m with
             | O => false
             | S m' => eqb n' m'
             end
  end.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
    match m with
    | O => false
    | S m' => leb n' m'
    end
  end.

Example test_leb1: leb 2 2 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 2 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 2 = false.
Proof. simpl. reflexivity. Qed.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Example test_leb3' : (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
  (andb (n <=? m) (negb (n =? m))).

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.
Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.
Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.
Theorem plus_id_example : forall n m : nat,
  n = m ->
  n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite <- H.
  reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H.
  intros H_2.
  rewrite -> H.
  rewrite -> H_2.
  reflexivity. Qed.

Check mult_n_O.
Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem mult_n_1 : forall p : nat, p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative : forall b c,
  andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    -- reflexivity.
    -- reflexivity.
  - destruct c eqn:Ec.
    -- reflexivity.
    -- reflexivity.
Qed.

Theorem andb3_exchange : forall b c d,
  andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  intros H.
  destruct c eqn:Ec.
  - reflexivity.
  - destruct b eqn:Ed.
    -- apply H.
    -- apply H.
Qed.

Theorem zero_nbeq_plus_1: forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

(* Fixpoint decreasing_test (n m : nat) : nat :=
  match n with
  | O => m
  | S O => (decreasing_test O m)
  | S (S n') => (decreasing_test m (S n'))
  end. *)

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H. rewrite -> H.
  reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H. rewrite -> H.
  rewrite -> negb_involutive.
  reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c.
  destruct b eqn:Eb.
  - destruct c eqn:Ec.
    -- reflexivity.
    -- simpl. rewrite <- Eb. intros H. rewrite -> H. reflexivity.
  - destruct c eqn:Ec.
    -- simpl. rewrite <- Eb. intros H. rewrite -> H. reflexivity.
    -- reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B_0 (n : bin)
  | B_1 (n : bin).

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z => B_1 Z
  | B_0 b => B_1 b
  | B_1 b => B_0 (incr b)
  end.

Fixpoint bin_to_nat (m : bin) : nat :=
  match m with
  | Z => 0
  | B_0 b => mult 2 (bin_to_nat b)
  | B_1 b => plus 1 (mult 2 (bin_to_nat b))
  end.

Example test_bin_incr1 : (incr (B_1 Z)) = B_0 (B_1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr2 : (incr (B_0 (B_1 Z))) = B_1 (B_1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr3 : (incr (B_1 (B_1 Z))) = B_0 (B_0 (B_1 Z)).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr4 : bin_to_nat (B_0 (B_1 Z)) = 2.
Proof. simpl. reflexivity. Qed.
Example test_bin_incr5 : bin_to_nat (incr (B_1 Z)) = 1 + bin_to_nat (B_1 Z).
Proof. simpl. reflexivity. Qed.
Example test_bin_incr6 : bin_to_nat (incr (incr (B_1 Z))) = 2 + bin_to_nat (B_1 Z).
Proof. simpl. reflexivity. Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg ssrint.
From mathcomp Require Import path choice fintype tuple finset ssralg bigop poly polydiv.
From mathcomp Require Import zmodp.

From CoqEAL Require Import hrel param refinements binint poly_op hpoly karatsuba.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.
Import Refinements.Op Poly.Op.

Local Open Scope ring_scope.

Ltac in_seq s t :=
  let rec aux s :=
      match s with
      | [::] => constr:(false)
      | (?hd :: ?tl) => match hd with
                        | t => constr:(true)
                        | _ => aux tl
                        end
      end in
  aux s.

Ltac freeVars t A :=
  let rec aux t fv :=
      match t with
      | 0 => fv
      | 1 => fv
      | (?t1 + ?t2) => aux t2 ltac:(aux t1 fv)
      | (?t1 - ?t2) => aux t2 ltac:(aux t1 fv)
      | (?t1 * ?t2) => aux t2 ltac:(aux t1 fv)
      | (- ?t) => aux t fv
      | ?n%:~R => fv
      | _ => let b := in_seq fv t in
             match b with
             | true => fv
             | false => constr:(t :: fv)
             end
      end in
  let s := aux t ([::] : seq A) in
  let n := (eval compute in (size s)) in
  constr:((s, n)).

Inductive PExpr :=
  | PEc : int -> PExpr
  | PEX : nat -> PExpr
  | PEadd : PExpr -> PExpr -> PExpr
  | PEmul : PExpr -> PExpr -> PExpr
  | PEopp : PExpr -> PExpr
  | PEpow : PExpr -> nat -> PExpr.

Definition Npoly (R : comRingType) : nat -> comRingType := fix aux n :=
  if n is n.+1 then poly_comRingType (aux n) else R.

Fixpoint NpolyC (R : comRingType) N : R -> Npoly R N :=
  if N isn't N'.+1 return R -> Npoly R N
  then fun x => x
  else fun x => (NpolyC N' x)%:P.

Fixpoint NpolyX (R : comRingType) N : nat -> Npoly R N :=
  if N isn't N'.+1 return nat -> Npoly R N
  then fun=> 0
  else fun n => if n is n.+1 then (NpolyX R N' n)%:P
                else 'X.

Fixpoint Nmap_poly (R R' : comRingType) (f : R -> R') N :
  Npoly R N -> Npoly R' N :=
  if N isn't N'.+1 return Npoly R N -> Npoly R' N
  then f else map_poly (@Nmap_poly _ _ f N').

Section Nmap_poly_morphism.

  Variable R R' : comRingType.
  Variable g : {additive R -> R'}.
  Variable f : {rmorphism R -> R'}.
  Variable N : nat.

  Fact Nmap_poly_is_additive : additive (Nmap_poly g (N:=N)).
  Proof.
    elim: N=> [|N' IHN] /=.
      exact: raddfB.
    exact: map_poly_is_additive (Additive IHN).
  Qed.
  Canonical Nmap_poly_additive := Additive Nmap_poly_is_additive.

  Fact Nmap_poly_is_rmorphism : rmorphism (Nmap_poly f (N:=N)).
  Proof.
    elim: N=> [|N' IHN] /=.
      exact: rmorphismP.
    exact: map_poly_is_rmorphism (RMorphism IHN).
  Qed.
  Canonical Nmap_poly_rmorphism := RMorphism Nmap_poly_is_rmorphism.

End Nmap_poly_morphism.

Fact horner_key : unit. Proof. exact: tt. Qed.

Fixpoint NhornerR (R : comRingType) N : seq R -> Npoly R N -> R :=
      if N isn't N'.+1 return seq R -> Npoly R N -> R
      then fun _ p => p
      else fun env p => if env is a :: env then NhornerR env p.[NpolyC N' a]
                        else NhornerR [::] p.[0].

Lemma NhornerRS (R : comRingType) N (a : R) (env : seq R) (p : Npoly R N.+1) :
  NhornerR (a :: env) p = NhornerR env p.[NpolyC N a].
Proof. by elim: N p. Qed.

Definition Nhorner (R : comRingType) N (env : seq R)
           (p : Npoly [comRingType of int] N) : R
  := locked_with horner_key (@NhornerR _ _) env (Nmap_poly intr p).

Lemma NhornerE (R : comRingType) N (env : seq R)
          (p : Npoly [comRingType of int] N) :
  Nhorner env p = (@NhornerR _ _) env (Nmap_poly intr p).
Proof. by rewrite /Nhorner; case: horner_key. Qed.

Definition PExpr_to_poly N : PExpr -> Npoly [comRingType of int] N :=
  fix aux p := match p with
  | PEc n => n%:~R
  | PEX n => NpolyX _ N n
  | PEadd p q => aux p + aux q
  | PEmul p q => aux p * aux q
  | PEopp p => - aux p
  | PEpow p n => aux p ^+ n
end.

Definition PExpr_to_Expr (R : comRingType) (env : seq R) : PExpr -> R :=
  fix aux p := match p with
  | PEc n => n%:~R
  | PEX n => env`_n
  | PEadd p q => aux p + aux q
  | PEmul p q => aux p * aux q
  | PEopp p => - aux p
  | PEpow p n => aux p ^+ n
end.

Lemma NhornerRC (R : comRingType) N (env : seq R) (a : R) :
  NhornerR env (NpolyC N a) = a.
Proof. by elim: N env=> [|N IHN] [|b env] //=; rewrite hornerC. Qed.

Lemma Nhorner_is_rmorphism (R : comRingType) (N : nat) (env : seq R) :
  rmorphism (@NhornerR R N env).
Proof.
do !split.
- by elim: N env=> [|N IHN] [|a env] p q //=; rewrite hornerD hornerN IHN.
- by elim: N env=> [|N IHN] [|a env] p q //=; rewrite hornerM IHN.
by elim: N env=> [|N IHN] [|b env] //=; rewrite hornerC.
Qed.

Canonical Nhorner_rmorphism (R : comRingType) (N : nat) (env : seq R) :=
  RMorphism (Nhorner_is_rmorphism N env).

Lemma polyficationP (R : comRingType) (env : seq R) N p : size env == N ->
  PExpr_to_Expr env p = Nhorner env (PExpr_to_poly N p).
Proof.
elim: p=> [n|n|p IHp q IHq|p IHp q IHq|p IHp|p IHp n] /=.
- by rewrite NhornerE !rmorph_int.
- rewrite NhornerE; elim: N env n=> [|N IHN] [|a env] [|n] //= senv.
    by rewrite map_polyX hornerX [RHS]NhornerRC.
  by rewrite map_polyC hornerC !IHN.
- by move=> senv; rewrite (IHp senv) (IHq senv) !NhornerE !rmorphD.
- by move=> senv; rewrite (IHp senv) (IHq senv) !NhornerE !rmorphM.
- by move=> senv; rewrite (IHp senv) !NhornerE !rmorphN.
- by move=> senv; rewrite (IHp senv) !NhornerE !rmorphX.
Qed.

Ltac getIndex t fv :=
  let rec aux s n :=
      match s with
      | (?hd :: ?tl) => match hd with
                        | t => eval compute in n
                        | _ => aux tl uconstr:(n.+1)
                        end
      | _ => fail "Not found"
      end in
  aux fv O.

Ltac toPExpr t fv N :=
  let rec aux t :=
      match t with
      | 0 => uconstr:(PEc 0)
      | 1 => uconstr:(PEc 1)
      | (?t1 + ?t2) => let e1 := aux t1 in
                       let e2 := aux t2 in
                       uconstr:(PEadd e1 e2)
      | (?t1 * ?t2) => let e1 := aux t1 in
                       let e2 := aux t2 in
                       uconstr:(PEmul e1 e2)
      | (- ?t) => let e := aux t in
                  uconstr:(PEopp e)
      | ?n%:~R => uconstr:(PEc n)
      | _ => let n := getIndex t fv in uconstr:(PEX n)
      end in
  let e := aux t in constr:(e : PExpr).

Tactic Notation (at level 0) "translate" constr(t) :=
  let A := type of t in
  let c := freeVars t A in
  let fv := (eval simpl in (c.1)) in
  let n := (eval simpl in (c.2)) in
  let p := toPExpr t fv n in
  have /= := @polyficationP _ fv n p isT.

Tactic Notation "polyfication" :=
  match goal with
  | |- (eq ?lhs ?rhs) =>
    let A := type of lhs in
    let c := freeVars (lhs + rhs) A in
    let fv := (eval simpl in (c.1)) in
    let n := (eval simpl in (c.2)) in
    let pl := toPExpr lhs fv n in
    let pr := toPExpr rhs fv n in
    let rwl := fresh "rwl" in
    let rwr := fresh "rwr" in
    have /= rwl := @polyficationP _ fv n pl isT; rewrite [LHS]rwl {rwl};
    have /= rwr := @polyficationP _ fv n pr isT; rewrite [RHS]rwr {rwr}
  | _ => fail "goal not an equation"
  end.

Tactic Notation "depolyfication" :=
  rewrite NhornerE /NhornerR /=;
  do ?[rewrite ?(rmorph0, rmorphN, rmorphD, rmorphB,
                rmorph1, rmorphM, rmorphX, map_polyC,
                map_polyX, map_polyZ) /=]; rewrite ?hornerE.

Tactic Notation "coqeal_vm_compute_eq2" :=
  do 1?coqeal [(X in Nhorner _ X = _)%pattern] vm_compute;
  do 1?coqeal [(X in _ = Nhorner _ X)%pattern] vm_compute.

Tactic Notation "coqeal_ring" :=
  by polyfication; coqeal_vm_compute_eq2; depolyfication.

Goal true.

  assert (h1 := [coqeal vm_compute of - (1 + 'X%:P * 'X) : {poly {poly int}}]).
  assert (h2 := [coqeal vm_compute of
    (1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X^(sizep (1 : {poly int})))]).
  assert (h3 := [coqeal vm_compute of
    1 + 2%:Z *: 'X + 3%:Z *: 'X^2 - (3%:Z *: 'X^2 + 1 + 2%:Z%:P * 'X)]).
  assert (h4 := [coqeal vm_compute of 'X + 'X^2 * 'X%:P : {poly {poly int}}]).

  have (a b c : int) : a * (b + c) = a * b + a * c.
  Time by coqeal_ring.
  move=> _.

  have (a b c : {poly int}) : (b + c) * a = b * a + c * a.
  Time by coqeal_ring.
  move=> _.

  have (a : {poly int}) : a * 0 = 0.
  Time by coqeal_ring.
  move=> _.

  have (a : Zp_ringType 7) : 0 = a * 0.
  Time by coqeal_ring.
  move=> _.

  have (a : {poly {poly {poly int}}}) : a * 0 = 0.
  Time by coqeal_ring.
  move=> _.

  have (R : comRingType) (a b c : R) : a + b - (1 * b + c * 0) = a.
  Time by coqeal_ring.
  move=> _.
by[].
Qed.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import choice path finset finfun fintype bigop.
From mathcomp Require Import finmap.

Section gensym.

Open Scope fmap_scope.

Definition E := nat.

Definition pre_newname (e : {fset nat}) : {n : nat | n \notin e}.
Proof.
exists (\max_(i : e) val i + 1).
set u := _ + 1; apply/negP => abs; move/negP: (ltnn u); apply.
move: abs; rewrite /u addn1 => abs; rewrite ltnS.
apply: (leq_bigmax [` abs ]%fset).
Qed.

Definition newname (e : {fset nat}) := val (pre_newname e).

Lemma new_nameP e : newname e \notin e.
Proof. rewrite /newname; apply: (@valP _ [pred n | n \notin e]). Qed.

End gensym.


Require Import Utf8 Arith.
Require Import Sorting.Permutation.
Import List List.ListNotations.
Require Import Misc Primes.

Definition euler_crit p :=
  filter (λ a, Nat_pow_mod a ((p - 1) / 2) p =? 1) (seq 0 p).

Definition quad_res p :=
  map (λ a, Nat_pow_mod a 2 p) (seq 1 (p - 1)).

Theorem euler_crit_iff : ∀ p a,
  a ∈ euler_crit p ↔ a < p ∧ a ^ ((p - 1) / 2) mod p = 1.
Proof.
intros.
split. {
  intros Hap.
  destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ now subst p | ].
  unfold euler_crit in Hap.
  apply filter_In in Hap.
  destruct Hap as (Ha, Hap).
  rewrite Nat_pow_mod_is_pow_mod in Hap; [ | easy ].
  apply in_seq in Ha.
  now apply Nat.eqb_eq in Hap.
} {
  intros (Hzap, Hap).
  destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ now subst p | ].
  unfold euler_crit.
  apply filter_In.
  rewrite Nat_pow_mod_is_pow_mod; [ | easy ].
  split; [ apply in_seq; flia Hzap | now apply Nat.eqb_eq ].
}
Qed.

Theorem quad_res_iff : ∀ p a,
  a ∈ quad_res p ↔ ∃ q, 1 ≤ q < p ∧ q ^ 2 mod p = a.
Proof.
intros.
split. {
  intros Hap.
  destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ now subst p | ].
  unfold quad_res in Hap.
  apply in_map_iff in Hap.
  destruct Hap as (b & Hpa & Hb).
  rewrite Nat_pow_mod_is_pow_mod in Hpa; [ | easy ].
  apply in_seq in Hb.
  replace (1 + (p - 1)) with p in Hb by flia Hpz.
  now exists b.
} {
  intros (q & Hqp & Hq).
  destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ now subst p | ].
  unfold quad_res.
  apply in_map_iff.
  exists (q mod p).
  rewrite Nat_pow_mod_is_pow_mod; [ | easy ].
  rewrite Nat_mod_pow_mod.
  split; [ easy | ].
  apply in_seq.
  replace (1 + (p - 1)) with p  by flia Hpz.
  split; [ now rewrite Nat.mod_small | ].
  now apply Nat.mod_upper_bound.
}
Qed.

Theorem all_different_exist : ∀ f n,
  (∀ i, i < n → f i < n)
  → (∀ i j, i < j < n → f i ≠ f j)
  → ∀ a, a < n → ∃ x, f x = a.
Proof.
intros * Hn Hf * Han.
remember (seq 0 n) as l eqn:Hl.
set (g := λ i, if lt_dec i n then f i else i).
assert (Hperm : Permutation l (map g l)). {
  apply Permutation_sym.
  subst l.
  apply nat_bijection_Permutation. {
    intros i Hi; subst g; cbn.
    destruct (lt_dec i n) as [Hin| Hin]; [ | easy ].
    now apply Hn.
  } {
    intros i j Hfij; subst g; cbn in Hfij.
    destruct (lt_dec i n) as [Hin| Hin]. {
      destruct (lt_dec j n) as [Hjn| Hjn]. {
        destruct (lt_dec i j) as [Hij| Hij]. {
          now specialize (Hf i j (conj Hij Hjn)).
        } {
          apply Nat.nlt_ge in Hij.
          destruct (Nat.eq_dec i j) as [Heij| Heij]; [ easy | ].
          assert (H : j < i) by flia Hij Heij.
          specialize (Hf j i (conj H Hin)).
          now symmetry in Hfij.
        }
      } {
        subst j.
        now specialize (Hn _ Hin).
      }
    } {
      destruct (lt_dec j n) as [Hjn| Hjn]; [ | easy ].
      subst i.
      now specialize (Hn _ Hjn).
    }
  }
}
specialize (Permutation_in a Hperm) as H1.
assert (H : a ∈ l). {
  subst l.
  apply in_seq; flia Han.
}
specialize (H1 H); clear H.
subst g; cbn in H1.
apply in_map_iff in H1.
destruct H1 as (x & Hax & Hx).
destruct (lt_dec x n) as [Hxn| Hxn]; [ now exists x | now subst x ].
Qed.

Theorem euler_criterion_quadratic_residue_iff : ∀ p a,
  prime p
  → p ≠ 2
  → a ≠ 0
  → a ∈ euler_crit p ↔ a ∈ quad_res p.
Proof.
intros * Hp Hp2 Haz.
destruct (Nat.eq_dec p 0) as [Hpz| Hpz]; [ now subst p | ].
split; intros Hap. 2: {
  apply quad_res_iff in Hap.
  apply euler_crit_iff.
  destruct Hap as (q & Hqp & Hqpa).
  rewrite <- Hqpa.
  split; [ now apply Nat.mod_upper_bound | ].
  rewrite Nat_mod_pow_mod.
  rewrite <- Nat.pow_mul_r.
  rewrite <- (proj2 (Nat.div_exact _ _ (Nat.neq_succ_0 _))). 2: {
    specialize (odd_prime p Hp Hp2) as H1.
    specialize (Nat.div_mod p 2 (Nat.neq_succ_0 _)) as H2.
    now rewrite H2, H1, Nat.add_sub, Nat.mul_comm, Nat.mod_mul.
  }
  now apply fermat_little.
} {
  apply euler_crit_iff in Hap.
  apply quad_res_iff.
  destruct Hap as (Ha, Hap).
  apply (not_forall_in_interv_imp_exist 1 (p - 1)). {
    intros n.
    apply Decidable.dec_and. {
      apply Decidable.dec_and; [ apply dec_le | apply dec_lt ].
    } {
      apply Nat.eq_decidable.
    }
  } {
    destruct p; [ easy | cbn ].
    destruct p; [ | flia ].
    flia Haz Ha.
  }
  intros H.
  assert (Hnres : ∀ n, 1 ≤ n ≤ p - 1 → n ^ 2 mod p ≠ a). {
    intros n Hn.
    specialize (H n Hn).
    intros H1; apply H.
    split; [ flia Hn | easy ].
  }
  clear H.
  (* https://proofwiki.org/wiki/Euler%27s_Criterion *)
  (* The congruence 𝑏𝑥≡𝑎(mod𝑝) has (modulo 𝑝) a unique solution 𝑏′ by Solution
     of Linear Congruence. *)
  assert (Hbb : ∀ b, 1 ≤ b < p → ∃! b', b' < p ∧ (b * b') mod p = a). {
    intros b Hb.
    specialize (smaller_than_prime_all_different_multiples p Hp b Hb) as H1.
    specialize (not_forall_in_interv_imp_exist 1 (p - 1)) as H2.
    specialize (H2 (λ b', (b * b') mod p = a)).
    cbn in H2.
    assert (H : ∀ n, Decidable.decidable ((b * n) mod p = a)). {
      intros n.
      apply Nat.eq_decidable.
    }
    specialize (H2 H); clear H.
    assert (H : 1 ≤ p - 1). {
      destruct p; [ easy | ].
      destruct p; [ easy | flia ].
    }
    specialize (H2 H); clear H.
    assert (Hb' : ¬ (∀ b', (b * b') mod p ≠ a)). {
      move H1 at bottom.
      intros H3.
      specialize (all_different_exist (λ b', (b' * b) mod p)) as H4.
      cbn in H4.
      specialize (H4 p).
      assert (H : ∀ i, i < p → (i * b) mod p < p). {
        intros.
        now apply Nat.mod_upper_bound.
      }
      specialize (H4 H H1 a Ha); clear H.
      destruct H4 as (b', Hb').
      specialize (H3 b').
      now rewrite Nat.mul_comm in H3.
    }
    assert (H : ¬ (∀ n : nat, 1 ≤ n ≤ p - 1 → (b * n) mod p ≠ a)). {
      intros H; apply Hb'; intros b'.
      destruct (Nat.eq_dec (b' mod p) 0) as [Hb'z| Hb'z]. {
        rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
        rewrite Hb'z, Nat.mul_0_r; cbn.
        rewrite Nat.mod_0_l; [ | easy ].
        now apply Nat.neq_sym.
      }
      rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
      apply H.
      split; [ flia Hb'z | ].
      rewrite Nat.sub_1_r.
      apply Nat.lt_le_pred.
      now apply Nat.mod_upper_bound.
    }
    specialize (H2 H); clear H.
    destruct H2 as (b', H2).
    exists (b' mod p).
    split. {
      split; [ now apply Nat.mod_upper_bound | ].
      now rewrite Nat.mul_mod_idemp_r.
    } {
      intros x (Hxp & Hxa).
      rewrite <- Nat.mul_mod_idemp_r in H2; [ | easy ].
      rewrite <- H2 in Hxa.
      destruct (le_dec (b' mod p) x) as [Hbx| Hbx]. {
        apply Nat_mul_mod_cancel_l in Hxa. 2: {
          rewrite Nat.gcd_comm.
          now apply eq_gcd_prime_small_1.
        }
        rewrite Nat.mod_mod in Hxa; [ | easy ].
        rewrite <- Hxa.
        now apply Nat.mod_small.
      } {
        apply Nat.nle_gt in Hbx.
        symmetry in Hxa.
        apply Nat_mul_mod_cancel_l in Hxa. 2: {
          rewrite Nat.gcd_comm.
          now apply eq_gcd_prime_small_1.
        }
        rewrite Nat.mod_mod in Hxa; [ | easy ].
        symmetry in Hxa.
        now rewrite Nat.mod_small in Hxa.
      }
    }
  }
  (* https://proofwiki.org/wiki/Euler%27s_Criterion *)
  (* Note that 𝑏′≢𝑏, because otherwise we would have 𝑏2≡𝑎(mod𝑝) and 𝑎 would be
     a quadratic residue of 𝑝. *)
  assert
    (H : ∀ b, 1 ≤ b < p → ∃! b', b' < p ∧ (b * b') mod p = a ∧ b ≠ b'). {
    intros b Hbp.
    specialize (Hbb b Hbp).
    destruct Hbb as (b' & (H1 & H2) & H3).
    exists b'.
    split. {
      split; [ easy | ].
      split; [ easy | ].
      intros H; subst b'.
      revert H2.
      rewrite <- Nat.pow_2_r.
      apply Hnres; flia Hbp.
    } {
      intros x' (Hx1 & Hx2 & Hx3).
      now apply H3.
    }
  }
  clear Hbb; rename H into Hbb.
  (* https://proofwiki.org/wiki/Euler%27s_Criterion *)
  (* It follows that the residue classes {1,2,…,𝑝−1} modulo 𝑝 fall into
     (𝑝−1)/2 pairs 𝑏,𝑏′ such that 𝑏𝑏′≡𝑎(mod𝑝). *)
  assert (H : fact (p - 1) mod p = a ^ ((p - 1) / 2) mod p). {
    rewrite fact_eq_fold_left.
    (* very similar with eq_fold_left_mul_seq_2_prime_sub_3_1;
       perhaps a common lemma could be useful *)
    specialize (seq_NoDup (p - 1) 1) as Hnd.
    remember (seq 1 (p - 1)) as l eqn:Hl.
    assert
      (Hij : ∀ i, i ∈ l →
       ∃j, j ∈ l ∧ i ≠ j ∧ (i * j) mod p = a ∧
        ∀ k, k ∈ l → k ≠ i → (k * j) mod p ≠ a). {
      intros i Hi.
      specialize (Hbb i) as H1.
      assert (H : 1 ≤ i < p). {
        subst l.
        apply in_seq in Hi; flia Hi.
      }
      specialize (H1 H); clear H.
      destruct H1 as (j & (Hj1 & Hj2 & Hj3) & Hj4).
      exists j.
      split. {
        subst l; apply in_seq.
        split; [ | flia Hj1 ].
        destruct j; [ | flia ].
        symmetry in Hj2.
        now rewrite Nat.mul_0_r, Nat.mod_0_l in Hj2.
      }
      split; [ easy | ].
      split; [ easy | ].
      intros k Hk Hki.
      specialize (Hj4 k) as H1.
      destruct (Nat.eq_dec ((i * k) mod p) a) as [Hka| Hka]. {
        assert (H : k < p ∧ (i * k) mod p = a ∧ i ≠ k). {
          apply Nat.neq_sym in Hki.
          split; [ | easy ].
          rewrite Hl in Hk.
          apply in_seq in Hk.
          flia Hk.
        }
        specialize (H1 H); clear H.
        subst k.
        rewrite <- Nat.pow_2_r.
        apply Hnres.
        split; [ | flia Hj1 ].
        destruct j; [ | flia ].
        symmetry in Hj2.
        now rewrite Nat.mul_0_r, Nat.mod_0_l in Hj2.
      } {
        intros Hkj.
        move Hj2 at bottom.
        rewrite <- Hkj in Hj2.
        destruct (le_dec k i) as [Hik| Hik]. {
          apply Nat_mul_mod_cancel_r in Hj2. 2: {
            rewrite Nat.gcd_comm.
            apply eq_gcd_prime_small_1; [ easy | ].
            split; [ | easy ].
            destruct j; [ | flia ].
            rewrite Nat.mul_0_r, Nat.mod_0_l in Hkj; [ | easy ].
            now symmetry in Hkj.
          }
          rewrite Nat.mod_small in Hj2. 2: {
            rewrite Hl in Hi; apply in_seq in Hi; flia Hi.
          }
          rewrite Nat.mod_small in Hj2. 2: {
            rewrite Hl in Hk; apply in_seq in Hk; flia Hk.
          }
          now symmetry in Hj2.
        } {
          apply Nat.nle_gt in Hik.
          symmetry in Hj2.
          apply Nat_mul_mod_cancel_r in Hj2. 2: {
            rewrite Nat.gcd_comm.
            apply eq_gcd_prime_small_1; [ easy | ].
            split; [ | easy ].
            destruct j; [ | flia ].
            rewrite Nat.mul_0_r, Nat.mod_0_l in Hkj; [ | easy ].
            now symmetry in Hkj.
          }
          rewrite Hl in Hk; apply in_seq in Hk.
          rewrite Nat.mod_small in Hj2; [ | flia Hk ].
          rewrite Nat.mod_small in Hj2; [ flia Hj2 Hik | ].
          rewrite Hl in Hi; apply in_seq in Hi; flia Hi.
        }
      }
    }
    clear Hbb Hnres.
    replace (p - 1) with (length l). 2: {
      now subst l; rewrite seq_length.
    }
    clear Hap.
    clear Hl.
    remember (length l) as len eqn:Hlen; symmetry in Hlen.
    revert l Hnd Hij Hlen.
    induction len as (len, IHlen) using lt_wf_rec; intros.
    destruct len. {
      apply length_zero_iff_nil in Hlen.
      now rewrite Hlen.
    }
    destruct l as [| b l]; [ easy | ].
    specialize (Hij b (or_introl (eq_refl _))) as H1.
    destruct H1 as (i2 & Hi2l & Hai2 & Hai2p & Hk).
    destruct Hi2l as [Hi2l| Hi2l]; [ easy | ].
    specialize (in_split i2 l Hi2l) as (l1 & l2 & Hll).
    rewrite Hll.
    cbn - [ "/" ]; rewrite Nat.add_0_r.
    rewrite fold_left_app; cbn - [ "/" ].
    rewrite fold_left_mul_from_1.
    rewrite Nat.mul_shuffle0, Nat.mul_comm.
    rewrite fold_left_mul_from_1.
    do 2 rewrite Nat.mul_assoc.
    remember (i2 * 2) as x.
    rewrite <- Nat.mul_assoc; subst x.
    rewrite <- Nat.mul_mod_idemp_l; [ | easy ].
    rewrite (Nat.mul_comm i2).
    rewrite Hai2p.
    replace (S len) with (len - 1 + 1 * 2). 2: {
      destruct len; [ | flia ].
      cbn in Hlen.
      apply Nat.succ_inj in Hlen.
      rewrite Hll in Hlen.
      rewrite app_length in Hlen; cbn in Hlen.
      now rewrite Nat.add_comm in Hlen.
    }
    rewrite Nat.div_add; [ | easy ].
    rewrite Nat.add_comm, Nat.pow_add_r, Nat.pow_1_r.
    rewrite <- Nat.mul_mod_idemp_r; [ | easy ].
    rewrite <- (Nat.mul_mod_idemp_r _ (a ^ _)); [ | easy ].
    f_equal; f_equal.
    rewrite Nat.mul_comm.
    rewrite List_fold_left_mul_assoc, Nat.mul_1_l.
    rewrite <- fold_left_app.
    apply (IHlen (len - 1)); [ flia | | | ]. 3: {
      cbn in Hlen.
      apply Nat.succ_inj in Hlen.
      rewrite <- Hlen, Hll.
      do 2 rewrite app_length.
      cbn; flia.
    } {
      apply NoDup_cons_iff in Hnd.
      destruct Hnd as (_, Hnd).
      rewrite Hll in Hnd.
      now apply NoDup_remove_1 in Hnd.
    }
    intros i Hi.
    specialize (Hij i) as H1.
    assert (H : i ∈ b :: l). {
      right; rewrite Hll.
      apply in_app_or in Hi.
      apply in_or_app.
      destruct Hi as [Hi| Hi]; [ now left | now right; right ].
    }
    specialize (H1 H); clear H.
    destruct H1 as (j & Hjall & Hinj & Hijp & Hk').
    exists j.
    split. {
      destruct Hjall as [Hjall| Hjall]. {
        subst j; exfalso.
        specialize (Hk' i2) as H1.
        assert (H : i2 ∈ b :: l). {
          now rewrite Hll; right; apply in_or_app; right; left.
        }
        specialize (H1 H); clear H.
        assert (H : i2 ≠ i). {
          intros H; subst i2.
          move Hnd at bottom; move Hi at bottom.
          apply NoDup_cons_iff in Hnd.
          destruct Hnd as (_, Hnd).
          rewrite Hll in Hnd.
          now apply NoDup_remove_2 in Hnd.
        }
        specialize (H1 H).
        now rewrite Nat.mul_comm in H1.
      }
      rewrite Hll in Hjall.
      apply in_app_or in Hjall.
      apply in_or_app.
      destruct Hjall as [Hjall| Hjall]; [ now left | ].
      destruct Hjall as [Hjall| Hjall]; [ | now right ].
      subst j.
      destruct (Nat.eq_dec b i) as [Hbi| Hbi]. {
        subst i.
        move Hnd at bottom.
        apply NoDup_cons_iff in Hnd.
        destruct Hnd as (Hnd, _).
        exfalso; apply Hnd; clear Hnd.
        rewrite Hll.
        apply in_app_or in Hi.
        apply in_or_app.
        destruct Hi as [Hi| Hi]; [ now left | now right; right ].
      }
      now specialize (Hk' b (or_introl eq_refl) Hbi) as H2.
    }
    split; [ easy | ].
    split; [ easy | ].
    intros k Hkll Hki.
    apply Hk'; [ | easy ].
    right.
    rewrite Hll.
    apply in_app_or in Hkll.
    apply in_or_app.
    destruct Hkll as [Hkll| Hkll]; [ now left | now right; right ].
  }
  specialize (proj1 (Wilson p (prime_ge_2 p Hp)) Hp) as HW.
  rewrite Hap, HW in H.
  flia Hp2 H.
}
Qed.


Set Automatic Coercions Import.

Require Import util c_util flow stability containers Morphisms.
Require EquivDec.
Set Implicit Arguments.

Open Local Scope CR_scope.

Record System: Type :=
  { Point: CSetoid

  ; Location: Set
  ; Location_eq_dec: EquivDec.EqDec Location eq

  ; State := Location * Point

  ; locations: ExhaustiveList Location
  ; NoDup_locations: NoDup locations

  ; initial: Location * Point -> Prop

(*
  ; invariant': morpher (@eq Location ==> @cs_eq Point ==> iff)%signature
*)

  ; invariant: Location * Point -> Prop
  ; invariant_initial: initial ⊆ invariant
  ; invariant_mor: Proper ((@eq _) ==> (@cs_eq _) ==> iff) (curry invariant)
    (* hm, can't we just use a unary morphism with product setoid equality on State? *)
  ; invariant_stable: forall s, Stable (invariant s)

  ; flow: Location -> Flow Point

  ; guard: Location * Point -> Location -> Prop
  ; reset: Location -> Location -> Point -> Point
    (* this separation of guard and reset seems to cause a problem:
    the paper allows having different transitions from a given (l, x) to
    some (l', x'), because you can have different transitions. we only allow one! *)
  }.

Existing Instance invariant_mor.

Hint Resolve Location_eq_dec locations: typeclass_instances.

Implicit Arguments Build_System [Point Location invariant initial].
Implicit Arguments initial [s].
Implicit Arguments invariant [[s]].

Section transitions_and_reachability.

  Variable system: System.

  Let State: Type := State system.
  Definition location: State -> Location system := fst.
  Definition point: State -> Point system := snd.

  Definition can_flow l: relation (Point system) := fun p p' =>
    exists d: Duration,
      (forall t, 0 <= t -> t <= `d -> invariant (l, flow system l p t))%CR
      /\ flow system l p (`d) [=] p'.

  Definition cont_trans: relation State := fun s s' =>
    location s = location s' /\
    can_flow (location s) (point s) (point s').

  Definition disc_trans: relation State := fun s s' =>
    guard system s (location s') /\
     reset system (location s) (location s') (point s) = point s' /\
      invariant s /\ invariant s'.

  Definition trans: relation State
    := fun s s' => disc_trans s s' \/ cont_trans s s'.

  Notation "s ->_C s'" := (cont_trans s s') (at level 70).
  Notation "s ->_D s'" := (disc_trans s s') (at level 70).
  Notation "s ->_T s'" := (trans s s') (at level 90).

  Lemma cont_trans_refl s: invariant s -> s ->_C s.
  Proof with auto.
    revert s.
    intros [l p] H.
    split...
    exists NonNegCR_zero.
    split. intros.
      rewrite (curry_eq (@invariant system)),
        (snd (CRle_def t 0)), flow_zero...
    apply flow_zero.
  Qed.

  Hint Resolve cont_trans_refl.
  Hint Resolve invariant_stable.

  Lemma cont_trans_trans: Transitive cont_trans.
  Proof with auto.
    intros [l p] [l' p'] [l'' p''] [ll' [t [i f]]] [l'l'' [t' [i' f']]].
    simpl location in *. simpl point in *. subst.
    split...
    exists (NonNegCR_plus t t').
    destruct t as [t nt]. destruct t' as [t' nt'].
    split.
      simpl proj1_sig in *.
      intros. simpl.
      apply (DN_apply (CRle_dec t t0))...
      intros [A | B]...
      rename t0 into x.
      rewrite
        (curry_eq (@invariant system)),
        (t11 t x),
        (flow_additive (flow system l'') p t (x - t)),
        f.
      apply i'.
        rewrite <- (Ropp_def CR_ring_theory t).
        apply t2...
      rewrite (t11 t t').
      rewrite (Radd_assoc CR_ring_theory).
      apply t2...
    simpl. rewrite flow_additive, f...
  Qed.

  Hint Resolve cont_trans_trans.

  Lemma cont_trans_preserves_location s s': s ->_C s' -> fst s = fst s'.
  Proof. intros. destruct H; auto... Qed.

  (* hm, the paper distinguishes between R^n and the
  subset that is the continuous state space for the HS, and i
  seem to recall that flowing could actually end up outside the
  latter. i don't see any of this in our definition *)

  Definition reachable (s: State): Prop :=
    exists i: State, initial i /\ trans_refl_closure.R trans i s.

  Definition unreachable (s: State): Prop := ~ reachable s.

  Hint Unfold reachable.

  Definition trans_kind (b: bool) := if b then disc_trans else cont_trans.

  Hint Unfold trans_kind.

  Definition reachable_alternating (s: State): Prop :=
    exists i: State, initial i /\ alternate trans_kind i s.

  Lemma reachable_invariant: reachable ⊆ invariant.
  Proof with auto with real.
    intros dst [src [src_init src_reach_dst]].
    induction src_reach_dst as [ | s [l' p'] [l'' p''] R IH T].
      apply invariant_initial...
    destruct T as [[_ [_ [_ H]]] | [A [B [C D]]]]...
    simpl in A. subst.
    unfold In, predicate_container.
    rewrite (curry_eq invariant).
    rewrite <- D.
    apply C...
    apply (CRnonNeg_le_zero (`B))...
  Qed.

  Lemma alternating_reachable: forall s, reachable_alternating s <-> reachable s.
  Proof with eauto.
    split.
      intros [s' [i [b t]]].
      exists s'.
      split... clear i.
      induction t...
      apply trans_refl_closure.step with y...
      destruct b; [left | right]...
    intros [x [H H0]].
    exists x. split...
    induction H0. exists true...
    destruct IHR...
    destruct H1; [exists true | exists false]; destruct x...
      apply end_with_next with b...
      apply end_with_next with b...
      apply cont_trans_refl.
      apply reachable_invariant.
      eauto 20.
    inversion_clear H2...
  Qed.

End transitions_and_reachability.

Implicit Arguments reachable [[system]].
Implicit Arguments unreachable [[system]].
Hint Unfold cont_trans.
Hint Unfold can_flow.