Require Import HoTT.
Require Import polynomial.
Require Import polynomial_lemma.

Structure it_signature :=
  {
    point_index : Type ;
    point : point_index -> polynomial
  }.

Structure it_algebra (Σ : it_signature) :=
  {
    carrier :> Type ;
    it_point : forall (i : point_index Σ), poly_act (point Σ i) carrier -> carrier
  }.

Arguments carrier {_}.
Arguments it_point {Σ} i _.

Section it_morphism.
  Variable (Σ : it_signature).

  Class it_morph {A₁ A₂ : it_algebra Σ} (f : A₁ -> A₂) :=
    point_commute : forall (i : point_index Σ) (x : poly_act (point Σ i) A₁),
      f(it_point A₁ i x) = it_point A₂ i (poly_map (point Σ i) f x).

  Global Instance id_it_morph (A : it_algebra Σ) : it_morph (idmap : A -> A)
    := fun i x => ap (it_point A i) (poly_map_id (point Σ i) x)^.

  Global Instance comp_it_morph
             {A₁ A₂ A₃ : it_algebra Σ}
             (g : A₂ -> A₃) `{it_morph _ _ g}
             (f : A₁ -> A₂) `{it_morph _ _ f}
    : it_morph (g o f)
    := fun i x =>
         (ap g (point_commute i x))
           @ (point_commute i (poly_map (point Σ i) f x))
           @ ap (it_point A₃ i) (poly_map_compose g f x)^.
End it_morphism.

Arguments it_morph {Σ} {A₁ A₂} f.
Arguments point_commute {Σ A₁ A₂} f {_} i.
Arguments id_it_morph {Σ} A.
Arguments comp_it_morph {Σ A₁ A₂ A₃} g {_} f {_}.

Section initial_it_algebra.
  Variable (Σ : it_signature).

  Definition weak_initial (A : it_algebra Σ) : Type
    := forall (B : it_algebra Σ), {f : A -> B & it_morph f}.

  Definition unique_initial (A : it_algebra Σ) : Type
    := forall (B : it_algebra Σ) (f g : A -> B),
      it_morph f -> it_morph g -> forall (x : A), f x = g x.

  Definition initial (A : it_algebra Σ) : Type
    := weak_initial A * unique_initial A.
End initial_it_algebra.

Arguments weak_initial {Σ} A.
Arguments unique_initial {Σ} A.
Arguments initial {Σ} A.

Section inductive_type.
  Variable (Σ : it_signature).

  Definition point_over
             {T : Type}
             (F : T -> Type)
             (c : forall i, poly_act (point Σ i) T -> T)
    := forall (i : point_index Σ) (u : poly_act (point Σ i) T),
      poly_fam (point Σ i) F u -> F (c i u).

  Structure IT :=
    {
      it_alg :> it_algebra Σ ;
      it_ind : forall (F : carrier it_alg -> Type)
                      (c : point_over F (it_point it_alg))
                      (x : carrier it_alg),
          F x ;
      it_ind_beta : forall (F : carrier it_alg -> Type)
                           (c : point_over F (it_point it_alg))
                           (i : point_index Σ)
                           (t : poly_act (point Σ i) (carrier it_alg)),
          it_ind F c (it_point it_alg i t) =
          c i t (poly_dmap (point Σ i) (it_ind F c) t)
    }.

  Definition it_rec_map (T : IT) (A : it_algebra Σ) : T -> A
    := it_ind T (fun _ => A) (fun i x p => (it_point A i (fam_const _ p))).

  Global Instance it_rec_map_is_morph (T : IT) (A : it_algebra Σ)
    : it_morph (it_rec_map T A)
    := fun i x => it_ind_beta _ _ _ _ _ @ ap (it_point A i) (fam_const_map _ x).

  Definition it_rec (T : IT) (A : it_algebra Σ) : {f : T -> A & it_morph f}
    := (it_rec_map T A;it_rec_map_is_morph T A).

  Definition it_rec_beta
             (T : IT) (A : it_algebra Σ)
             (i : point_index Σ) (x : poly_act (point Σ i) T)
    : (it_rec T A).1 (it_point T i x)
      =
      it_point A i (poly_map (point Σ i) (it_rec T A).1 x)
    := it_ind_beta _ _ _ i x @ ap (it_point A i) (const_dmap (it_rec T A).1 x).
End inductive_type.

Arguments it_ind {Σ _} F c.
Arguments it_ind_beta {Σ _} F c _ _.
Arguments it_rec {Σ T} A.
Arguments it_rec_beta {Σ T} A i x.

Section uniqueness_inductive_types.
  Variable (Σ : it_signature).

  Definition it_to_it (T₁ T₂ : IT Σ) : {f : T₁ -> T₂ & it_morph f}
    := it_rec T₂.

  Definition it_to_it_eq (T₁ T₂ : IT Σ)
    : forall (x : T₂), (it_to_it T₁ T₂).1 ((it_to_it T₂ T₁).1 x) = x
    := it_ind
         _
         (fun i x y =>
            (ap _ (it_rec_beta T₁ i x))
              @ (it_rec_beta T₂ i (poly_map (point Σ i) (it_to_it T₂ T₁).1 x))
              @ (ap (it_point T₂ i)
                    (((poly_map_compose _ _ x)^)
                       @ (fam_eq _ _ x y)
                       @ (poly_map_id (point Σ i) x))
                )).

  Global Instance is_equiv_it_to_it (T₁ T₂ : IT Σ)
    : IsEquiv (it_to_it T₁ T₂).1
    := isequiv_adjointify _
                          (it_to_it T₂ T₁).1
                          (it_to_it_eq T₁ T₂)
                          (it_to_it_eq T₂ T₁).
End uniqueness_inductive_types.

Section inductive_type_is_fixpoint.
  Variable (Σ : it_signature) (T : IT Σ).

  Definition T_to_FT : T -> {i : point_index Σ & poly_act (point Σ i) T}
    := it_ind _ (fun i x _ => (i;x)).

  Definition FT_to_T : {i : point_index Σ & poly_act (point Σ i) T} -> T
    := fun x => it_point T x.1 x.2.

  Global Instance is_equiv_T_to_FT : IsEquiv T_to_FT
    := isequiv_adjointify
         _
         FT_to_T
         (fun x => it_ind_beta _ _ x.1 x.2)
         (it_ind (fun z => FT_to_T(T_to_FT z) = z)
                 (fun i y _ => ap FT_to_T (it_ind_beta _ _ i y))).
End inductive_type_is_fixpoint.

Section inductive_type_is_initial.
  Variable (Σ : it_signature) (T : IT Σ).

  Definition inductive_to_initial : initial T
    := ((fun A => it_rec A),
        fun A f g Hf Hg =>
          it_ind (fun z => f z = g z)
                 (fun i y z =>
                    (point_commute f i y)
                      @ (ap (it_point A i) (fam_eq f g y z))
                      @ (point_commute g i y)^)).
End inductive_type_is_initial.

Section initial_is_inductive.
  Variable (Σ : it_signature) (T : it_algebra Σ) (HT : initial T).

  Definition dependent_algebra
             (F : T -> Type)
             (c : point_over Σ F (it_point T))
    : it_algebra Σ
    := {|carrier := {x : T & F x} ;
         it_point :=
           fun i x =>
             let u := poly_map (point Σ i) pr1 x in
             (it_point T i u;
                c i
                  u
                  (fam_sum _ (@poly_dmap (point Σ i) {x : T & F x} (fun z => F z.1) pr2 x))
             )
       |}.

  Global Instance pr_dependent_algebra
             (F : T -> Type)
             (c : point_over Σ F (it_point T))
    : it_morph (pr1 : dependent_algebra F c -> T)
    := fun i x => idpath.

  Definition initial_to_inductive : IT Σ.
  Proof.
    destruct HT as [T_rec T_unique].
    simple refine {|it_alg := T|}.
    - intros F c x.
      destruct (T_rec (dependent_algebra F c)) as [f Hf].
      exact (transport F (T_unique T (pr1 o f) idmap _ _ x) (f x).2).
    - intros F c i x ; cbn.
      destruct (T_rec (dependent_algebra F c)) as [f Hf].
      rewrite (transport_pr2 _ _ (Hf i x)) ; simpl.
