(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    FullAtomicJl:
        Decidable, Tag-Based (Atomically) Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * FullAtomicJl: Main Propositions *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.FullAtomicJl.BaseDefs.
Require Import Mechanization.FullAtomicJl.BaseProps.
Require Import Mechanization.FullAtomicJl.MatchProps.
Require Import Mechanization.FullAtomicJl.SemSubProps.
Require Import Mechanization.FullAtomicJl.DeclSubProps.
Require Import Mechanization.FullAtomicJl.RedSubProps.

Require Import Mechanization.Aux.BasicTactics.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Open  Scope btjm_scope.

(* ################################################################# *)
(** ** On ValueType *)
(* ################################################################# *)

(** [value_type t] is decidable *)
Theorem value_type__decidable : forall (t : ty),
    Decidable.decidable (value_type t).
Proof.
  apply value_type__dcdbl.
Qed.

(* ################################################################# *)
(** ** On Matching *)
(* ################################################################# *)

(** Any value type matches itself. *)
Lemma match_valty__reflexive : forall (v : ty),
    value_type v ->
    |- v <$ v.
Proof.
  apply match_valty__rflxv.
Qed.

(** A value type matches only an eqivalent value type. *)
Lemma valty_match_valty__equal' : forall (v1 v2 : ty),
    |- v1 <$ v2 ->
    value_type v2 ->
    v1 = v2.
Proof.
  apply valty_match_valty__equal.
Qed.

(** [v <$ t] is decidable. *)
Theorem match_ty__decidable : forall (v t : ty),
    Decidable.decidable (|- v <$ t).
Proof.
  apply match_ty__dcdbl.
Qed.

(* ################################################################# *)
(** ** On Reductive Subtyping *)
(* ################################################################# *)

Close Scope btj_scope.
Open  Scope btjr_scope.

(* ================================================================= *)
(** *** Relation to Matching *)
(* ================================================================= *)

Theorem match_ty__sub_r_sound' : forall (v t : ty),
    valid v ->
    |- v <$ t ->
    |- v << t.
Proof.
  apply match_ty__sub_r_sound.
Qed.

Theorem match_valty__sub_r_complete' : forall (v t : ty),
    valid v -> valid t ->
    |- v << t ->
    value_type v ->
    |- v <$ t.
Proof.
  apply match_valty__sub_r_complete.
Qed.

(* ================================================================= *)
(** *** Correctness with respect to Declarative Subtyping *)
(* ================================================================= *)

(* ----------------------------------------------------------------- *)
(** **** Soundness *)
(* ----------------------------------------------------------------- *)

(** Reductive subtyping implies declarative. *)
(* DEP: mk_nf__sub_d2 *)
Theorem sub_r__sound : forall (t1 t2 : ty),
    valid t1 ->
    |- t1 << t2 ->
    (|- t1 << t2)%btj.
Proof.
  intros t1 t2 HTY1 Hsub; induction Hsub;
    try solve [
          constructor
        | apply SD_Trans with treal; constructor ].
  - (* Pair *)
    inversion HTY1; subst.
    constructor; tauto.
  - (* UnionL *)
    inversion HTY1; subst.
    constructor; tauto.
  - (* UnionR1 *)
    apply union_right_1; tauto.
  - (* UnionR2 *)
    apply union_right_2; tauto.
  - (* NF *)
    apply SD_Trans with (MkNF(t)).
    apply mk_nf__sub_d2.
    assumption. apply IHHsub.
    apply mk_nf__preserves_valid; assumption.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Completeness *)
(* ----------------------------------------------------------------- *)

(** Declarative subtyping implies reductive. *)
(* DEP: sub_r__reflexive, sub_r__transitive *)
Theorem sub_r__complete : forall (t1 t2 : ty),
    valid t1 -> valid t2 ->
    (|- t1 << t2)%btj ->
    |- t1 << t2.
Proof.
  intros t1 t2 HTY1 HTY2 Hsub; induction Hsub;
    try solve [constructor].
  - (* Refl *)
    apply sub_r__reflexive; assumption.
  - (* Trans *)
    pose proof (sub_d__valid1 _ _ Hsub2) as HTY3.
    apply sub_r__transitive with t2; tauto.
  - (* Pair *)
    inversion HTY1; inversion HTY2; subst.
    constructor; tauto.
  - (* UnionL *)
    inversion HTY1; subst.
    constructor; tauto.
  - (* UnionR1 *)
    inversion HTY2; subst.
    apply SR_UnionR1; apply sub_r__reflexive; tauto.
  - (* UnionR2 *)
    inversion HTY2; subst.
    apply SR_UnionR2; apply sub_r__reflexive; tauto.
  - (* Distr1 *)
    inversion HTY1; inversion HTY2; subst.
    inversion H1; inversion H5; inversion H6; subst.
    apply mk_nf_sub_r__sub_r; try solve [constructor; assumption].
    apply mk_nf__distr11; assumption.
  - (* Distr2 *)
    inversion HTY1; inversion HTY2; subst.
    inversion H2; inversion H5; inversion H6; subst.
    apply mk_nf_sub_r__sub_r; try solve [constructor; assumption].
    apply mk_nf__distr21; tauto.
Qed.

(* ================================================================= *)
(** *** Decidability *)
(* ================================================================= *)

(** [t1 << t2] is decidable. *)
(* DEP: mk_nf__in_nf, nf_sub_r__decidable *)
Theorem sub_r__decidable : forall (t1 t2 : ty),
    valid t1 -> valid t2 ->
    Decidable.decidable (|- t1 << t2).
Proof.
  intros t1 t2 HTY1 HTY2.
  assert (Hnf: InNF(MkNF(t1))) by (apply mk_nf__in_nf; assumption).
  pose proof (nf_sub_r__decidable _ t2 Hnf) as Hdec.
  destruct Hdec as [Hdec | Hdec]; try assumption.
  - left; apply SR_NormalForm; assumption.
  - right; intros Hcontra.
    apply sub_r__mk_nf_sub_r1 in Hcontra.
    contradiction. assumption.
Qed.

(*
Eval compute in sub_r__decidable tint (TUnion tint tflt).
*)

(* ################################################################# *)
(** ** On Declarative Subtyping *)
(* ################################################################# *)

Close Scope btjr_scope.
Open  Scope btj_scope.

(* ================================================================= *)
(** *** Relation to Matching *)
(* ================================================================= *)

Theorem match_ty__sub_d_sound' : forall (v t : ty),
    valid v ->
    |- v <$ t ->
    |- v << t.
Proof.
  apply match_ty__sub_d_sound.
Qed.

Theorem match_valty__sub_d_complete' : forall (v t : ty),
    |- v << t ->
    value_type v ->
    |- v <$ t.
Proof.
  apply match_valty__sub_d_complete.
Qed.

(* ================================================================= *)
(** *** Semantic Soundness and Completeness *)
(* ================================================================= *)

(* ----------------------------------------------------------------- *)
(** **** Soundness *)
(* ----------------------------------------------------------------- *)

(** Declarative subtyping implies semantic:
    [t1 << t2  ->  [t1] <= [t2]]. *)
(* DEP: match_valty__transitive_on_sub_d *)
Theorem sub_d__semantic_sound : forall (t1 t2 : ty),
    |- t1 << t2 ->
    ||- [t1] <= [t2].
Proof.
  intros t1 t2 Hsub. unfold sem_sub.
  apply match_valty__transitive_on_sub_d; assumption.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Completeness *)
(* ----------------------------------------------------------------- *)

(** Semantic subtyping implies declarative:
    [[t1] <= [t2]  ->  t1 << t2]. *)
(* DEP: nf_exists, nf_sem_sub__sub_d,
        match_valty__sub_d_complete, match_ty__sub_d_sound *)
Theorem sub_d__semantic_complete : forall (t1 t2 : ty),
    valid t1 -> valid t2 ->
    ||- [t1] <= [t2] ->
    |- t1 << t2.
Proof.
  intros t1 t2 HTY1 HTY2 Hsem.
  (* exists nt1 = NF(t1) *)
  pose proof (nf_exists t1 HTY1) as [tn1 [Hnf1 [Hsub1 Hsub2]]].
  (* t1 << tn1 << t2 *)
  apply SD_Trans with tn1; try assumption.
  apply nf_sem_sub__sub_d; try assumption.
  (* [tn1] <= [t2] *)
  unfold sem_sub in *. intros v Hv Hm1.
  apply Hsem. assumption.
  apply match_valty__transitive_on_sub_d with tn1; assumption.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Imp.
Require Import Maps.

Definition Assertion := state -> Prop.

Module ExAssertions.

Definition as1 : Assertion := fun st => st X = 3.

Definition as2 : Assertion := fun st => st X <= st Y.

Definition as3 : Assertion := fun st =>
  st X = 3 \/ st X <= st Y.

Definition as4 : Assertion := fun st =>
  st Z * st Z <= st X /\
  ~ (((S (st Z)) * (S (st Z))) <= st X).

Definition as5 : Assertion := fun st => True.
Definition as6 : Assertion := fun st => False.

End ExAssertions.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.

Open Scope hoare_spec_scope.

Notation "P <<->> Q" := (P ->> Q /\ Q ->> P)
                        (at level 80) : hoare_spec_scope.

(* Hoare Triples *)

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
    c / st \\ st' ->
    P st ->
    Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{ P }} c {{ Q }}.
Proof.
  intros. unfold hoare_triple. intros.
  apply H.
Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~(P st)) ->
  {{ P }} c {{ Q }}.
Proof.
  unfold hoare_triple. intros.
  unfold not in H. apply H in H1.
  intuition.
Qed.

(* Proof Rules *)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{ Q [X |-> a] }} (X ::= a) {{ Q }}.
Proof.
  unfold assn_sub. unfold hoare_triple.
  intros. inversion H. subst.
  apply H0.
Qed.

(* strengthening the precondition, or
   weakening the postcondition also produce a
   valid Hoare triple *)

Theorem hoare_consequence_pre : forall P P' Q c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple. unfold assert_implies.
  intros. eapply H.
  - apply H1.
  - apply H0. apply H2.
Qed.

Theorem hoare_consequence_post : forall P Q Q' c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple. unfold  assert_implies.
  intros. apply H0. eapply H.
  - apply H1.
  - apply H2.
Qed.

Example hoare_asgn_example1 :
  {{ fun st => True }}
  (X ::= (ANum 1))
  {{ fun st => st X = 1 }}.
Proof.
  unfold hoare_triple.
  intros.
  inversion H. subst.
  unfold t_update. simpl.
  reflexivity.
Qed.

Theorem hoare_consequence : forall P P' Q Q' c,
  {{P'}} c {{Q'}} ->
  P ->> P' -> Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros. eapply hoare_consequence_pre.
  - eapply hoare_consequence_post.
    + apply H.
    + apply H1.
  - apply H0.
Qed.

(* Skip *)

Theorem hoare_skip : forall P,
  {{P}} SKIP {{P}}.
Proof.
  unfold hoare_triple.
  intros. inversion H. subst. apply H0.
Qed.

(* Sequence *)

Theorem hoare_seq : forall P Q R c1 c2,
  {{Q}} c2 {{R}} ->
  {{P}} c1 {{Q}} ->
  {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12. subst.
  eapply H1.
  - apply H6.
  - eapply H2.
    + apply H3.
    + apply Pre.
Qed.

Example hoare_asgn_example3 : forall a n,
  {{ fun st => aeval st a = n }}
  (X ::= a;; SKIP)
  {{ fun st => st X = n }}.
Proof.
  intros.
  eapply hoare_seq.
  - apply hoare_skip.
  - eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + intros st H. subst. reflexivity.
Qed.

Example hoare_asgn_example4 :
  {{ fun st => True }}
  (X ::= (ANum 1);;
   Y ::= (ANum 2))
  {{ fun st => st X = 1 /\ st Y = 2 }}.
Proof.
  intros.
  eapply hoare_seq.
  - eapply hoare_asgn.
  - eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + intros st H. unfold assn_sub.
      auto.
Qed.

(* TODO Exercises *)

(* Conditionals *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros. apply H.
Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ (bassn b) st.
Proof.
  unfold not. intros. inversion H0.
  rewrite H2 in H. inversion H.
Qed.

Theorem hoare_if : forall P Q b c1 c2,
  {{ fun st => P st /\ bassn b st }} c1 {{ Q }} ->
  {{ fun st => P st /\ ~(bassn b st) }} c2 {{ Q }} ->
  {{ P }} (IFB b THEN c1 ELSE c2 FI) {{ Q }}.
Proof.
  intros. intros st st' HE HP.
  inversion HE; subst.
  - apply (H st st').
    + apply H7.
    + split. * apply HP. * apply H6.
  - apply (H0 st st').
    + apply H7.
    + split. * apply HP. * apply bexp_eval_false. intuition.
Qed.

Example if_example :
  {{ fun st => True }}
  IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= (APlus (AId X) (ANum 1)))
  FI
  {{ fun st => st X <= st Y }}.
Proof.
  apply hoare_if.
  - eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + unfold bassn, assn_sub, t_update, assert_implies.
      simpl. intros st [_ H]. apply beq_nat_true in H.
      omega.
  - eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + unfold assn_sub, t_update, assert_implies.
      simpl. intros st [_ H]. omega.
Qed.

(* TODO Exercises *)

(* Loops *)

Lemma hoare_while : forall P b c,
  {{ fun st => P st /\ bassn b st }} c {{ P }} ->
  {{ P }} WHILE b DO c END {{ fun st => P st /\ ~ (bassn b st) }}.
Proof.
  intros. intros st st' HE HP.
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction HE; try (inversion Heqwcom); subst; clear Heqwcom.
  - split.
    + apply HP. + apply bexp_eval_false. apply H0.
  - apply IHHE2.
    + reflexivity.
    + eapply H.
      * apply HE1. * split. assumption. apply bexp_eval_true. apply H0.
Qed.

Example while_example :
  {{ fun st => st X <= 3 }}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
  {{ fun st => st X = 3 }}.
Proof.
  eapply hoare_consequence_post.
  - apply hoare_while.
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + unfold bassn, assn_sub, assert_implies, t_update.
      simpl. intros st [H1 H2]. apply leb_complete in H2.
      omega.
  - unfold bassn, assert_implies. intros st [Hle Hb].
    simpl in Hb. destruct (leb (st X) 2) eqn: Heqle.
    + destruct Hb. reflexivity.
    + apply leb_iff_conv in Heqle. omega.
Qed.

Theorem always_loop_hoare : forall P Q,
  {{ P }} WHILE BTrue DO SKIP END {{ Q }}.
Proof.
  Admitted.


From STLC Require Import STLCdef.
From STLC Require Import STLCprop.
From PLF Require Import LibTactics.
From PLF Require Import Maps.
Require Import Utf8.

Module Type STLCLR.

  Import STLC.

  (* Parameter Res : Prop. *)
  Parameter R : context -> tm -> ty -> Prop.
  (* Parameter query : ctx -> ID -> option ty. *)
(*
  Recall syntactic definition. We really just glue things onto it
  | ht_var : forall G x T1,
      G x = Some T1 ->
      has_type G (tm_var x) T1
  | ht_app : forall G x y T1 T2,
      has_type G x (ty_arrow T1 T2) ->
      has_type G y T1 ->
      has_type G (tm_app x y) T2
  | ht_abs : forall G x body T1 T2,
      has_type (x |-> T1; G) body T2 ->
      has_type G (tm_abs x T1 body) (ty_arrow T1 T2)
  | ht_true  : forall G,
      has_type G tm_true ty_bool
  | ht_false : forall G,
      has_type G tm_false ty_bool
  | ht_if    : forall G cond b c T,
      has_type G cond ty_bool ->
      has_type G b T ->
      has_type G c T ->
      has_type G (tm_if cond b c) T. *)

  (* following all are compatible lemma *)
  Axiom compat_var : forall G x T1,
    G x = Some T1 ->
    R G (tm_var x) T1.

  Axiom compat_app : forall G x y T1 T2,
    R G x (ty_arrow T1 T2) ->
    R G y T1 ->
    R G (tm_app x y) T2.
  Axiom compat_abs : forall G x body T1 T2,
    R (x |-> T1; G) body T2 ->
    R G (tm_abs x T1 body) (ty_arrow T1 T2).
  Axiom compat_true  : forall G,
    R G tm_true ty_bool.
  Axiom compat_false : forall G,
    R G tm_false ty_bool.
  Axiom compat_if    : forall G cond b c T,
    R G cond ty_bool ->
    R G b T ->
    R G c T ->
    R G (tm_if cond b c) T.

  Hint Immediate compat_var compat_app compat_abs compat_true compat_false
        compat_if.
  Theorem Fundamental:
    forall G x T,
      has_type G x T -> R G x T.

    intros G x T h. induction h; eauto.
  Qed.

End STLCLR.

Module STLCLR_TypeSafe
(* <: STLCLR *)
.

  Import STLC.
  Import STLCProp.

  Definition safe (x: tm) :=
    forall y, steps x y -> (exists y', step y y') \/ value y.
    (* (value y \/ exists y', step y y'). *)

  Definition E' (T : ty) (x: tm) (k : tm -> Prop) : Prop :=
    closed x /\ forall y, steps x y -> (exists y', step y y') \/ k y.

  Fixpoint V (T : ty) (x : tm) {struct T}  : Prop :=
    match T with
    | ty_bool => x = tm_true \/ x = tm_false
    | ty_arrow a b =>  closed x /\ exists bind T body, (x = tm_abs bind T body) /\ forall input, (V a input) -> (E' b (subst bind input body) (V b))
    end.

  (* Thanks to https://www.ps.uni-saarland.de/extras/cbpv-in-coq/doc/CBPV.SemanticTyping.html *)

  Notation E T t := (E' T t (V T)).

  Inductive good_subst : partial_map ty -> partial_map tm -> Prop :=
    | gs_empty : good_subst empty empty
    | gs_v : forall ctx env x T v,
      good_subst ctx env -> V T v -> good_subst (x |-> T ; ctx) (x |-> v; env).

      Ltac clean_up_impossibilities :=
        match goal with
          | h0: (value (tm_app _ _)) |- _  => inversion h0
          | h0: (value (tm_if _ _ _)) |- _  => inversion h0
          | h0: (value (tm_var _ )) |- _  => inversion h0
          | h0: empty _ = Some _ |- _ => inversion h0
          | h0: has_type _ (tm_abs _ _ _) ty_bool |- _ => inversion h0
          | h0: (step tm_true _) |- _ => inversion h0
          | h0: (step tm_false _) |- _ => inversion h0
          | h0: (step (tm_abs _ _ _) _) |- _ => inversion h0
        end.
  Theorem good_subst_non_empty:
    forall {G} {GS},
      good_subst G GS ->
    forall {x} {T},
      G x = Some T ->
      exists v, GS x = Some v.

    intros G GS h; induction h; intros; subst; eauto;
    try clean_up_impossibilities.
    Ltac unfold_all := unfold update in *; unfold t_update in *; (repeat (unfold eqb_string in *)).
    try unfold_all; eauto.
    destruct (string_dec x x0); subst; eauto; try clean_up_impossibilities; try discriminate; try contradiction.
  Qed.

Definition R (gamma : context) (e: tm) (T : ty) :=
  forall gs, good_subst gamma gs -> E T (subst_map gs e).

Theorem good_subst_all_V:
  forall {G} {GS},
    good_subst G GS ->
    forall {v} {s},
    GS s = Some v ->
    (exists T, G s = Some T /\ V T v).

  intros G GS h. induction h; intros; subst ;eauto.
  inversion H.
  unfold_all. destruct (string_dec x s); subst; eauto; try discriminate; try contradiction.
  match goal with
  | h: Some _ = Some _ |- _ => inversion h; subst; eauto
  end.
Qed.

Ltac unfoldV :=
    match goal with
    | [h : V ?Tx _ |- _] => destruct Tx; subst; eauto; cbn in *; try clean_up_impossibilities; try discriminate
    end.

Theorem v_implies_e:
  forall T e,
    V T e -> E T e.
Admitted.
(*
  unfold E'.
  intros T e h; split; unfoldV; intros; destruct_ALL; subst; eauto.
  admit. admit. admit. admit.
  inversion h1; subst; eauto.

  unfoldV; eauto; destruct_ALL; subst ;eauto; try clean_up_impossibilities; try discriminate; try contradiction.
Qed. *)

Hint Resolve v_implies_e.
Ltac use_good_subst :=
  match goal with
  | [h : good_subst ?g1 ?g2, h2: ?g1 _ = _, h1: ?g2 _ = Some _ |- _] =>
      destruct (good_subst_all_V h h1); destruct_ALL; subst; rewrite h2 in *; subst; destruct_ALL; eauto; try clean_up_impossibilities; try discriminate; try contradiction

  | [h : good_subst ?g1 ?g2, h2: ?g2 _ = _, h1: ?g1 _ = Some _ |- _] =>
      destruct (good_subst_non_empty h h1); destruct_ALL; subst; eauto; rewrite h2 in *; destruct_ALL; try clean_up_impossibilities; try discriminate; try contradiction

  | [h : good_subst ?g1 ?g2, h1: ?g1 _ = Some _ |- _] =>
      destruct (good_subst_non_empty h h1); destruct_ALL; subst; eauto; try clean_up_impossibilities; try discriminate; try contradiction

  | [h : good_subst ?g1 ?g2, h1: ?g2 _ = Some _ |- _] =>
      destruct (good_subst_all_V h h1); destruct_ALL; subst; eauto; try clean_up_impossibilities; try discriminate; try contradiction

  end.

Definition compat_var:
  forall G x T1,
    G x = Some T1 ->
    R G (tm_var x) T1.
unfold R. intros G x T1 h0 gs h1.
cbn in *.
destruct (gs x) eqn: Heq; subst; eauto; try use_good_subst.
Qed.

Hint Constructors value ty tm step steps has_type: core.

Theorem V_as_canonical:
  forall T t,
    V T t ->
    value t.

  intros T t h.
  destruct T; cbn in *; intros; destruct_ALL; subst; simpl; eauto; try discriminate; try clean_up_impossibilities; try contradiction.
Qed.

Theorem E_close_under_step:
  forall {t t'},
    step t t' ->
  forall {T},
    E T t ->
    E T t'.
  intros t t' h.
  induction h; subst; eauto.
Admitted.

Hint Immediate V_as_canonical.
Hint Resolve V_as_canonical.

Definition  compat_app :
  forall G x y T1 T2,
    R G x (ty_arrow T1 T2) ->
    R G y T1 ->
    R G (tm_app x y) T2.

(* induction on steps, so we need to reorder argument *)

intros.
unfold R. unfold E'.
intros; split. unfold R in *; unfold E' in *.
cbn. forwardsALL; eauto.
intros.
assert (
  forall k y0,
   steps k y0 ->
  forall gs G x y T1 T2,
  k = (subst_map gs (tm_app x y)) ->
  R G x (ty_arrow T1 T2) ->
  R G y T1 ->
    good_subst G gs ->
    ((exists y', (step y0 y')) \/ V T2 y0)
); eauto; clear.
intros k y0 hsteps.
induction hsteps; intros; subst; cbn in *;eauto.
(* When Steps = refl *)
unfold R in *; unfold E' in *; forwardsALL; cbn in *;  destruct_ALL;
  try (
    match goal with
    | [h : subst_map _ _ = _ |- _] => rewrite h in *; eauto
    end
  );
  subst; try discriminate; try contradiction; eauto.

(* When Steps = step + steps *)

Ltac forwardsALL_clear :=
    match goal with
     | H : ( _ -> _) |- _ => forwards* : H;  clear H; forwardsALL_clear
     | H : _ |- _ => idtac; intros
     end.

 (forwardsALL_clear; destruct_ALL); eauto;
 try (
  match goal with
  | [h : subst_map _ _ = _ |- _] => rewrite h in *; eauto
  end
 ).

Hint Extern 1 =>
  match goal with
  | [h0 : closed ?a |- _] => rewrite (subst_id_on_closed a) in *
  end.

Hint Extern 1 =>
  match goal with
  | [h0 : value ?x , h1 : step ?x _ |- _] =>
      destruct (steppable_not_value _ _ h1 h0); subst; eauto
  end.

 unfold R in *. unfold E' in *.
 forwards* : H1; eauto;
 forwards* : H2; eauto; destruct_ALL; subst; eauto; try contradiction; try discriminate.
 (* When Steps = step + steps *)
 inversion H; subst; eauto;
 forwards* : closed_close_under_step; eauto.
  eapply (IHhsteps _ _ a' _); eauto.
  eapply (IHhsteps _ _ _ b'); eauto; eauto.
  rewrite <- H7 in *; eauto.
  forwards* : H6; eauto. destruct_ALL; subst; eauto; try clean_up_impossibilities; try contradiction; try discriminate.
  forwards* : H5; eauto. destruct_ALL; subst; eauto; try clean_up_impossibilities; try contradiction; try discriminate.
  cbn in H9; eauto; destruct_ALL; subst; eauto; try discriminate; try contradiction.
  inversion H12; subst; eauto.
  forwards*: H13; eauto. unfold E' in *; destruct_ALL; subst; eauto.
Qed.

Hint Resolve closed_tapp closed_tif closed_true closed_false closed_abs_weak.

Definition compat_true  : forall G,
R G tm_true ty_bool.

unfold R. unfold E'. cbn. split; eauto.
intros y h0. inversion h0; subst; eauto; try clean_up_impossibilities.
Qed.

Definition compat_false : forall G,
R G tm_false ty_bool.

unfold R. unfold E'. cbn. split; eauto.
intros y h0. inversion h0; subst; eauto; try clean_up_impossibilities.
Qed.

Definition compat_if    :
forall G cond b c T,
  R G cond ty_bool ->
  R G b T ->
  R G c T ->
  R G (tm_if cond b c) T.

  unfold R.  cbn. split; eauto. unfold E' in *; destruct_ALL; subst; eauto.
  forwardsALL; eauto.

  intros y h0.
  forwardsALL; destruct_ALL; subst; eauto; try clean_up_impossibilities; try discriminate; try contradiction.

  inversion h0; subst; eauto.
  unfold E' in H0; eauto.
  admit.
  eauto.
Abort.

End STLCLR_TypeSafe.


(** * Definition and classification of the [×] Type, with primitive projections *)
(** In this file, we classify the basic structure of [×] types ([prod]
    in Coq).  In particular, we classify equalities of non-dependent
    pairs (inhabitants of [×] types), so that when we have an equality
    between two such pairs, or when we want such an equality, we have
    a systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Coq.Classes.Morphisms.
Require Import Rewriter.Util.IffT.
Require Import Rewriter.Util.Equality.
Require Import Rewriter.Util.GlobalSettings.

Local Set Primitive Projections.

Delimit Scope primproj_type_scope with primproj_type.
Delimit Scope primproj_scope with primproj.

Module Import Primitive.
  Record prod A B := pair { fst : A ; snd : B }.
  Global Arguments pair {_ _}.
  Global Arguments fst {_ _}.
  Global Arguments snd {_ _}.

  Module Export Notations.
    Notation "x * y" := (@prod x y) : type_scope.
    Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
  End Notations.

  Local Set Implicit Arguments.
  Definition prod_beq A B (eq_A : A -> A -> bool) (eq_B : B -> B -> bool) (X Y : A * B) : bool
    := let '(a, b) := X in let '(a', b') := Y in (eq_A a a' && eq_B b b')%bool.
  Global Arguments prod_beq / .
  Lemma prod_dec_bl A B eq_A eq_B
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (B_bl : forall x y : B, eq_B x y = true -> x = y)
        (x y : A * B)
    : prod_beq eq_A eq_B x y = true -> x = y.
  Proof.
    destruct x as [a b], y as [a' b'].
    specialize (A_bl a a'); specialize (B_bl b b').
    cbn; intro H; destruct A_bl; [ | destruct B_bl; [ | reflexivity ] ];
      edestruct eq_A; edestruct eq_B; cbn in *; try reflexivity; try assumption.
  Defined.
  Lemma prod_dec_lb A B eq_A eq_B
        (A_lb : forall x y : A, x = y -> eq_A x y = true)
        (B_lb : forall x y : B, x = y -> eq_B x y = true)
        (x y : A * B)
    : x = y -> prod_beq eq_A eq_B x y = true.
  Proof.
    intro H; specialize (A_lb _ _ (f_equal fst H)); specialize (B_lb _ _ (f_equal snd H)).
    cbn in *; cbv [fst snd] in *.
    rewrite A_lb, B_lb; reflexivity.
  Defined.
  Definition prod_eq_dec A B eq_A eq_B
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (B_bl : forall x y : B, eq_B x y = true -> x = y)
        (A_lb : forall x y : A, x = y -> eq_A x y = true)
        (B_lb : forall x y : B, x = y -> eq_B x y = true)
        (x y : A * B)
    : {x = y} + {x <> y}.
  Proof.
    refine (let H := let b := @prod_beq A B eq_A eq_B x y in if b as b0 return ({b0 = true} + {b0 = false}) then left eq_refl else right eq_refl in
            match H with
            | left e => left (@prod_dec_bl A B eq_A eq_B A_bl B_bl x y e)
            | right H' => right (fun e => _ (@prod_dec_lb A B eq_A eq_B A_lb B_lb x y e))
            end).
    congruence.
  Defined.
End Primitive.
Notation "x * y" := (@prod x%primproj_type y%primproj_type) : primproj_type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x%primproj y%primproj) .. z%primproj) : primproj_scope.

Local Arguments f_equal {_ _} _ {_ _} _.

Definition fst_pair {A B} (a:A) (b:B) : fst (a,b) = a := eq_refl.
Definition snd_pair {A B} (a:A) (b:B) : snd (a,b) = b := eq_refl.
Create HintDb cancel_primpair discriminated. #[global] Hint Rewrite @fst_pair @snd_pair : cancel_primpair.

(** ** Equality for [prod] *)
Section prod.
  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition fst_path {A B} {u v : prod A B} (p : u = v)
  : fst u = fst v
    := f_equal fst p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition snd_path {A B} {u v : prod A B} (p : u = v)
  : snd u = snd v
    := f_equal snd p.

  (** *** Equality of [prod] is itself a [prod] *)
  Definition path_prod_uncurried {A B : Type} (u v : prod A B)
             (pq : prod (fst u = fst v) (snd u = snd v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct p, q; simpl in *.
    reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_prod {A B : Type} (u v : prod A B)
             (p : fst u = fst v) (q : snd u = snd v)
    : u = v
    := path_prod_uncurried u v (pair p q).

  (** *** Equivalence of equality of [prod] with a [prod] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of × types
      in dependent positions, we'd need it. *)
  Definition path_prod_uncurried_iff {A B}
             (u v : @prod A B)
    : u = v <-> (prod (fst u = fst v) (snd u = snd v)).
  Proof.
    split; [ intro; subst; split; reflexivity | apply path_prod_uncurried ].
  Defined.

  (** *** Eta-expansion of [@eq (prod _ _)] *)
  Definition path_prod_eta {A B} {u v : @prod A B} (p : u = v)
    : p = path_prod_uncurried u v (fst_path p, snd_path p).
  Proof. destruct p; reflexivity. Defined.

  (** *** Induction principle for [@eq (prod _ _)] *)
  Definition path_prod_rect {A B} {u v : @prod A B} (P : u = v -> Type)
             (f : forall p q, P (path_prod_uncurried u v (p, q)))
    : forall p, P p.
  Proof. intro p; specialize (f (fst_path p) (snd_path p)); destruct p; exact f. Defined.
  Definition path_prod_rec {A B u v} (P : u = v :> @prod A B -> Set) := path_prod_rect P.
  Definition path_prod_ind {A B u v} (P : u = v :> @prod A B -> Prop) := path_prod_rec P.
End prod.

Lemma prod_iff_and (A B : Prop) : (A /\ B) <-> (A * B).
Proof. repeat (intros [? ?] || intro || split); assumption. Defined.

Global Instance iff_prod_Proper
  : Proper (iff ==> iff ==> iff) (fun A B => prod A B).
Proof. repeat intro; tauto. Defined.
Global Instance iff_iffTp_prod_Proper
  : Proper (iff ==> iffTp ==> iffTp) (fun A B => prod A B) | 1.
Proof.
  intros ?? [?] ?? [?]; constructor; tauto.
Defined.
Global Instance iffTp_iff_prod_Proper
  : Proper (iffTp ==> iff ==> iffTp) (fun A B => prod A B) | 1.
Proof.
  intros ?? [?] ?? [?]; constructor; tauto.
Defined.
Global Instance iffTp_iffTp_prod_Proper
  : Proper (iffTp ==> iffTp ==> iffTp) (fun A B => prod A B) | 1.
Proof.
  intros ?? [?] ?? [?]; constructor; tauto.
Defined.
#[global] Hint Extern 2 (Proper _ prod) => apply iffTp_iffTp_prod_Proper : typeclass_instances.
#[global] Hint Extern 2 (Proper _ (fun A => prod A)) => refine iff_iffTp_prod_Proper : typeclass_instances.
#[global] Hint Extern 2 (Proper _ (fun A B => prod A B)) => refine iff_prod_Proper : typeclass_instances.

(** ** Useful Tactics *)
(** *** [inversion_prod] *)
Ltac simpl_proj_pair_in H :=
  repeat match type of H with
         | context G[fst (pair ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[snd (pair ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_path_prod H :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using path_prod_rect;
  simpl_proj_pair_in H0;
  simpl_proj_pair_in H1.
Ltac inversion_prod_step :=
  match goal with
  | [ H : _ = pair _ _ |- _ ]
    => induction_path_prod H
  | [ H : pair _ _ = _ |- _ ]
    => induction_path_prod H
  end.
Ltac inversion_prod := repeat inversion_prod_step.

(** *** [subst_prod] *)
(** The tactic [subst_prod] is like [subst], but it works on equations
    of the form [_ = (x, y)] and [(x, y) = _] for [x] and [y]
    identifiers. *)
Ltac do_subst_prod A B x y :=
  is_var x; is_var y;
  let H := fresh in
  let xy := fresh x in
  remember (@pair A B x y) as xy eqn:H;
  assert (fst xy = x) by (subst xy; reflexivity);
  assert (snd xy = y) by (subst xy; reflexivity);
  subst x y;
  clear H; try subst xy.
Ltac subst_prod_step :=
  match goal with
  | [ H : _ = @pair ?A ?B ?x ?y |- _ ] => do_subst_prod A B x y
  | [ H : @pair ?A ?B ?x ?y = _ |- _ ] => do_subst_prod A B x y
  end.
Ltac subst_prod := repeat subst_prod_step.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus (mult (Succ lv0) lv1) lv0)) (plus (mult lv1 (Succ lv0)) (Succ lv0))).
Admitted.
QuickChick conj15synthconj1.


Require Export CoRN.algebra.CRings Coq.setoid_ring.Ring.
Definition CRing_Ring(R:CRing):(ring_theory (@cm_unit R) (@cr_one R) (@csg_op R) (@cr_mult R) (fun x y => x [-] y) (@cg_inv R) (@cs_eq R)).
Proof.
 split;algebra.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import VCF.PairConstructors.
Require Import VCF.WhileCallLang.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import VCF.InfSem.
Require Import VCF.FiniteDivergeTrace.
Require Import VCF.FinTraceRelDomain.
Require Import VCF.InfTraceRelDomain.
Require Import VCF.KnasterTarski.
Require Import VCF.GeneralDomain.

Definition state := Z -> Z.
Definition constant_func {A: Type} (c: Z): A -> Z := fun _ => c.

Fixpoint aeval (a : aexp) : state -> Z :=
  match a with
  | ANum n => constant_func n
  | APlus a1 a2 => (aeval a1 + aeval a2)%Func
  | AMinus a1 a2  => (aeval a1 - aeval a2)%Func
  | AMult a1 a2 => (aeval a1 * aeval a2)%Func
  | ADeref a1 => fun st => st ((aeval a1) st)
  end.

Fixpoint beval (b : bexp) : state -> Prop :=
  match b with
  | BTrue       => Sets.full
  | BFalse      => Sets.empty
  | BEq a1 a2   => ZFunc.test_eq (aeval a1) (aeval a2)
  | BLe a1 a2   => ZFunc.test_le (aeval a1) (aeval a2)
  | BNot b1     => Sets.complement (beval b1)
  | BAnd b1 b2  => Sets.intersect (beval b1 ) (beval b2)
  end.

Definition event: Type := positive * Z.

Definition if_sem
  (cond: state -> Prop)
  (then_branch else_branch: InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop))
  : InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)
:=
  Domain_union
    (iTrRel.concat (iTrRel.test cond nil) then_branch)
    (iTrRel.concat (iTrRel.test (Sets.complement cond) nil) else_branch).

Definition loop_sem (cond: state -> Prop) (loop_body: InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)):
  InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop) :=
  KT_fix_l
    (fun sem =>
       Domain_union
         (iTrRel.concat
           (iTrRel.test cond nil)
           (iTrRel.concat loop_body sem))
         (iTrRel.test (Sets.complement cond) nil)).

Lemma loop_sem_recur:
  forall cond loop_body,
    Domain_R'
      (loop_sem cond loop_body)
      (Domain_union
         (iTrRel.concat
           (iTrRel.test cond nil)
           (iTrRel.concat loop_body (loop_sem cond loop_body)))
         (iTrRel.test (Sets.complement cond) nil)).
Proof.
  intros.
  unfold loop_sem.
  match goal with
  | |- Domain_R' (KT_fix_l ?F) _ =>
    pose proof KnasterTarski_fixpoint_theorem_l F as H; apply H; clear H
  end.
  hnf; intros.
  rewrite H.
  reflexivity.
Qed.

Fixpoint ceval (c: com) (callee: func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)): InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop) :=
  match c with
  | CSkip => iTrRel.id
  | CAss a1 a2 =>
      {|
        fin_cases :=
          fun st1 tr st2 =>
            st2 (aeval a1 st1) = aeval a2 st1 /\
            (forall l, aeval a1 st1 <> l -> st1 l = st2 l) /\
            tr = nil;
          inf_cases :=
            Sets.empty
      |}
  | CSeq c1 c2 => iTrRel.concat (ceval c1 callee) (ceval c2 callee)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1 callee) (ceval c2 callee)
  | CWhile b c => loop_sem (beval b) (ceval c callee)
  | CCall f => match f with
               | Zneg fid =>
                   {|
                     fin_cases := fun st1 tr st2 => st1 = st2 /\ tr = (fid, st1 0%Z) :: nil;
                     inf_cases := Sets.empty
                   |}
               | _ => callee f
               end
  end.

Definition single_binrel {A} (a0: A) (R: InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)): A -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop) :=
  fun a =>
    {|
        fin_cases := fun b tr c => a = a0 /\ fin_cases R b tr c;
        inf_cases := fun b tr=> a = a0 /\ inf_cases R b tr;
    |}.

Definition feval (fc: func_name * com) (callee: func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)): func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop) :=
  match fc with
  | (f, c) => single_binrel f (ceval c callee)
  end.

Definition peval_pre (p: prog) (callee: func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)):=
  fold_right Domain_union Domain_empty (map (fun fc => feval fc callee) p).

Fixpoint peval (p: prog): func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop) :=
  KT_fix_l (peval_pre p).

(***********************************************************)

Record partial_prog_denote: Type := {
  defined_funcs: func_name -> Prop;
  func_nodup: Prop;
  partial_sem: (func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop)) ->
               (func_name -> InfSem (state -> list event -> state -> Prop) (state -> FDvgTrace event unit -> Prop));
}.

Record partial_prog_denote_equiv (d1 d2: partial_prog_denote): Prop := {
  defined_funcs_equiv: forall f,
    defined_funcs d1 f <-> defined_funcs d2 f;
  func_nodup_equiv:
    func_nodup d1 <-> func_nodup d2;
  partial_sem_equiv: Domain_R' (partial_sem d1) (partial_sem d2)
}.

Definition partial_peval (p: list (func_name * com)): partial_prog_denote := {|
  defined_funcs := fun f => exists c, In (f, c) p;
  func_nodup := NoDup (map fst p);
  partial_sem := fun extern_sem => KT_fix_l (fun sem => peval_pre p (Domain_union extern_sem sem))
|}.

Definition union_pair {A: Type} {CLA: CL_Domain A} {UnionA: Union_Domain A} (p: A * A): A :=
  Domain_union (fst p) (snd p).

Lemma union_pair_equiv: forall {A: Type} {CLA: CL_Domain A} {UnionA: Union_Domain A} p1 p2,
  Domain_R' p1 p2 -> Domain_R' (union_pair p1) (union_pair p2).
Admitted.

Definition partial_prog_denote_compose (d1 d2: partial_prog_denote): partial_prog_denote := {|
  defined_funcs := Sets.union (defined_funcs d1) (defined_funcs d2);
  func_nodup := func_nodup d1 /\ func_nodup d2 /\
                Sets.equiv (Sets.intersect (defined_funcs d1) (defined_funcs d2)) Sets.empty;
  partial_sem := fun extern_sem =>
                   union_pair
                     (KT_fix2_l
                       (fun _ sem2 => partial_sem d1 (Domain_union extern_sem sem2))
                       (fun sem1 _ => partial_sem d2 (Domain_union extern_sem sem1)))
|}.

Theorem separate_compile: forall p1 p2,
  partial_prog_denote_equiv
    (partial_peval (p1 ++ p2))
    (partial_prog_denote_compose (partial_peval p1) (partial_peval p2)).
Proof.
Admitted.


Universes x y.

Constraint x < y.

Definition X := Type@{x}.
Definition Y := Type@{y}.

Check X.
(* X : Type@{Top.1+1} *)

Check Y.
(* Y : Type@{Top.2+1} *)

Inductive W : X -> Y :=.

Definition x : X. Admitted.

Definition y : (W x : Y). Admitted.

Check x : X.
(* x : X : X *)

Fail Check y : Y.
(* The command has indeed failed with message:
The term "y" has type "W x" while it is expected to have type "Y". *)

Check y : W x : Y.

Definition Z := Type.

Inductive F : Y -> Z :=.

Check F y.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e285m9_11limbs.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.


(** * Preface *)

(* $Date: 2012-07-23 16:26:25 -0400 (Mon, 23 Jul 2012) $ *)

(** This electronic book is a one-semester course on _Software
    Foundations_ -- the mathematical theory of programming and
    programming languages -- suitable for graduate or upper-level
    undergraduate students.  It develops basic concepts of functional
    programming, logic, operational semantics, lambda-calculus, and
    static type systems, using the Coq proof assistant.

    The main novelty of the course is that the development is
    formalized and machine-checked: the text is literally a script for
    the Coq proof assistant.  It is intended to be read hand-in-hand
    with the accompanying Coq source file in an interactive session
    with Coq.  All the details of the lectures are fully developed in
    Coq, and the exercises are designed to be worked using Coq.

    The files are organized into a sequence of core chapters, covering
    about one semester's worth of material and organized into a
    coherent linear narrative, plus several "appendices" covering
    additional topics. *)

(* ###################################################################### *)
(** * Overview *)

(** The course weaves together several fundamental themes:
  - _Logic_ as the mathematical basis for software engineering:
<<
                logic                        calculus
         --------------------   =   ----------------------------
         software engineering       mechanical/civil engineering
>>
         In particular, inductively defined sets and relations and
         inductive proofs about them are ubiquitous in all of computer
         science.  The course examines them from many angles.

  - _Functional programming_, an increasingly important part of
    the software developer's bag of tricks:

       - Advanced programming idioms in mainstream software
         development methodologies are increasingly incorporating
         ideas from functional programming.

       - In particular, using persistent data structures and avoiding
         mutable state enormously simplifies many concurrent
         programming tasks.

  - _Foundations of programming languages_ (the second part of the
    course):

        - Notations and techniques for rigorously describing and
          stress-testing new programming languages and language
          features.  (Designing new programming languages is a
          surprisingly common activity!  Most
          large software systems include subsystems that are basically
          programming languages -- think of regular expressions,
          command-line formats, preference and configuration files,
          SQL, Flash, PDF, etc., etc.)

        - A more sophisticated understanding of the everyday tools
          used to build software... what's going on under the hood of
          your favorite programming language.

  - _Coq_, an industrial-strength proof assistant:

       - Proof assistants are becoming more and more popular in both
         software and hardware industries.  Coq is not the only one
         out there, but learning one thoroughly will give you a big
         advantage in coming to grips with another.
*)

(* ###################################################################### *)
(** * Practicalities *)

(* ###################################################################### *)
(** ** Chapter Dependencies *)

(** A diagram of the dependencies between chapters and some suggested
    paths through the material can be found in the file [deps.html]. *)

(* ###################################################################### *)
(** ** Required Background *)

(** These notes are intended to be accessible to a broad range of
    readers, from advanced undergraduates to PhD students and
    researchers.  They assume little specific background in
    programming languages or logic.  However, a degree of mathematical
    maturity will be helpful. *)

(* ###################################################################### *)
(** * Coq *)

(** Our laboratory for this course is the Coq proof assistant.
    Coq can be seen as a combination of two things:
      - a simple and slightly idiosyncratic (but, in its way,
        extremely expressive) _programming language_, together with
      - a set of tools for stating _logical assertions_ (including
        assertions about the behavior of programs) and marshalling
        evidence of their truth.
    We will be investigating both aspects in tandem.
*)

(* ###################################################################### *)
(** ** System Requirements *)

(** Coq runs on Windows and pretty much all flavors of Unix (including
    Linux and OS X).  You will need:
       - A current installation of Coq, available from the Coq home
         page.  (Everything is known to compile with 8.3.)
       - An IDE for interacting with Coq.  Currently, there are two choices:
           - Proof General is an Emacs-based IDE.  It tends to be
             preferred by users who are already comfortable with
             Emacs.  It requires a separate installation (google
             "Proof General").
           - CoqIDE is a simpler stand-alone IDE.  It is distributed
             with Coq, but on some platforms compiling it involves
             installing additional packages for GUI libraries and
             such. *)

(* ###################################################################### *)
(** ** Access to the Coq files *)

(** A tar file containing the full sources for the "release version"
    of these notes (as a collection of Coq scripts and HTML files) is
    available here:
<<
        http://www.cis.upenn.edu/~bcpierce/sf
>>
    If you are using the notes as part of a class, you may be given
    access to a locally extended version of the files, which you
    should use instead of the release version.
*)

(* ###################################################################### *)
(** * Exercises *)

(** Each chapter of the notes includes numerous exercises.  Some are
    marked "optional", some "recommended."  Doing just the
    non-optional exercises should provide good coverage of the
    material in approximately six or eight hours of study time (for
    the longer chapters).

    The "star ratings" for the exercises can be interpreted as follows:

       - One star: easy exercises that for most readers should take
         only a minute or two.  None of these are explicitly marked
         "Recommended"; rather, _all_ of them should be considered as
         recommended: readers should be in the habit of working them
         as they reach them.

       - Two stars: straightforward exercises (five or ten minutes).

       - Three stars: exercises requiring a bit of thought (fifteen
         minutes to half an hour).

       - Four stars: more difficult exercises (an hour or two).
*)

(* ###################################################################### *)
(** * Recommended Reading *)

(** Some suggestions for supplemental texts can be found in the
    [Postscript] chapter. *)

(* ###################################################################### *)
(** * Translations *)

(** Thanks to the efforts of a team of volunteer translators, _Software
    Foundations_ can now be enjoyed in Japanese:

      - http://proofcafe.org/sf
*)

(* ###################################################################### *)
(** * For Instructors *)

(** If you intend to use these materials in your own course, you will
    undoubtedly find things you'd like to change, improve, or add.
    Your contributions are welcome!

    Please send an email to Benjamin Pierce, and we'll set you up with
    read/write access to our subversion repository and developers'
    mailing list; in the repository you'll find a [README] with further
    instructions. *)


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

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

Print Assumptions freeze.


Require Import Base.
Require Import BaseProofs.

Inductive 𝔳 : Type :=
  | 𝔳hole : 𝔳
  | 𝔳pair : 𝔳 -> 𝔳 -> 𝔳
  | 𝔳inj : nat -> 𝔳 -> 𝔳
  | 𝔳lambda : 𝔵 -> 𝔳 -> 𝔳
  | 𝔳suspend : 𝔢 -> 𝔳
with 𝔫 : Type :=
  | 𝔫hole : 𝔫
  | 𝔫pair : 𝔢 -> 𝔢 -> 𝔫
  | 𝔫inj : nat -> 𝔢 -> 𝔫
  | 𝔫lambda : 𝔵 -> 𝔢 -> 𝔫
  | 𝔫return : 𝔢 -> 𝔫
  | 𝔫flor : 𝔳 -> 𝔫.

Fixpoint 𝔳2𝔱 (v : 𝔳) :=
  match v with
  | 𝔳hole => 𝔱hole
  | 𝔳pair v1 v2 => 𝔱pair (𝔳2𝔱 v1) (𝔳2𝔱 v2)
  | 𝔳inj z v1 => 𝔱inj z (𝔳2𝔱 v1)
  | 𝔳lambda x v1 => 𝔱lambda x (𝔳2𝔱 v1)
  | 𝔳suspend e => 𝔱suspend e
  end.

Definition 𝔫2𝔢 (n : 𝔫) :=
  match n with
  | 𝔫hole => 𝔢hole
  | 𝔫pair e1 e2 => 𝔢pair e1 e2
  | 𝔫inj z e => 𝔢inj z e
  | 𝔫lambda x e => 𝔢lambda x e
  | 𝔫return e => 𝔢return e
  | 𝔫flor v => 𝔢flor (𝔳2𝔱 v)
  end.

Fixpoint 𝔱subst (t : 𝔱) (x : 𝔵) (v : 𝔱) : 𝔱 :=
  match t with
  | 𝔱id x' => (match var_eq x x' with true => v | false => t end)
  | 𝔱hole => t
  | 𝔱holecase t' => 𝔱holecase (𝔱subst t' x v)
  | 𝔱pair t1 t2 => 𝔱pair (𝔱subst t1 x v) (𝔱subst t2 x v)
  | 𝔱prj z t' => 𝔱prj z (𝔱subst t' x v)
  | 𝔱inj z t' => 𝔱inj z (𝔱subst t' x v)
  | 𝔱case t' x1 t1 x2 t2 => 𝔱case (𝔱subst t' x v) x1 (𝔱subst t1 x v) x2 (𝔱subst t2 x v)
  | 𝔱lambda x' t' => 𝔱lambda x' (𝔱subst t' x v)
  | 𝔱app t1 t2 => 𝔱app (𝔱subst t1 x v) (𝔱subst t2 x v)
  | 𝔱suspend e => t
  end.

Fixpoint 𝔢subst (e : 𝔢) (x : 𝔵) (n : 𝔢) : 𝔢 :=
  match e with
  | 𝔢id x' => (match var_eq x x' with true => n | false => e end)
  | 𝔢hole => e
  | 𝔢holecase e' => 𝔢holecase (𝔢subst e' x n)
  | 𝔢holelet e1 e2 => 𝔢holelet (𝔢subst e1 x n) (𝔢subst e2 x n)
  | 𝔢pair e1 e2 => 𝔢pair (𝔢subst e1 x n) (𝔢subst e2 x n)
  | 𝔢let x1 x2 e1 e2 => 𝔢let x1 x2 (𝔢subst e1 x n) (𝔢subst e2 x n)
  | 𝔢inj z e => 𝔢inj z (𝔢subst e x n)
  | 𝔢case e' x1 e1 x2 e2 => 𝔢case (𝔢subst e' x n) x1 (𝔢subst e1 x n) x2 (𝔢subst e2 x n)
  | 𝔢lambda x' e' => 𝔢lambda x' (𝔢subst e' x n)
  | 𝔢app e1 e2 => 𝔢app (𝔢subst e1 x n) (𝔢subst e2 x n)
  | 𝔢return e' => 𝔢return (𝔢subst e' x n)
  | 𝔢bind x' e1 e2 => 𝔢bind x' (𝔢subst e1 x n) (𝔢subst e2 x n)
  | 𝔢force t => e
  | 𝔢flor t => e
  | 𝔢florlet x' e1 e2 => 𝔢florlet x' (𝔢subst e1 x n) (𝔢subst e2 x n)
  end.


Parameter sort : Set.
Parameter axiom : sort -> sort -> Prop.
Parameter rule_pi : sort -> sort -> sort -> Prop.
Parameter rule_sig : sort -> sort -> sort -> Prop.

Parameter star : sort.

Definition size_sort (s:sort) := 1.

Parameter sort_regularity : forall s1, exists s2, axiom s1 s2.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import String.
Require Export Field.
Require Import cells.

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

Open Scope ring_scope.

(* Une notation plus jolie pour les arêtes. *)
Notation "[ 'edge' 'of' p1 , p2 ]" := (@Bedge p1 p2 is_true_true)
  (at level 0, format  "[ 'edge'  'of'  p1 ','  p2 ]").

(* Une notation pour les nombres rationnels qui sont en fait des entiers. *)
Notation "[ 'rat' 'of' 'int' x ]" := (Rat (fracq_subproof (Posz x, Posz 1))).

Notation "[ 'rat' 'of' x , y ]" :=  (Rat (fracq_subproof (x, y))).

(* En entrée, les rationnels qui sont en fait des entiers positifs peuvent
  aussi s'écrire 2%:R, etc. *)

Definition rat_of_nat (x : nat) : rat :=  x%:R.

Coercion rat_of_nat : nat >-> rat.

Definition mk_edge (a b c d : nat) : option edge :=
  let a' := a%:R in
  let b' := b%:R in
  let c' := c%:R in
  let d' := d%:R in
  match (a' < c') as x return (a' < c') = x -> option edge with
  | true => fun h =>
     Some (@Bedge {| p_x := a'; p_y := b'|} {| p_x := c'; p_y := d'|} h)
  | false => fun _ => None
  end erefl.

Fixpoint seq_nat_to_edges (s : seq nat) : option (seq edge) :=
  match s with
  | nil => Some nil
  | a :: b :: c :: d :: tl =>
    match mk_edge a b c d with
    | Some e =>
       match seq_nat_to_edges tl with Some r => Some (e :: r) | _ => None end
    | _ => None
    end
  | _ => None
  end.

Definition dummy_low := @Bedge (Bpt 0%:Q 0%:Q) (Bpt 50%:Q 0%:Q) isT.

Definition dummy_high := @Bedge (Bpt 0%:Q 50%:Q) (Bpt 50%:Q 50%:Q) isT.

Definition test (s : seq nat) : option (seq cell) :=
  match seq_nat_to_edges s with
  | Some v => Some (start (edges_to_events v) dummy_low dummy_high )
  | _ => None
  end.

Definition newline :=
  String (Ascii.Ascii false true false true false false false false)
        EmptyString.

Definition digits := "0123456789"%string.

Fixpoint nat_to_st (fuel : nat) (n : nat) (buffer : string) :=
  match fuel with
  | S p =>
    let d := (n %% 10)%N in
    let n' := (n %/ 10)%N in
    let buffer' := match get d digits with
    | Some da => String da buffer
    | None => buffer
    end in
    if n' == 0%N then buffer' else nat_to_st p n' buffer'
  | 0 => concat ""%string [:: "0"%string; buffer]
  end.

Definition nat_to_string (n : nat) (buf : string) :=
  nat_to_st n n buf.

Definition int_to_string (n : int) (buf : string) :=
  match n with
  | Posz n => nat_to_string n buf
  | Negz n => nat_to_string n.+1 (concat "" [:: " opp "; buf]%string)
  end.

Definition rat_to_string (scale : string) (r : rat) (buffer : string) :=
  let v := valq r in
  if (v.2 == 1) then
    int_to_string v.1 (concat "" [:: " "; scale; " "; buffer]%string)
  else
     int_to_string v.1 (concat "" [:: " "; scale; " ";
       (int_to_string v.2 (concat "" [:: " div "; buffer]))]%string).

Definition cats (s1 s2: string) := concat "" [:: s1; s2].

Definition display_segment (scale : string)
   (p1 p2 : pt) (buffer : string) : string :=
  rat_to_string scale (p_x p1) (rat_to_string scale (p_y p1)
    (cats "moveto "
      (rat_to_string scale (p_x p2) (rat_to_string scale (p_y p2)
         (concat "" ([:: "lineto"; newline; buffer])%string))))).

Fixpoint iterate_cell_border (scale : string) (f : string -> pt -> pt -> string -> string)
  (last : pt) (s : seq pt) (buffer : string) :=
  match s with
  | nil => buffer
  | p :: nil => f scale p last buffer
  | p1 :: (p2 :: _) as tl =>
    let buffer' := iterate_cell_border scale f last tl buffer in
    f scale p1 p2 buffer'
  end.

Definition display_cell_border scale s buffer :=
  match s with
  | a :: tl => iterate_cell_border scale display_segment a s buffer
  | nil => buffer
  end.

Definition display_cell scale (c : cell) (buf : string) : string :=
  display_cell_border scale (pts c) buf.

Definition dtest (s : seq nat) :=
  match test s with
  | Some v =>
    concat newline ([:: ""; "%!PS"; "100 100 translate"; "newpath";
    foldr (display_cell (cats
    newline
    "20 mul "%string))
    (concat newline [:: "stroke"; "showpage"; "EOF"; ""]) v])%string
  | None => EmptyString
  end.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.