(*      Check (ap pr1 (Hf i x)^ @
     T_unique T (fun x0 : T => (f x0).1) idmap (comp_it_morph _ f)
     (id_it_morph T) (it_point T i x)).
      assert ((poly_map (point Σ i) pr1 (poly_map (point Σ i) f x)) = x).
      {
        induction (point Σ i) ; cbn.
        - refine (T_unique T (fun x0 : T => (f x0).1) idmap (comp_it_morph _ f)
                          (id_it_morph T) _).
        - reflexivity.
        - exact (path_prod' (IHp1 (fst x)) (IHp2 (snd x))).
        - destruct x as [x | x].
          + apply (ap inl (IHp1 x)).
          + apply (ap inr (IHp2 x)).
      }
      Check (fam_sum (poly_map (point Σ i) f x) (poly_dmap (point Σ i) _ (poly_map (point Σ i) f x))).
      Definition test
                 (F : T -> Type)
                 (c : point_over Σ F (it_point T))
                 (i : point_index Σ)
                 (x : poly_act (point Σ i) T)
                 (f : T -> dependent_algebra F c)
                 (p : it_point T i (poly_map (point Σ i) pr1 (poly_map (point Σ i) f x))
                      = it_point T i x)
                 g z
        : transport F p (c i (poly_map (point Σ i) pr1 (poly_map (point Σ i) f x)) z)
          =
          c i x (g z).
      Proof.
 *)
  Admitted.
End initial_is_inductive.


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 C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A Aprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ col_ O Bprime Cprime)))))))))) -> col_ O Aprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(***
Modulus : 2^255-19
Base: 25.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 25 + 1/2;
    bitwidth := 32;
    s := 2^255;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

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

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

    mul_code := Some (fun a b =>
      (* Micro-optimized form from curve25519-donna by Adam Langley (Google) and Daniel Bernstein. See <https://github.com/agl/curve25519-donna/blob/master/LICENSE.md>. *)
      let '(in9, in8, in7, in6, in5, in4, in3, in2, in1, in0) := a in
      let '(in29, in28, in27, in26, in25, in24, in23, in22, in21, in20) := b in
      dlet output0 :=       in20 * in0 in
      dlet output1 :=       in20 * in1 +
                            in21 * in0 in
      dlet output2 :=  2 *  in21 * in1 +
                            in20 * in2 +
                            in22 * in0 in
      dlet output3 :=       in21 * in2 +
                            in22 * in1 +
                            in20 * in3 +
                            in23 * in0 in
      dlet output4 :=       in22 * in2 +
                       2 * (in21 * in3 +
                            in23 * in1) +
                            in20 * in4 +
                            in24 * in0 in
      dlet output5 :=       in22 * in3 +
                            in23 * in2 +
                            in21 * in4 +
                            in24 * in1 +
                            in20 * in5 +
                            in25 * in0 in
      dlet output6 :=  2 * (in23 * in3 +
                            in21 * in5 +
                            in25 * in1) +
                            in22 * in4 +
                            in24 * in2 +
                            in20 * in6 +
                            in26 * in0 in
      dlet output7 :=       in23 * in4 +
                            in24 * in3 +
                            in22 * in5 +
                            in25 * in2 +
                            in21 * in6 +
                            in26 * in1 +
                            in20 * in7 +
                            in27 * in0 in
      dlet output8 :=       in24 * in4 +
                       2 * (in23 * in5 +
                            in25 * in3 +
                            in21 * in7 +
                            in27 * in1) +
                            in22 * in6 +
                            in26 * in2 +
                            in20 * in8 +
                            in28 * in0 in
      dlet output9 :=       in24 * in5 +
                            in25 * in4 +
                            in23 * in6 +
                            in26 * in3 +
                            in22 * in7 +
                            in27 * in2 +
                            in21 * in8 +
                            in28 * in1 +
                            in20 * in9 +
                            in29 * in0 in
      dlet output10 := 2 * (in25 * in5 +
                            in23 * in7 +
                            in27 * in3 +
                            in21 * in9 +
                            in29 * in1) +
                            in24 * in6 +
                            in26 * in4 +
                            in22 * in8 +
                            in28 * in2 in
      dlet output11 :=      in25 * in6 +
                            in26 * in5 +
                            in24 * in7 +
                            in27 * in4 +
                            in23 * in8 +
                            in28 * in3 +
                            in22 * in9 +
                            in29 * in2 in
      dlet output12 :=      in26 * in6 +
                       2 * (in25 * in7 +
                            in27 * in5 +
                            in23 * in9 +
                            in29 * in3) +
                            in24 * in8 +
                            in28 * in4 in
      dlet output13 :=      in26 * in7 +
                            in27 * in6 +
                            in25 * in8 +
                            in28 * in5 +
                            in24 * in9 +
                            in29 * in4 in
      dlet output14 := 2 * (in27 * in7 +
                            in25 * in9 +
                            in29 * in5) +
                            in26 * in8 +
                            in28 * in6 in
      dlet output15 :=      in27 * in8 +
                            in28 * in7 +
                            in26 * in9 +
                            in29 * in6 in
      dlet output16 :=      in28 * in8 +
                       2 * (in27 * in9 +
                            in29 * in7) in
      dlet output17 :=      in28 * in9 +
                            in29 * in8 in
      dlet output18 := 2 *  in29 * in9 in
      dlet output8 := output8 + output18 << 4 in
      dlet output8 := output8 + output18 << 1 in
      dlet output8 := output8 + output18 in
      dlet output7 := output7 + output17 << 4 in
      dlet output7 := output7 + output17 << 1 in
      dlet output7 := output7 + output17 in
      dlet output6 := output6 + output16 << 4 in
      dlet output6 := output6 + output16 << 1 in
      dlet output6 := output6 + output16 in
      dlet output5 := output5 + output15 << 4 in
      dlet output5 := output5 + output15 << 1 in
      dlet output5 := output5 + output15 in
      dlet output4 := output4 + output14 << 4 in
      dlet output4 := output4 + output14 << 1 in
      dlet output4 := output4 + output14 in
      dlet output3 := output3 + output13 << 4 in
      dlet output3 := output3 + output13 << 1 in
      dlet output3 := output3 + output13 in
      dlet output2 := output2 + output12 << 4 in
      dlet output2 := output2 + output12 << 1 in
      dlet output2 := output2 + output12 in
      dlet output1 := output1 + output11 << 4 in
      dlet output1 := output1 + output11 << 1 in
      dlet output1 := output1 + output11 in
      dlet output0 := output0 + output10 << 4 in
      dlet output0 := output0 + output10 << 1 in
      dlet output0 := output0 + output10 in
      (output9, output8, output7, output6, output5, output4, output3, output2, output1, output0)
            );

    square_code := Some (fun a =>
      (* Micro-optimized form from curve25519-donna by Adam Langley (Google) and Daniel Bernstein. See <https://github.com/agl/curve25519-donna/blob/master/LICENSE.md>. *)
      let '(in9, in8, in7, in6, in5, in4, in3, in2, in1, in0) := a in
      dlet output0 :=       in0 * in0 in
      dlet output1 :=  2 *  in0 * in1 in
      dlet output2 :=  2 * (in1 * in1 +
                            in0 * in2) in
      dlet output3 :=  2 * (in1 * in2 +
                            in0 * in3) in
      dlet output4 :=       in2 * in2 +
                       4 *  in1 * in3 +
                       2 *  in0 * in4 in
      dlet output5 :=  2 * (in2 * in3 +
                            in1 * in4 +
                            in0 * in5) in
      dlet output6 :=  2 * (in3 * in3 +
                            in2 * in4 +
                            in0 * in6 +
                       2 *  in1 * in5) in
      dlet output7 :=  2 * (in3 * in4 +
                            in2 * in5 +
                            in1 * in6 +
                            in0 * in7) in
      dlet output8 :=       in4 * in4 +
                       2 * (in2 * in6 +
                            in0 * in8 +
                       2 * (in1 * in7 +
                            in3 * in5)) in
      dlet output9 :=  2 * (in4 * in5 +
                            in3 * in6 +
                            in2 * in7 +
                            in1 * in8 +
                            in0 * in9) in
      dlet output10 := 2 * (in5 * in5 +
                            in4 * in6 +
                            in2 * in8 +
                       2 * (in3 * in7 +
                            in1 * in9)) in
      dlet output11 := 2 * (in5 * in6 +
                            in4 * in7 +
                            in3 * in8 +
                            in2 * in9) in
      dlet output12 :=      in6 * in6 +
                       2 * (in4 * in8 +
                       2 * (in5 * in7 +
                            in3 * in9)) in
      dlet output13 := 2 * (in6 * in7 +
                            in5 * in8 +
                            in4 * in9) in
      dlet output14 := 2 * (in7 * in7 +
                            in6 * in8 +
                       2 *  in5 * in9) in
      dlet output15 := 2 * (in7 * in8 +
                            in6 * in9) in
      dlet output16 :=      in8 * in8 +
                       4 *  in7 * in9 in
      dlet output17 := 2 *  in8 * in9 in
      dlet output18 := 2 *  in9 * in9 in
      dlet output8 := output8 + output18 << 4 in
      dlet output8 := output8 + output18 << 1 in
      dlet output8 := output8 + output18 in
      dlet output7 := output7 + output17 << 4 in
      dlet output7 := output7 + output17 << 1 in
      dlet output7 := output7 + output17 in
      dlet output6 := output6 + output16 << 4 in
      dlet output6 := output6 + output16 << 1 in
      dlet output6 := output6 + output16 in
      dlet output5 := output5 + output15 << 4 in
      dlet output5 := output5 + output15 << 1 in
      dlet output5 := output5 + output15 in
      dlet output4 := output4 + output14 << 4 in
      dlet output4 := output4 + output14 << 1 in
      dlet output4 := output4 + output14 in
      dlet output3 := output3 + output13 << 4 in
      dlet output3 := output3 + output13 << 1 in
      dlet output3 := output3 + output13 in
      dlet output2 := output2 + output12 << 4 in
      dlet output2 := output2 + output12 << 1 in
      dlet output2 := output2 + output12 in
      dlet output1 := output1 + output11 << 4 in
      dlet output1 := output1 + output11 << 1 in
      dlet output1 := output1 + output11 in
      dlet output0 := output0 + output10 << 4 in
      dlet output0 := output0 + output10 << 1 in
      dlet output0 := output0 + output10 in
      (output9, output8, output7, output6, output5, output4, output3, output2, output1, output0)
            );

    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.


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 C D Aprime : Universe, ((wd_ B C /\ (wd_ C A /\ (wd_ B A /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ C D /\ (col_ Aprime B C /\ col_ A B Aprime))))))) -> col_ B C A)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


Require Export parser.
Require Export refine.

Definition starter: IA := parse
"IA [t1,t2] (t1) [] [start] [] [t1->(start)t2]".

(*at m: true*)
Definition starter_m_rep: IA := starter.

Definition starter_m_hid: IA := starter.

Eval compute in SMENI_refinement starter_m_rep starter_m_hid.

(*at l: true*)
Definition starter_l_rep: IA :=
 IAutomaton.hiding starter (ASet.GenActs [&"start"]).

Definition starter_l_hid: IA :=
 IAutomaton.hiding starter (ASet.GenActs [&"start"]).

Eval compute in SMENI_refinement starter_l_rep starter_l_hid.


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

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.
Require Import RezkCompletion.auxiliary_lemmas_HoTT.
Require Import RezkCompletion.precategories.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
Local Notation "f ;; g" := (compose f g)(at level 50).

Section def_initial.

Variable C : precategory.

Definition isInitial (a : C) := forall b : C, iscontr (a --> b).

Definition Initial := total2 (fun a => isInitial a).

Definition InitialObject (O : Initial) : C := pr1 O.
Coercion InitialObject : Initial >-> ob.

Definition InitialArrow (O : Initial) (b : C) : O --> b :=  pr1 (pr2 O b).

Lemma InitialEndo_is_identity (O : Initial) (f : O --> O) : identity O == f.
Proof.
  apply proofirrelevance.
  apply isapropifcontr.
  apply (pr2 O O).
Qed.

Lemma isiso_from_Initial_to_Initial (O O' : Initial) :
   is_isomorphism (InitialArrow O O').
Proof.
  exists (InitialArrow O' O).
  split; apply pathsinv0;
   apply InitialEndo_is_identity.
Defined.

Definition iso_Initials (O O' : Initial) : iso O O' :=
   tpair _ (InitialArrow O O') (isiso_from_Initial_to_Initial O O') .

Definition hasInitial := ishinh Initial.

Section Initial_Unique.

Hypothesis H : is_category C.

Lemma isaprop_Initial : isaprop Initial.
Proof.
  apply invproofirrelevance.
  intros O O'.
  apply (total2_paths (isotoid _ H (iso_Initials O O')) ).
  apply proofirrelevance.
  unfold isInitial.
  apply impred.
  intro t ; apply isapropiscontr.
Qed.

End Initial_Unique.

End def_initial.


(** This module defines the type system of Simply RaTT. *)

From SimplyRatt Require Export Substitutions.

From Coq Require Import Omega Program.Equality.

(* Definition of well-formed types *)
Inductive wf_type : nat -> type -> Prop :=
| IT_Unit : forall Th,
    wf_type Th Unit
| IT_Nat  : forall Th,
    wf_type Th Nat
| IT_TypeVar : forall Th i,
    i < Th ->
    wf_type Th (TypeVar i)
| IT_Times : forall Th T1 T2,
    wf_type Th T1 ->
    wf_type Th T2 ->
    wf_type Th (Times T1 T2)
| IT_Plus : forall Th T1 T2,
    wf_type Th T1 ->
    wf_type Th T2 ->
    wf_type Th (Plus T1 T2)
| IT_Arrow : forall Th T1 T2,
    wf_type Th T1 ->
    wf_type Th T2 ->
    wf_type Th (Arrow T1 T2)
| IT_Delay : forall Th T,
    wf_type Th T ->
    wf_type Th (Delay T)
| IT_Box : forall Th T,
    wf_type Th T ->
    wf_type Th (Box T)
| IT_Mu : forall Th T,
    wf_type (S Th) T ->
    wf_type Th (Mu T).

(* A closed type is well-formed in the empty context *)
Definition closed_type (T : type) : Prop := wf_type 0 T.

(* Definition of stable types *)
Inductive stable : type -> Prop :=
| S_Unit : stable Unit
| S_Nat : stable Nat
| S_Times : forall T1 T2,
    stable T1 ->
    stable T2 ->
    stable (Times T1 T2)
| S_Plus : forall T1 T2,
    stable T1 ->
    stable T2 ->
    stable (Plus T1 T2)
| S_Box : forall T,
    stable (Box T).

Inductive ctype := init | now | later.

Inductive ctx : ctype -> Set :=
| ctx_empty : ctx init
| ctx_var {ty} : ctx ty -> type -> ctx ty
| ctx_skip {ty} : ctx ty -> ctx ty
| ctx_lock : ctx init -> ctx now
| ctx_tick : ctx now -> ctx later.

Fixpoint skip_later (G : ctx later) : ctx now :=
  match G with
  | ctx_tick G' => G'
  | @ctx_var later G' _ => ctx_skip (skip_later G')
  | @ctx_skip later G' => ctx_skip (skip_later G')
  end.

Fixpoint skip_now (G : ctx now) : ctx init :=
  match G with
  | ctx_lock G' => G'
  | @ctx_var now G' _ => ctx_skip (skip_now G')
  | @ctx_skip now G' => ctx_skip (skip_now G')
  end.

Inductive ctx_lookup {ty} : ctx ty -> nat -> type -> Prop :=
| ctx_zero G T : ctx_lookup (ctx_var G T) 0 T
| ctx_succ G T T' n : ctx_lookup G n T -> ctx_lookup (ctx_var G T') (S n) T
| ctx_succ_skip G T  n : ctx_lookup G n T -> ctx_lookup (ctx_skip G ) (S n) T.

Reserved Notation "G '⊢' e '∶' T" (at level 40).
Inductive hastype : forall {ty}, ctx ty -> term -> type -> Prop :=
(* Simple λ-calculus with sums and products *)
| T_unit : forall ty (G : ctx ty),
    G ⊢ unit ∶ Unit
| T_nat : forall ty (G : ctx ty) n,
    G ⊢ natlit n ∶ Nat
| T_var : forall ty (G : ctx ty) x T,
    ctx_lookup G x T ->
    G ⊢ var x ∶ T
| T_abs : forall ty (G : ctx ty) t T1 T2,
    ty <> later ->
    ctx_var G T1 ⊢ t ∶ T2 ->
    G ⊢ abs t ∶ (Arrow T1 T2)
| T_app : forall ty (G : ctx ty) t1 t2 T1 T2,
    G ⊢ t1 ∶ (Arrow T1 T2) ->
    G ⊢ t2 ∶ T1 ->
    G ⊢ app t1 t2 ∶ T2
| T_pair : forall ty (G : ctx ty) t1 t2 T1 T2,
    G ⊢ t1 ∶ T1 ->
    G ⊢ t2 ∶ T2 ->
    G ⊢ pair t1 t2 ∶ (Times T1 T2)
| T_pr1 : forall ty (G : ctx ty) t T1 T2,
    G ⊢ t ∶ (Times T1 T2) ->
    G ⊢ pr1 t ∶ T1
| T_pr2 : forall ty (G : ctx ty) t T1 T2,
    G ⊢ t ∶ (Times T1 T2) ->
    G ⊢ pr2 t ∶ T2
| T_in1 : forall ty (G : ctx ty) t T1 T2,
    G ⊢ t ∶ T1 ->
    G ⊢ in1 t ∶ (Plus T1 T2)
| T_in2 : forall ty (G : ctx ty) t T1 T2,
    G ⊢ t ∶ T2 ->
    G ⊢ in2 t ∶ (Plus T1 T2)
| T_case : forall ty (G : ctx ty) t t1 t2 T T1 T2,
    G ⊢ t ∶ (Plus T1 T2) ->
    ctx_var G T1 ⊢ t1 ∶ T ->
    ctx_var G T2 ⊢ t2 ∶ T ->
    G ⊢ case t t1 t2 ∶ T
(* Reactive expressions *)
| T_delay : forall G T t,
    ctx_tick G ⊢ t ∶ T ->
    G  ⊢ delay t ∶ Delay T
| T_adv : forall G t T ,
    skip_later G ⊢ t ∶ Delay T ->
    G ⊢ adv t ∶ T
| T_progr : forall G t T ,
    stable T ->
    skip_later G ⊢ t ∶ T ->
    G ⊢ progr t ∶ T
| T_box : forall G t T,
    ctx_lock G ⊢ t ∶ T ->
    G ⊢ box t ∶ (Box T)
| T_unbox : forall G t T,
    skip_now G ⊢ t ∶ Box T ->
    G ⊢ unbox t ∶ T
| T_promote_now : forall G t T,
    stable T ->
    skip_now G ⊢ t ∶ T ->
    G ⊢ promote t ∶ T
| T_promote_later : forall G t T,
    stable T ->
    skip_now (skip_later G) ⊢ t ∶ T ->
    G ⊢ promote t ∶ T
(* Temporal recursive expressions *)
| T_fix : forall G t T,
    (ctx_var (ctx_lock G) (Delay T)) ⊢ t ∶ T ->
    G ⊢ fixp t ∶ Box T
| T_into : forall ty (G : ctx ty) t T,
    G ⊢ t ∶ tsubst 0 T (Delay (Mu T)) ->
    G ⊢ into t ∶ Mu T
| T_out : forall ty (G : ctx ty) t A B,
    B = tsubst 0 A (Delay (Mu A)) ->
    G ⊢ t ∶ Mu A ->
    G ⊢ out t ∶ B
 where "G '⊢' e '∶' T" := (hastype G e T) : type_scope.

Hint Constructors ctx_lookup hastype wf_type.

Hint Unfold closed_type.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj14synthconj5 : forall  (lv0 : lst) (lv1 : natural), (@eq natural (len (append lv0 (Cons lv1 lv0))) (Succ (len (append lv0 lv0)))).
Admitted.
QuickChick conj14synthconj5.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
(* Require Import rel. *)
Require Import maps.
Require Import smallstep2.
Require Import typerevise.
(* Require Import stlc.
 *)

Module Flow.
(* no polymophism of types *)
(*and no pc*)
(*no assume and where*)
(*no sealed term *)
(* no prod type | tproj : nat -> tm -> tm -> tm
  | Prodty : ty -> ty -> ty
   pair : tm -> tm -> tm
 *)

Inductive pr : Type :=
  | prin : string -> pr
  | bot: pr
  | top : pr
  | confpr : pr -> pr
  | integpr : pr -> pr
  | andpr : pr -> pr -> pr
  | orpr : pr -> pr -> pr
  | joinpr : pr -> pr -> pr
  | meetpr : pr -> pr -> pr.

Inductive ty : Type :=
  | Unit
  | Fail (f: ty)
  | Sumty : ty -> ty -> ty
  | Functy : ty -> pr -> ty -> ty
  | Says: pr -> pr -> ty -> ty.

Inductive tm : Type :=
  | var : string -> tm
  | unit : tm
  | fail : tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> pr -> tm -> tm
  | inj : nat -> tm -> tm
  | eta : pr -> pr -> tm -> tm
  | case : tm -> string-> tm -> tm -> tm
  | bind  : string -> tm -> tm -> tm
  | run   : tm -> pr -> tm
  | ret   : tm -> pr -> tm
  | compEnd : tm -> tm -> tm
  | select :  pr -> pr -> tm -> tm -> tm.

Inductive config : Type :=
  | conf : tm -> pr -> config.

Open Scope string_scope.
Definition x := "x".
Definition y := "y".
Definition z := "z".
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Inductive value : tm -> Prop :=
  | v_abs : forall x T t pc,
      value (abs x T pc t)
  | v_unit :
      value (unit)
  | v_fail :
      value fail
  | v_inj: forall n v,
      (value v) -> value (inj n v)
  | eta_val: forall v l j,
      (value v) -> value (eta l j v).
Hint Constructors value.

Reserved Notation
"'[' x ':=' s ']' t" (at level 40).
Fixpoint subst (x:string)
(s:tm) (t:tm) : tm :=
  match t with
  | var x' =>
      if beq_string x x' then s else t
  | fail => fail
  | unit =>
       unit
  | abs x' T pc t1 =>
      abs x' T pc
     (if beq_string x x' then t1 else
     ([x:=s] t1))
  | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
  | inj n t1 => inj n ([x:=s] t1)
  | eta l j t1 => eta l j ([x:=s] t1)
  | case t1 x' t2 t3 =>
      (if beq_string x x' then case t1 x' t2 t3
      else
      case ([x:=s] t1) x' ([x:=s] t2) ([x:=s] t3))
  | bind x' t1 t2 =>
        if beq_string x x' then t else
        bind x' ([x := s] t1) ([x := s] t2)
  | run t1 p => run ([x := s] t1) p
  | ret t1 p => ret ([x := s] t1) p
  | compEnd t1 t2 => compEnd ([x:=s] t1) ([x:=s] t2)
  | select p1 p2 t1 t2 =>
       select  p1 p2 ([x:=s] t1) ([x:=s] t2)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive substi (s:tm) (x:string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (var x) s
  | s_var2 : forall x', x <> x' ->
      substi s x (var x') (var x')
  | s_fail : substi s x fail fail
  | s_unit : substi s x unit unit
  | s_abs1 : forall T t1 t1' pc, t1 = abs x T pc t1' ->
              substi s x (abs x T pc t1') t1
  | s_abs2 : forall x' T t1 t1' pc, x<>x'->
    substi s x t1 t1' ->
    substi s x (abs x' T pc t1) (abs x' T pc t1')
  | s_app : forall t1 t1' t2 t2',
       substi s x t1' t1 ->  substi s x t2' t2 ->
         substi s x (app t1' t2') (app t1 t2)
  | s_inj  : forall n t1 t1',
        substi s x t1 t1' ->
        substi s x (inj n t1) (inj n t1')
  | s_eta : forall l j t1 t1',
       substi s x t1 t1' ->
       substi s x (eta l j t1) (eta l j t1')
  | s_case1 :  forall t1 t2 t3,
     substi s x (case t1 x t2 t3) (case t1 x t2 t3)
  | s_case2 :  forall x' t1 t2 t3 t1' t2' t3',
     x <> x' ->
     substi s x t1 t1' -> substi s x t2 t2'
     -> substi s x t3 t3' ->
     substi s x (case t1 x' t2 t3) (case t1' x' t2' t3')
  | s_bind1 : forall t1 t2,
       substi s x (bind x t1 t2) (bind x t1 t2)
  | s_bind2 : forall x' t1 t2 t1' t2',
      x<>x' -> substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x (bind x' t1 t2) (bind x' t1' t2')
  | s_run : forall t1 t1' p,
      substi s x t1 t1' ->
      substi s x (run t1 p) (run t1' p)
  | s_ret : forall t1 t1' p,
      substi s x t1 t1' ->
      substi s x (ret t1 p) (ret t1' p)
  | s_compEnd : forall t1 t1' t2 t2',
      substi s x t1 t1' -> substi s x t2 t2' ->
      substi s x (compEnd t1 t2) (compEnd t1' t2')
  | s_select: forall p1 p2 t1 t1' t2 t2' ,
      substi s x t1 t1' -> substi s x t2 t2' ->
      substi s x (select p1 p2 t1 t2)
                 (select p1 p2 t1' t2').

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
intros. inversion H.
Qed.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
intros. split.
- generalize dependent t'. induction t; intros.
  + simpl in H. unfold beq_string in H.
    destruct (string_dec x0 s0) in H.
   * rewrite <- e, H. apply s_var1.
   * rewrite <- H. apply s_var2. apply n.
  + subst. simpl. apply s_unit.
  + subst. simpl. apply s_fail.
  + simpl in H.  subst. apply s_app.
    apply IHt1. reflexivity.
    apply IHt2. reflexivity.
  + simpl in H. unfold beq_string in H.
    destruct (string_dec x0 s0) in H.
    subst. apply s_abs1. reflexivity.
    subst. apply s_abs2. apply n.
    apply IHt. reflexivity.
  + simpl in H. subst. apply s_inj.
    apply IHt. reflexivity.
  + simpl in H. subst. apply s_eta.
    apply IHt. reflexivity.
  + simpl in H. unfold beq_string in H.
    destruct (string_dec x0 s0) in H.
    subst. apply s_case1. subst.
    apply s_case2. apply n.
    apply IHt1. reflexivity.
    apply IHt2. reflexivity.
    apply IHt3. reflexivity.
  + simpl in H. unfold beq_string in H.
    destruct (string_dec x0 s0) in H.
    subst. apply s_bind1. subst.
    apply s_bind2. apply n.
    apply IHt1. reflexivity.
    apply IHt2. reflexivity.
  + simpl in H. subst. apply s_run.
    apply IHt. reflexivity.
  + simpl in H. subst. apply s_ret.
    apply IHt. reflexivity.
  + simpl in H. subst. apply s_compEnd.
    apply IHt1. reflexivity.
    apply IHt2. reflexivity.
  + simpl in H. subst. apply s_select.
    apply IHt1. reflexivity.
    apply IHt2. reflexivity.
- generalize dependent t'. induction t; intros.
  + inversion H. subst. simpl. unfold beq_string.
    destruct (string_dec s0 s0). reflexivity.
    apply ex_falso_quodlibet. apply n.
    reflexivity. simpl. unfold beq_string.
    destruct (string_dec x0 s0).
    apply ex_falso_quodlibet. rewrite e in H1.
    apply H1. reflexivity. reflexivity.
  + simpl. inversion H. reflexivity.
  + simpl. inversion H. reflexivity.
  + inversion H. subst. simpl.
    apply IHt1 in H2. apply IHt2 in H4.
   subst. reflexivity.
  + inversion H. subst. simpl.
   unfold beq_string.
   destruct (string_dec s0 s0).
   reflexivity.
   apply ex_falso_quodlibet. apply n.
   reflexivity. subst. apply IHt in H6.
   rewrite <- H6. simpl.
   unfold beq_string.
   destruct (string_dec x0 s0).
   apply ex_falso_quodlibet. apply H5. apply e.
   reflexivity.
  + simpl. inversion H.
    apply IHt in H3. subst. reflexivity.
  + simpl. inversion H. subst.  apply IHt in H4.
    subst. reflexivity.
  + simpl. inversion H. unfold beq_string.
    destruct (string_dec s0 s0). reflexivity.
    apply ex_falso_quodlibet. apply n.
    reflexivity. unfold beq_string.
    destruct (string_dec x0 s0). rewrite e in H4.
    apply ex_falso_quodlibet. apply H4.
    reflexivity. apply IHt1 in H6.
    apply IHt2 in H7. apply IHt3 in H8.
    subst. reflexivity.
  + simpl. inversion H. unfold beq_string.
    destruct (string_dec s0 s0). reflexivity.
    apply ex_falso_quodlibet. apply n.
    reflexivity. unfold beq_string.
    destruct (string_dec x0 s0).
    rewrite e in H3. apply ex_falso_quodlibet.
    apply H3. reflexivity.
    apply IHt1 in H5. apply IHt2 in H6.
    subst. reflexivity.
  + simpl. inversion H. apply IHt in H3.
    subst. reflexivity.
  + simpl. inversion H. apply IHt in H3.
    subst. reflexivity.
  + simpl. inversion H. apply IHt1 in H2.
    apply IHt2 in H4. subst. reflexivity.
  + simpl. inversion H. apply IHt1 in H5.
    apply IHt2 in H6. subst. reflexivity.
Qed.

Reserved Notation " t '==>' n "
(at level 50, left associativity).

Inductive floweval : tm ->tm ->Prop :=
  | E_Inj1 : forall t1 v,
        t1 ==> v ->
        inj 1 t1 ==> inj 1 v
  | E_Inj2 : forall t2 v,
        t2 ==> v ->
        inj 2 t2 ==> inj 2 v
  | E_Eta : forall l j t1 v,
       t1 ==> v ->
       eta l j t1 ==> eta l j v
  | E_App : forall x T t2 v2 t12 pc,
         t2 ==> v2 ->
         (app (abs x T pc t12) t2) ==> [x:=v2]t12
  | E_Case1 : forall t1 x v t2 t3,
       t1 ==> inj 1 v ->
      case t1 x t2 t3 ==> [x:=v] t2
  | E_Case2 : forall t1 x v t2 t3,
       t1 ==> inj 2 v ->
      case t1 x t2 t3 ==> [x:=v] t3
  | E_Bind1 : forall t1 t2 x v1 v l j,
       t1 ==> v1 ->
       value v -> v1 = eta l j v ->
       bind x t1 t2 ==> [x:=v]t2
  | E_Run : forall t1 p t1' c v,
      value v ->
      ret t1 c ==> ret v c ->
      run t1 p ==> run t1' p
  | E_Ret : forall t1 p v,
      t1 ==> v ->
      ret t1 p ==> ret v p
  | E_CompEnd1 : forall t1 t2 l1 l2 j1 j2 v1 v2 v,
      t1 ==> v1 -> t2 ==> v2 ->
      v1 = eta l1 j1 v -> v2 = eta l2 j2 v ->
      compEnd t1 t2 ==> eta (andpr l1 l2 ) (andpr j1 j2) v
  | E_Select1 : forall v t1 t2 v1 p1 p2 l j,
      t1 ==> v1 -> t2 ==> fail ->
      v1 = eta l j v  ->
      select p1 p2 t1 t2 ==> eta p1 p2 v
  | E_Select2 : forall v t1 t2 v2 p1 p2 l j,
      t1 ==> fail -> t2 ==> v2 -> v2 = eta l j v ->
      select p1 p2 t1 t2 ==> eta p1 p2 v
where "t1 '==>' t2" := (floweval t1 t2).

Reserved Notation
"t1 '-->' t2" (at level 40).
(* ,  c1 at level 0,
t2 at level 40, c2 at level 12).
 *)
Inductive flowstep : config -> config ->Prop :=
  | ST_Inj1 : forall t1 t1' c,
        conf t1 c  --> conf t1'  c ->
        conf (inj 1 t1)  c --> conf (inj 1 t1')  c
  | ST_Inj2 : forall t2 t2' c,
        conf t2  c --> conf t2'  c ->
        conf (inj 2 t2)  c --> conf (inj 2 t2')  c
  | ST_Eta : forall l j t1 t1' c,
       conf t1 c --> conf t1' c ->
       conf (eta l j t1) c --> conf (eta l j t1') c
  | ST_AppAbs : forall x T t12 v2 c pc,
         value v2 ->
         conf (app (abs x T pc t12) v2) c --> conf ([x := v2]t12)  c
  | ST_App1 : forall t1 t1' t2 c,
         conf t1 c --> conf t1' c ->
         conf (app t1 t2) c--> conf (app t1' t2) c
  | ST_App2 : forall v1 t2 t2' c,
         value v1 ->
         conf t2 c --> conf t2' c ->
         conf (app v1 t2) c --> conf (app v1 t2') c
  | ST_Case1 : forall t1 x v t2 t3 c,
       (value v) -> t1 = inj 1 v ->
      conf (case t1 x t2 t3) c --> conf ([x:=v] t2) c
  | ST_Case2 : forall t1 x v t2 t3 c,
       (value v) -> t1 = inj 2 v ->
      conf (case t1 x t2 t3) c --> conf ([x:=v] t3) c
  | ST_Case : forall t1 t1' x t2 t3 c,
      conf t1 c--> conf t1' c ->
      conf (case t1 x t2 t3) c --> conf (case t1' x t2 t3) c
  | ST_Bind1 : forall t1 t1' t2 x c,
       conf t1 c --> conf t1' c ->
       conf (bind x t1 t2) c --> conf (bind x t1' t2) c
  | ST_Bind2 : forall t1 t2 v x l j c,
       value t1 -> t1 = eta l j v ->
       conf (bind x t1 t2) c --> conf ([x:=v] t2) c
  | ST_Run1 : forall t1 p c,
      conf (run t1 p) c --> conf (ret t1 c) p
  (* | ST_Run2 : forall p c v,
      value v ->
      conf (run v p) c --> conf v c *)
  | ST_Ret1 : forall t1 p t1' c,
      conf t1 p --> conf t1' p ->
      conf (ret t1 c) p --> conf (ret t1' c) p
  | ST_Ret2 : forall p v c,
      value v ->
      conf (ret v c) p --> conf v c
  | ST_CompEnd1 : forall t1 t1' t2 c,
      conf t1 c --> conf t1' c ->
      conf (compEnd t1 t2) c --> conf (compEnd t1' t2) c
  | ST_CompEnd2 : forall v t2 t2' c,
      value v -> conf t2 c --> conf t2' c ->
      conf (compEnd v t2) c --> conf (compEnd v t2') c
  | ST_Select1 : forall t1 t1' t2 p1 p2 c,
      conf t1 c --> conf t1' c ->
      conf (select p1 p2 t1 t2) c -->
      conf (select p1 p2 t1' t2) c
  | ST_Select2 : forall v t2 t2' p1 p2 c,
      value v -> conf t2 c --> conf t2' c ->
      conf (select p1 p2 v t2) c
      --> conf (select p1 p2 v t2') c
where "t1 '-->' t2 " := (flowstep t1 t2).

Hint Constructors flowstep.
Notation multistep := (multi flowstep).
Notation "t1 -->*' t2" :=
(multistep t1 t2) (at level 110).

Lemma val_nostep : forall v c,
value v -> ~ exists t, conf v c --> conf t c.
Proof.
intros. unfold not.
intros. induction H.
 - inversion H0; subst. inversion H.
- inversion H0; subst; inversion H.
- inversion H0; subst. inversion H.
- apply IHvalue. inversion H0. inversion H1.
subst. exists t1'. apply H3. subst. exists t2'.
apply H3.
- apply IHvalue. inversion H0. inversion H1.
subst. exists t1'. apply H3.
Qed.

Lemma inj_same_val:  forall n v1 v2,
inj n v1 = inj n v2 -> v1 = v2.
Proof.
intros. inversion H. reflexivity.
Qed.

(* Definition deterministic {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.
 *)
Lemma same_term: forall t t' c,
conf t c = conf t' c -> t = t'.
Proof.
intros.
inversion H. reflexivity.
Qed.

Theorem step_deterministic:
  deterministic flowstep.
Proof.
unfold deterministic.
intros. generalize dependent y2.
induction H; intros.
- inversion H0. subst.
apply IHflowstep in H4.
apply same_term in H4. subst. reflexivity.
- inversion H0. subst.
  apply IHflowstep in H4. subst.
apply same_term in H4. subst. reflexivity.
- inversion H0. subst. apply IHflowstep in H6.
apply same_term in H6. subst. reflexivity.
- inversion H0.
  + reflexivity.
  + subst. inversion H5.
  + subst.
 assert (G: ~ exists t, conf v2 c --> conf t c).
      { apply val_nostep. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t2'. apply H6.
- inversion H0.
  + subst. inversion H.
  + subst. apply IHflowstep in H5.
  apply same_term in H5. subst. reflexivity.
  + subst. assert (G: ~ exists t, conf t1 c --> conf t c).
      { apply val_nostep. apply H5. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
- inversion H1.
   + subst. assert (G: ~ exists t, conf t2 c --> conf t c).
      { apply val_nostep. apply H6. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t2'. apply H0.
  + subst. assert (G: ~ exists t, conf v1 c --> conf t c).
      { apply val_nostep. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H6.
  + subst. apply IHflowstep in H7.
    apply same_term in H7. subst. reflexivity.
- inversion H1.
   + subst. apply inj_same_val in H9.
     rewrite H9. reflexivity.
   + subst. inversion H9.
   + subst.
   assert (G: ~ exists t, conf (inj 1 v) c --> conf t c).
      { apply val_nostep. apply v_inj. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H8.
- inversion H1.
  + subst. inversion H9.
  + subst. apply inj_same_val in H9. rewrite H9.
    reflexivity.
  + subst. assert (G: ~ exists t, conf (inj 2 v) c --> conf t c).
      { apply val_nostep. apply v_inj. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H8.
- inversion H0.
  + subst.
    assert (G: ~ exists t, conf (inj 1 v) c --> conf t c).
      { apply val_nostep. apply v_inj. apply H7. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
  + subst. assert (G: ~ exists t, conf (inj 2 v) c --> conf t c).
      { apply val_nostep. apply v_inj. apply H7. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
  + subst. apply IHflowstep in H7.
apply same_term in H7. subst. reflexivity.
- inversion H0.
  + subst. apply IHflowstep in H6. apply same_term in H6.
    subst. reflexivity.
  + subst. assert (G: ~ exists t, conf (eta l j v) c --> conf t c).
      { apply val_nostep. apply H6. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
- inversion H1.
  + subst.
  assert (G: ~ exists t, conf (eta l j v) c --> conf t c).
      { apply val_nostep. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H7.
  + subst. inversion H8. reflexivity.
- inversion H0.
  + subst. reflexivity.
- inversion H0.
  + subst. apply IHflowstep in H5.
  apply same_term in H5. subst. reflexivity.
  + subst. assert (G: ~ exists t, conf t1 p --> conf t p).
      { apply val_nostep. apply H5. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
- inversion H0.
  + subst. assert (G: ~ exists t, conf v p --> conf t p).
      { apply val_nostep. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H5.
  + reflexivity.
- inversion H0.
  + subst. apply IHflowstep in H5. apply same_term in H5.
    subst. reflexivity.
  + subst. assert (G: ~ exists t, conf t1 c --> conf t c).
      { apply val_nostep. apply H5. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
- inversion H1.
  + subst. assert (G: ~ exists t, conf v c --> conf t c).
      { apply val_nostep. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H6.
   + subst. apply IHflowstep in H7. apply same_term in H7. subst.
     reflexivity.
- inversion H0.
  + subst. apply IHflowstep in H7. apply same_term in H7.
    subst. reflexivity.
  + subst. assert (G: ~ exists t, conf t1 c --> conf t c).
      { apply val_nostep. apply H7. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H.
- inversion H1.
  + subst. assert (G: ~ exists t, conf v c --> conf t c).
      { apply val_nostep. apply H. }
     unfold not in G.
     apply ex_falso_quodlibet.
     apply G. exists t1'. apply H8.
   + subst. apply IHflowstep in H9. apply same_term in H9.
     subst. reflexivity.
Qed.

Inductive pt : Type :=
  | prpr : pr -> pt
  | tyty : ty -> pt.

Fixpoint J (t: ty) : pr :=
  match t with
   | Unit => bot
   | Fail f => J f
   | Sumty  t1 t2 => joinpr (J t1) (J t2)
   | Functy t1 pc t2 => joinpr (J t1) (J t2)
   | Says l j t => j
  end.

Definition flowsto_map (A:Type) := pr -> A.
Definition flow_empty {A:Type} (v : A) : flowsto_map A :=
  (fun _ => v).
Definition partial_flow_map (A:Type) :=
flowsto_map (option A).
Definition fempty {A:Type} : partial_flow_map A :=
  flow_empty None.

(* Definition delI := partial_flow_map pt.
Definition delC := partial_flow_map pt.

Definition del := pair delI delC.
*)
Definition del := partial_flow_map pr.
(* Reserved Notation "D '|-' p1 'F' p2"  (at level 40). *)

Inductive flowstoI : del -> pr -> pr -> Prop:=
| flowsI : forall D p1 p2,
    D (integpr p1) = Some (integpr p2) ->
    flowstoI D p1 p2.

Inductive flowstoC : del -> pr -> pr -> Prop:=
| flowsC : forall D p1 p2,
    D (confpr p1) = Some (confpr p2) ->
    flowstoC D p1 p2.

Inductive flowsto : del -> pr -> pr -> Prop :=
  | flows : forall D p1 p2,
    flowstoI D p1 p2 ->
    flowstoC D p1 p2 ->
    flowsto D p1 p2.

Inductive actsfor : del -> pr -> pr -> Prop :=
 | actsf : forall D p1 p2,
    flowstoC D p2 p1 ->
    flowstoI D  p1 p2 -> actsfor D p1 p2.

Definition pc := pr.

Fixpoint L (t: ty) : pr :=
  match t with
   | Unit => bot
   | Fail f => L f
   | Sumty  t1 t2 => joinpr (L t1) (L t2)
   | Functy t1 pc t2 => joinpr (L t1) (L t2)
   | Says l j t => l
  end.

Definition context := partial_map ty.

(* Reserved Notation "G '|-' t 'in' T" (at level 40). *)
Inductive has_type :
context -> del -> pr -> pr -> tm -> ty -> Prop :=
  | T_Var : forall G D c pc x T,
      G x = Some T ->  actsfor D c pc ->
      has_type G D c pc (var x) T
| T_Unit : forall G D c pc,
       actsfor D c pc ->
       (has_type G D c pc unit Unit)
  | T_Fail : forall G D f c pc,
        actsfor D c pc ->
       (has_type G D c pc fail (Fail f))
| T_Abs : forall G D c c' pc pc' x T11 T12 t12,
 (has_type (update G x T11) D c' pc' t12 T12) ->
  actsfor D c pc ->
 ( has_type G D c pc (abs x T11 pc' t12)
(Functy T11 pc' T12))
  | T_Inj1 : forall G D c pc T1 T2 t1,
     (has_type G D c pc t1 T1) ->
     (* (has_type G D c pc t1 T2) ) -> *)
      actsfor D c pc ->
     (has_type G D c pc (inj 1 t1) (Sumty T1 T2))
  | T_Inj2 : forall G D c pc T1 T2 t1,
     (has_type G D c pc t1 T2) ->
     (* (has_type G D c pc t1 T2) ) -> *)
      actsfor D c pc ->
     (has_type G D c pc (inj 2 t1) (Sumty T1 T2))
  | T_App : forall T11 T12 G D c pc pc' t1 t2,
     (has_type G D c pc t1 (Functy T11 pc' T12)) ->
     (has_type G D c pc t2 T11) ->
     actsfor D c pc -> flowsto D pc pc' ->
     (has_type G D c pc (app t1 t2) T12)
  | T_Eta : forall G D c pc l j t1 T,
     (has_type G D c pc t1 T) -> (flowsto D (J T) l) ->
     actsfor D c pc ->
     (has_type G D c pc (eta l j t1) (Says l j T))
  | T_Case : forall t1 x t2 t3 T T1 T2 G D c pc,
       (has_type G D c pc t1 (Sumty T1 T2)) ->
       (has_type (update G x T1) D c pc t2 T) ->
       (has_type (update G x T2) D c pc t3 T) ->
        actsfor D c pc ->
       (has_type G D c pc (case t1 x t2 t3) T)
  | T_Bind : forall x t1 t2 c pc l j  T1 T2 G D,
      (has_type G D c pc t1 (Says l j T1)) ->
      (has_type (update G x T1) D c (joinpr (joinpr l j) pc) t2 T2) ->
       flowsto D j (J T2) ->
       flowsto D l (L T2)  ->
       actsfor D c pc ->
      (has_type G D c pc (bind x t1 t2) T2)
  (* | T_Run : forall G D c pc pcr t1 p T1,
     (has_type G D p pcr t1 T1) ->
     actsfor D c pc -> flowsto D pc pcr ->
    this breaks ret
     (has_type G D c pc (run t1 p) T1) *)
   (* | T_Run : forall G D c pc t1 p T1,
    (has_type G D p (joinpr pc (integpr c)) t1 T1) ->
     actsfor D c pc ->
    (has_type G D c pc (run t1 p) T1)
this breaks ret as well*)
  | T_Run : forall G D c c' pc pc' t1 T1,
    (has_type G D c' pc' (ret t1 c) T1) ->
     actsfor D c pc -> flowsto D pc pc' ->
    (has_type G D c pc (run t1 c') T1)
  | T_Ret : forall G D c c' pc t1 T1,
     (has_type G D c' pc t1 T1) ->
    (*  actsfor D p pc -> *)
     (has_type G D c' pc (ret t1 c) T1)
  | T_CompEnd : forall G D c pc t1 t2 T j1 j2 l1 l2 l j ,
     has_type G D c pc t1 (Says l1 j1 T) ->
     has_type G D c pc t2 (Says l2 j2 T)->
     actsfor D c pc ->
     l = andpr l1 l2 ->
     j = andpr j1 j2 ->
     has_type G D c pc (compEnd t1 t2) (Says l j T)
  | T_Select : forall G D c pc t1 t2
p1 p2 T j1 j2 l1 l2 ,
     has_type G D c pc t1 (Says l1 j1 T) ->
     has_type G D c pc t2 (Says l2 j2 T) ->
     actsfor D c pc ->
     p1 = orpr l1 l2 ->
     p2 = joinpr j1 j2 ->
     has_type G D c pc
(select p1 p2 t1 t2) (Says p1 p2 T).

Hint Constructors has_type.

Lemma canonical_forms_unit : forall c pc t,
  has_type empty fempty c pc t Unit ->
  value t -> t = unit.
Proof.
intros. inversion H0;subst.
- inversion H.
- reflexivity.
- inversion H.
- inversion H.
- inversion H.
Qed.

Lemma canonical_forms_fail : forall t c pc x,
  has_type empty fempty c pc t (Fail x) ->
  value t -> t = fail.
Proof.
intros. inversion H0;subst.
- inversion H.
- inversion H.
- reflexivity.
- inversion H.
- inversion H.
Qed.

Lemma canonical_forms_inj : forall t c pc T1 T2,
  has_type empty fempty c pc t (Sumty T1 T2) ->
  value t -> exists n v, (value v /\ t = inj n v).
Proof.
intros. inversion H0;subst.
- inversion H.
- inversion H.
- inversion H.
- exists n, v. split. apply H1. reflexivity.
- inversion H.
Qed.

Lemma canonical_forms_eta : forall t c pc T l j,
  has_type empty fempty c pc t (Says l j T) ->
  value t -> exists v, (value v /\ t = eta l j v).
Proof.
intros. inversion H0;subst.
- inversion H.
- inversion H.
- inversion H.
- inversion H.
- exists v. split. apply H1.
inversion H. reflexivity.
Qed.

Lemma canonical_forms_fun : forall t c pc pc' T1 T2,
  has_type empty fempty c pc t (Functy T1 pc' T2) ->
  value t ->
  exists x u, t = abs x T1 pc' u.
Proof.
intros. inversion H0; subst.
- inversion H. subst. exists x0,t0.
reflexivity.
- inversion H.
- inversion H.
- inversion H.
- inversion H.
Qed.

Theorem values_host : forall v G D c c' pc T,
  value v ->
  has_type G D c pc v T ->
  actsfor D c' pc ->
  has_type G D c' pc v T.
Proof.
intros. generalize dependent T.
induction H.
- intros. inversion H0. subst.
apply T_Abs with c'0.
apply H10. apply H1.
- intros. inversion H0. apply T_Unit.
apply H1.
- intros. inversion H0. apply T_Fail.
apply H1.
- intros. inversion H0. subst.
apply T_Inj1.
apply IHvalue. apply H8. apply H1.
apply T_Inj2.
apply IHvalue. apply H8. apply H1.
- intros. inversion H0. apply T_Eta.
subst. apply IHvalue. apply H9.
apply H11. apply H1.
Qed.

Theorem values_pc : forall v G D c c' pc pc' T,
  value v ->
  has_type G D c pc v T -> actsfor D c' pc' ->
  has_type G D c' pc' v T.
Proof.
intros. generalize dependent T.
induction H.
- intros. inversion H0. subst.
apply T_Abs with c'0. apply H10.
apply H1.
- intros. inversion H0. apply T_Unit.
apply H1.
- intros. inversion H0. apply T_Fail.
apply H1.
- intros. inversion H0. subst.
apply T_Inj1. apply IHvalue.
apply H8. apply H1. subst.
apply T_Inj2. apply IHvalue.
apply H8. apply H1.
- intros. inversion H0. subst.
apply T_Eta. apply IHvalue.
apply H9. apply H11.
apply H1.
Qed.

Lemma transitive_flowsto :
forall D a b c,
flowsto D a b -> flowsto D b c ->
flowsto D a c.
Proof.
intros.
Admitted.

Lemma ref_flowstof :
forall D a b c,
flowsto D a c -> flowsto D b c ->
flowsto D a b.
Proof.
intros.
Admitted.

Lemma ref_flowsto_joinf :
forall D a b c ,
flowsto D (joinpr b c) (joinpr a c)
-> flowsto D b a.
Proof.
intros.
Admitted.

Lemma ref_flowsto_joinr :
forall D a b c ,
flowsto D b a ->
flowsto D (joinpr b c) (joinpr a c).
Proof.
intros.
Admitted.

Lemma ref_flowsto : forall D a,
flowsto D a a.
Proof.
Admitted.

Lemma clearance : forall G D c pc t T,
has_type G D c pc t T -> actsfor D c pc.
Proof.
intros. induction H.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
Qed.

Lemma actsfor_low : forall c pc pc' lj D,
actsfor D c (joinpr lj pc) -> flowsto D pc' pc
-> actsfor D c pc' -> actsfor D c (joinpr lj pc').
Proof.
Admitted.

Lemma flowsto_join : forall a b c D,
flowsto D a b ->
flowsto D (joinpr c a) (joinpr c b).
Proof.
Admitted.
Lemma actsfor_joinf : forall a b c D,
actsfor D c a -> actsfor D c b ->
actsfor D c (joinpr a b).
Proof.
Admitted.
Lemma actsfor_joinr : forall a b c D,
actsfor D c (joinpr a b) ->
actsfor D c a /\ actsfor D c b.
Proof.
Admitted.
Lemma unfold_flowsto : forall a b D,
flowsto D a b ->
(flowstoI D a b) /\
(flowstoC D a b).
Proof.
Admitted.
Lemma unfold_actsfor : forall a b D,
actsfor D a b ->
(flowstoI D a b) /\
(flowstoC D b a).
Proof.
Admitted.

Lemma fold_actsfor : forall a b D,
(flowstoI D a b) ->
(flowstoC D b a) -> actsfor D a b.
Proof.
Admitted.
Lemma simpl_flowstoI2 : forall a b D,
(flowstoI D a (integpr b)) ->
(flowstoI D a b).
Proof.
intros.
Admitted.
Lemma trans_flowstoI : forall a b c D,
flowstoI D a b -> flowstoI D b c ->
flowstoI D a c.
Proof.
Admitted.
Lemma trans_flowstoC : forall a b c D,
flowstoC D a b -> flowstoC D b c ->
flowstoC D a c.
Proof.
Admitted.
Theorem pc_reduction :
forall t G D c pc pc' T,
  has_type G D c pc t T -> flowsto D pc' pc ->
  actsfor D c pc' ->
  has_type G D c pc' t T.
Proof.
intros.
generalize dependent pc'.
induction H.
- intros. apply T_Var. apply H.
apply H2.
- intros. apply T_Unit. apply H1.
- intros. apply T_Fail. apply H1.
- intros.  apply T_Abs with c'.
apply H. apply H2.
- intros. apply T_Inj1.
apply IHhas_type.
apply H1. apply H2. apply H2.
- intros. apply T_Inj2.
apply IHhas_type.
apply H1. apply H2. apply H2.
- intros. apply T_App with T11 pc'.
apply IHhas_type1. apply H3.
apply H4. apply IHhas_type2.
apply H3. apply H4. apply H4.
apply transitive_flowsto with pc0.
apply H3. apply H2.
- intros. apply T_Eta.
apply IHhas_type.
apply H2. apply H3. apply H0. apply H3.
- intros. apply T_Case with T1 T2.
apply IHhas_type1. apply H3. apply H4.
apply IHhas_type2. apply H3. apply H4.
apply IHhas_type3. apply H3. apply H4.
apply H4.
- intros.
assert (E: actsfor D c (joinpr (joinpr l j) pc0)).
{ apply clearance in H0. apply H0. }
 apply T_Bind with l j T1.
apply IHhas_type1. apply H4. apply H5.
eapply IHhas_type2. eapply flowsto_join.
apply H4.
apply actsfor_joinr in E.
destruct E as [E1 E2].
apply actsfor_joinf. apply E1. apply H5.
apply H1. apply H2. apply H5.
- intros. apply T_Run with pc'.
apply H. apply H3.
apply transitive_flowsto with pc0.
apply H2. apply H1.
- intros. apply T_Ret. apply IHhas_type.
apply H0. apply H1.
- intros.
apply T_CompEnd with j1 j2 l1 l2.
apply IHhas_type1. apply H4. apply H5.
apply IHhas_type2. apply H4. apply H5.
apply H5. apply H2. apply H3.
- intros.
apply T_Select with j1 j2 l1 l2.
apply IHhas_type1. apply H4. apply H5.
apply IHhas_type2. apply H4. apply H5.
apply H5. apply H2. apply H3.
Qed.

Lemma two_ty_val : forall v T T' G D c pc,
has_type G D c pc v T' ->
~ (has_type G D c pc v T).
Proof.
Admitted.
Lemma eq_neq : forall x s :string,
 x = s -> ~(x <> s).
Proof.
intros.
Admitted.

Theorem var_sub : forall t v x c pc T T' G D,
has_type G D c pc t T  ->
has_type G D c pc (var x) T ->
has_type G D c pc v T' ->
has_type G D c pc ([x:=v] t) T.
Proof.
intros. induction t.
- simpl. unfold beq_string.
 destruct (string_dec x0 s).
apply ex_falso_quodlibet.
apply eq_neq. apply H1.

(* values are typable at any pc
values are typable at any host *)
(* pc reduction *)
variable sunstitution
type preservation
robust asumption (may be not req now)
robust protection (may be not required now)
Pi extension (may be not required now)
type substitution (not required now)
Theorem preservation : forall t t' G D c pc T,
  has_type G D c pc t T ->
  conf t c --> conf t' c ->
  has_type G D c pc t' T.
Proof.

(* big_step  *)
(* val_nostep     *)
(* Types (not complete yet) *)
preservation
progress
l protects t proof


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

From Coq Require Import String Ensembles Setoid.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.Classical_Prop.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Coq.Classes Require Import Morphisms_Prop.
From Coq.Unicode Require Import Utf8.
From Coq.micromega Require Import Lia.

From MatchingLogic Require Import Logic.
From MatchingLogic.Theories Require Import Definedness_Syntax Definedness_ProofSystem.
From MatchingLogic.Utils Require Import stdpp_ext.

Require Import MatchingLogic.wftactics.

From stdpp Require Import base fin_sets sets propset proof_irrel option list.

Import extralibrary.

Import MatchingLogic.Logic.Notations.
Import MatchingLogic.Theories.Definedness_Syntax.Notations.

Set Default Proof Mode "Classic".

From MatchingLogic Require Import
  Theories.DeductionTheorem
  Theories.Sorts_Syntax
  FOEquality_ProofSystem
  Sorts_ProofSystem
.

Import MatchingLogic.Theories.Sorts_Syntax.Notations.

Open Scope ml_scope.
Open Scope string_scope.
Open Scope list_scope.

Section nat_syntax.

  Context {Σ : Signature}.

  Inductive Symbols := sNat | sZero | sSucc.

  Class Syntax :=
    { inj : Symbols -> symbols;
      imported_sorts :> Sorts_Syntax.Syntax;
    }.
  Context {self : Syntax}.

  Definition Nat := patt_sym (inj sNat).
  Definition Zero := patt_sym (inj sZero).
  Definition Succ := patt_sym (inj sSucc).

End nat_syntax.

Section nat.
  Context
    {Σ : Signature}
    {syntax : Syntax}
  .

  Inductive AxiomName :=
  | AxFun1
  | AxFun2
  | AxNoConfusion1
  | AxNoConfusion2
  | AxInductiveDomain.

  Definition axiom (name : AxiomName) : Pattern :=
    match name with
    | AxFun1 => ex Nat , Zero =ml b0
    | AxFun2 => all Nat, ex Nat, Succ $ b1 =ml b0
    | AxNoConfusion1 => all Nat, !(Zero =ml Succ $ b0)
    | AxNoConfusion2 => all Nat, all Nat, (Succ $ b1 =ml Succ $ b0 ---> b1 =ml b0)
    | AxInductiveDomain => 〚 Nat 〛 =ml mu , Zero or Succ $ B0
    end.

  Program Definition named_axioms : NamedAxioms :=
    {|
      NAName := AxiomName;
      NAAxiom := axiom;
    |}.
  Next Obligation.
    destruct name; simpl; wf_auto2.
  Qed.

  Definition theory := Definedness_Syntax.theory ∪ theory_of_NamedAxioms named_axioms.

End nat.