Require Import Program.Tactics.
Require Import MyTactics.
Require Import LabelAlgebra.
Require Import LambdaTwoSyntax.

Section IndistinguishabilityTwo.

Context (L : two)
        (P : value -> value -> Prop)
        (Prefl : forall x, P x x).

Fixpoint atom_LPequiv a1 a2 : Prop :=
  match a1, a2 with
    | Atom v1 l1, Atom v2 l2 =>
      (L = Bottom2 /\ l1 = l2 /\ l1 = Top2 /\
       match v1, v2 with
         | VNat n1, VNat n2 => P v1 v2
         | VClos e1 t1, VClos e2 t2 => value_LPequiv v1 v2
         | _, _ => True
       end) \/
      (L = Bottom2 /\ l1 = l2 /\ l1 = Bottom2 /\ value_LPequiv v1 v2) \/
      (L = Top2 /\ l1 = l2 /\ value_LPequiv v1 v2)
  end
with value_LPequiv v1 v2 : Prop :=
       match v1, v2 with
         | VBool b1, VBool b2 => b1 = b2
         | VNat n1, VNat n2 => n1 = n2
         | VClos e1 t1, VClos e2 t2 =>
           list_forall2 atom_LPequiv e1 e2 /\ t1 = t2
         | VBool _, _ | VNat _, _ | VClos _ _, _ => False
       end.

Definition env_LPequiv : env -> env -> Prop :=
  list_forall2 atom_LPequiv.

Lemma atom_LPequiv_lab_inv :
  forall v1 v2 l1 l2,
    atom_LPequiv (Atom v1 l1) (Atom v2 l2) ->
    l1 = l2.
Proof.
  intros. inversion H; inversion H0; destruct_conjs; auto.
Qed.

Lemma atom_LPequiv_raise :
  forall v1 v2,
    atom_LPequiv (Atom v1 Bottom2) (Atom v2 Bottom2) ->
    atom_LPequiv (Atom v1 Top2) (Atom v2 Top2).
Proof.
  intros v1 v2 H. destruct L.
  - destruct v1; destruct v2; destruct H; destruct H; destruct_conjs;
        inversion H; try inversion H1; subst; auto.
    + destruct H2. left. auto.
    + right. right. auto.
    + destruct H2. left. auto.
    + right. right. auto.
    + left. auto.
    + right. right. auto.
  - destruct v1; destruct v2; destruct H; destruct H; destruct_conjs;
        inversion H; inversion H1; inversion H2; subst.
    + destruct H2. left. auto.
    + right. right. auto.
    + left. auto.
    + right. right. auto.
    + left. auto.
    + right. right.  auto.
Qed.

End IndistinguishabilityTwo.

Definition atom_Lequiv := fun L => atom_LPequiv L (fun _ _ => True).

Definition value_Lequiv := fun L => value_LPequiv L (fun _ _ => True).

Definition env_Lequiv := fun L => env_LPequiv L (fun _ _ => True).

Lemma atom_value_env_LPequiv_Lequiv :
  forall L P,
    (forall a1 a2,
       atom_LPequiv L P a1 a2 -> atom_Lequiv L a1 a2)
    /\ (forall v1 v2,
          value_LPequiv L P v1 v2 -> value_Lequiv L v1 v2)
    /\ (forall e1 e2,
          env_LPequiv L P e1 e2 -> env_Lequiv L e1 e2).
Proof.
  intros. apply atom_value_env_mutind.
  - intros v1 Hv l1 a2 H. destruct a2 as [v2 l2].
    destruct L; destruct l1; destruct l2.
    + assert (value_LPequiv Bottom2 P v1 v2) by
          (destruct H; destruct H; destruct_conjs; try inversion H1; auto).
      apply Hv in H0. right. left. auto.
    + apply atom_LPequiv_lab_inv in H. inversion H.
    + apply atom_LPequiv_lab_inv in H. inversion H.
    + destruct v1; destruct v2; left; repeat (split; auto).
      * assert (t0 = t /\ env_LPequiv Bottom2 P l l0) by
            (split; destruct H; destruct H; destruct_conjs; subst; auto).
        destruct_conjs; subst.
        assert (value_Lequiv Bottom2 (VClos l t) (VClos l0 t)) by
            (apply Hv; split; auto).
        assert (env_Lequiv Bottom2 l l0) by
            (destruct H0; destruct H; destruct_conjs; subst; auto).
        assumption.
      * destruct H; destruct H; destruct_conjs; subst; auto.
    + assert (value_LPequiv Top2 P v1 v2) by
          (destruct H; destruct H; destruct_conjs; try inversion H; auto).
      apply Hv in H0. right. right. auto.
    + apply atom_LPequiv_lab_inv in H. inversion H.
    + apply atom_LPequiv_lab_inv in H. inversion H.
    + assert (value_LPequiv Top2 P v1 v2) by
          (destruct H; destruct H; destruct_conjs; try inversion H; auto).
      apply Hv in H0. right. right. auto.
  - intros n1 v2 H. destruct v2; inversion H; reflexivity.
  - intros n1 v2 H. destruct v2; inversion H; reflexivity.
  - intros e1 He t1 v2 H. destruct v2 as [| | e2 t2].
    + inversion H.
    + inversion H.
    + assert (env_LPequiv L P e1 e2) by (destruct H; auto).
      assert (t2 = t1) by (destruct H; symmetry; assumption).
      apply He in H0. subst. split; auto.
  - intros e1.
    induction e1 as [| a1 e1']; intros Ha e2 H;
    destruct e2 as [| a2 e2']; inversion H; auto; split.
    + apply (Ha 0); auto.
    + apply IHe1'. intros. apply (Ha (S n)); auto. assumption.
Qed.

Lemma atom_LPequiv_Lequiv :
  forall L P a1 a2,
    atom_LPequiv L P a1 a2 -> atom_Lequiv L a1 a2.
Proof. apply atom_value_env_LPequiv_Lequiv. Qed.

Lemma value_LPequiv_Lequiv :
  forall L P v1 v2,
    value_LPequiv L P v1 v2 -> value_Lequiv L v1 v2.
Proof. apply atom_value_env_LPequiv_Lequiv. Qed.

Lemma env_LPequiv_Lequiv :
  forall L P e1 e2,
    env_LPequiv L P e1 e2 -> env_Lequiv L e1 e2.
Proof. apply atom_value_env_LPequiv_Lequiv. Qed.

Lemma atom_value_env_LPequiv_refl :
  forall L (P : value -> value -> Prop),
    (forall x, P x x) ->
    (forall a, atom_LPequiv L P a a) /\
    (forall v, value_LPequiv L P v v) /\
    (forall e, env_LPequiv L P e e).
Proof.
  intros L P Prefl. apply atom_value_env_mutind.
  - intros v Hv l.
    destruct v as [b | n | e t];
      (destruct L; destruct l; [
         right; left; auto |
         left; auto |
         right; right; auto |
         right; right; auto
       ]).
  - intros b.
    unfold value_LPequiv. auto.
  - intros n.
    unfold value_LPequiv. auto.
  - intros e He t.
    unfold value_LPequiv. auto.
  - intros e Ha.
    unfold env_LPequiv.
    induction e as [| a e'].
    + reflexivity.
    + split.
      * apply (Ha 0). reflexivity.
      * apply IHe'. intros. apply (Ha (S n)). auto.
Qed.

Lemma atom_LPequiv_refl :
  forall L (P : value -> value -> Prop),
    (forall x, P x x) ->
    (forall a, atom_LPequiv L P a a).
Proof.
  intros. apply atom_value_env_LPequiv_refl. auto.
Qed.

Lemma value_LPequiv_refl :
  forall L (P : value -> value -> Prop),
    (forall x, P x x) ->
    (forall v, value_LPequiv L P v v).
Proof.
  intros. apply atom_value_env_LPequiv_refl. auto.
Qed.

Lemma env_LPequiv_refl :
  forall L (P : value -> value -> Prop),
    (forall x, P x x) ->
    (forall e, env_LPequiv L P e e).
Proof.
  intros. apply atom_value_env_LPequiv_refl. auto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Automatic Coercions Import.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Module_cat.
Require Export Monoid_util.
Require Export Group_util.
(** Title "Tools for building modules." *)
Section Module.
Variable R : RING.
Variable E : Setoid.
Variable genlaw : E -> E -> E.
Variable e : E.
Variable geninv : E -> E.
Variable gen_module_op : R -> E -> E.
Hypothesis
  fcomp :
    forall x x' y y' : E,
    Equal x x' -> Equal y y' -> Equal (genlaw x y) (genlaw x' y').
Hypothesis
  genlawassoc :
    forall x y z : E, Equal (genlaw (genlaw x y) z) (genlaw x (genlaw y z)).
Hypothesis eunitgenlawr : forall x : E, Equal (genlaw x e) x.
Hypothesis invcomp : forall x y : E, Equal x y -> Equal (geninv x) (geninv y).
Hypothesis geninvr : forall x : E, Equal (genlaw x (geninv x)) e.
Hypothesis fcom : forall x y : E, Equal (genlaw x y) (genlaw y x).
Hypothesis
  op_comp :
    forall (a b : R) (x y : E),
    Equal a b -> Equal x y -> Equal (gen_module_op a x) (gen_module_op b y).
Hypothesis
  oplin_l :
    forall (a b : R) (x : E),
    Equal (gen_module_op (sgroup_law R a b) x)
      (genlaw (gen_module_op a x) (gen_module_op b x)).
Hypothesis
  oplin_r :
    forall (a : R) (x y : E),
    Equal (gen_module_op a (genlaw x y))
      (genlaw (gen_module_op a x) (gen_module_op a y)).
Hypothesis
  opassoc :
    forall (a b : R) (x : E),
    Equal (gen_module_op a (gen_module_op b x))
      (gen_module_op (ring_mult a b) x).
Hypothesis opunit : forall x : E, Equal (gen_module_op (ring_unit R) x) x.

Definition module_util_endo_el : forall a : R, Endo_SET E.
intros a; try assumption.
simpl in |- *.
apply (Build_Map (A:=E) (B:=E) (Ap:=fun x : E => gen_module_op a x)).
red in |- *.
auto with algebra.
Defined.

Definition module_util_op : operation (ring_monoid R) E.
simpl in |- *.
apply
 (BUILD_HOM_MONOID (G:=ring_monoid R) (G':=Endo_SET E)
    (ff:=module_util_endo_el)).
simpl in |- *.
intros x y H'; red in |- *.
simpl in |- *.
auto with algebra.
simpl in |- *.
intros x y; red in |- *.
simpl in |- *.
intros x0; try assumption.
apply Trans with (gen_module_op (ring_mult x y) x0); auto with algebra.
simpl in |- *.
red in |- *.
simpl in |- *.
auto with algebra.
Defined.

Definition module_util_G : ABELIAN_GROUP.
apply (BUILD_ABELIAN_GROUP (E:=E) (genlaw:=genlaw) (e:=e) (geninv:=geninv));
 auto with algebra.
Defined.

Definition BUILD_MODULE : MODULE R.
apply (Build_module (R:=R) (module_carrier:=module_util_G)).
apply (Build_module_on (R:=R) (M:=module_util_G) (module_op:=module_util_op)).
abstract exact oplin_l.
abstract exact oplin_r.
Defined.
End Module.
Section Hom.
Variable R : RING.
Variable Mod Mod' : MODULE R.
Variable ff : Mod -> Mod'.
Hypothesis ffcomp : forall x y : Mod, Equal x y -> Equal (ff x) (ff y).
Hypothesis
  fflaw :
    forall x y : Mod,
    Equal (ff (sgroup_law Mod x y)) (sgroup_law Mod' (ff x) (ff y)).
Hypothesis ffunit : Equal (ff (monoid_unit Mod)) (monoid_unit Mod').
Hypothesis
  ffop :
    forall (a : R) (x : Mod),
    Equal (ff (module_mult a x)) (module_mult a (ff x)).

Definition BUILD_HOM_MODULE : Hom Mod Mod' :=
  Build_module_hom
    (module_monoid_hom:=BUILD_HOM_GROUP (G:=Mod) (G':=Mod') (ff:=ff) ffcomp
                          fflaw ffunit) ffop.
End Hom.
Section Module_on_group.
Variable R : RING.
Variable module_util_G : ABELIAN_GROUP.
Variable gen_module_op : R -> module_util_G -> module_util_G.
Hypothesis
  op_comp :
    forall (a b : R) (x y : module_util_G),
    Equal a b -> Equal x y -> Equal (gen_module_op a x) (gen_module_op b y).
Hypothesis
  oplin_l :
    forall (a b : R) (x : module_util_G),
    Equal (gen_module_op (sgroup_law R a b) x)
      (sgroup_law module_util_G (gen_module_op a x) (gen_module_op b x)).
Hypothesis
  oplin_r :
    forall (a : R) (x y : module_util_G),
    Equal (gen_module_op a (sgroup_law module_util_G x y))
      (sgroup_law module_util_G (gen_module_op a x) (gen_module_op a y)).
Hypothesis
  opassoc :
    forall (a b : R) (x : module_util_G),
    Equal (gen_module_op a (gen_module_op b x))
      (gen_module_op (ring_mult a b) x).
Hypothesis
  opunit : forall x : module_util_G, Equal (gen_module_op (ring_unit R) x) x.

Definition module_util_endo_el2 : forall a : R, Endo_SET module_util_G.
intros a; try assumption.
simpl in |- *.
apply
 (Build_Map (A:=module_util_G) (B:=module_util_G)
    (Ap:=fun x : module_util_G => gen_module_op a x)).
red in |- *.
auto with algebra.
Defined.

Definition module_util_op2 : operation (ring_monoid R) module_util_G.
simpl in |- *.
apply
 (BUILD_HOM_MONOID (G:=ring_monoid R) (G':=Endo_SET module_util_G)
    (ff:=module_util_endo_el2)).
simpl in |- *.
intros x y H'; red in |- *.
simpl in |- *.
auto with algebra.
simpl in |- *.
intros x y; red in |- *.
simpl in |- *.
intros x0; try assumption.
apply Trans with (gen_module_op (ring_mult x y) x0); auto with algebra.
simpl in |- *.
red in |- *.
simpl in |- *.
auto with algebra.
Defined.

Definition BUILD_MODULE_GROUP : MODULE R.
apply (Build_module (R:=R) (module_carrier:=module_util_G)).
apply
 (Build_module_on (R:=R) (M:=module_util_G) (module_op:=module_util_op2)).
abstract exact oplin_l.
abstract exact oplin_r.
Defined.
End Module_on_group.


Require Export Base.

Definition is_coequalizer {C: Category} {x y: C} (f g: x ~> y) (E: C) (e: y ~> E) :=
  e ∘ f = e ∘ g /\
  forall z (d: y ~> z), d ∘ f = d ∘ g -> exists! u: E ~> z, u ∘ e = d.

Definition is_coeq_obj {C: Category} {x y: C} (f g: x ~> y) (E: C) :=
  exists e, is_coequalizer f g E e.

Definition ex_coequalizer {C: Category} {x y: C} (f g: x ~> y) :=
  exists E, is_coeq_obj f g E.

Instance is_coeq_obj_iso {C: Category} {x y: C} (f g: x ~> y): Proper (isomorphic C ==> iff) (is_coeq_obj f g).
Proof.
  enough (Proper (isomorphic C ==> impl) (is_coeq_obj f g)).
  now split; apply H.
  intros E E' [i] [e [He H]].
  exists (i ∘ e).
  split.
  rewrite <- !comp_assoc.
  now f_equal.
  intros z d Hd.
  specialize (H z d Hd).
  destruct H as [u [Hu H]].
  subst d.
  exists (u ∘ i⁻¹).
  split.
  rewrite comp_assoc, <- (comp_assoc u).
  f_equal.
  rewrite inv_l.
  apply comp_id_r.
  intros u' Hu'.
  apply (iso_epic i).
  rewrite <- comp_assoc, inv_l, comp_id_r.
  apply H.
  now rewrite <- comp_assoc.
Qed.

Lemma iso_eq_obj {C: Category} (x y: C) (f g: x ~> y) (E E': C): is_coeq_obj f g E -> is_coeq_obj f g E' -> E ≃ E'.
Proof.
  intros [e [He H]] [e' [He' H0]].
  destruct (H E' e' He') as [to [H1 _]].
  destruct (H0 E e He) as [from [H2 _]].
  constructor.
  exists to, from.
  + specialize (H E e He).
    destruct H as [u [_ Hu]].
    transitivity u.
    symmetry.
    all: apply Hu.
    rewrite <- comp_assoc, H1.
    apply H2.
    apply comp_id_l.
  + specialize (H0 E' e' He').
    destruct H0 as [u [_ Hu]].
    transitivity u.
    symmetry.
    all: apply Hu.
    rewrite <- comp_assoc, H2.
    apply H1.
    apply comp_id_l.
Qed.

Module CoeqCategory.

Structure mixin_of (C: Category) := Mixin {
  coEqz {x y: C} (f g: x ~> y): C;
  coeqz {x y: C} (f g: x ~> y): y ~> coEqz f g;
  coeqz_comm {x y: C} (f g: x ~> y): coeqz f g ∘ f = coeqz f g ∘ g;
  coeqz_med {x y z: C} (f g: x ~> y) (e: y ~> z): e ∘ f = e ∘ g -> coEqz f g ~> z;
  coeqz_med_comm {x y z: C} (f g: x ~> y) (e: y ~> z) (H: e ∘ f = e ∘ g): (coeqz_med f g e H) ∘ coeqz f g = e;
  coeqz_med_unique {x y z: C} (f g: x ~> y) (e: y ~> z) (u: coEqz f g ~> z) (H: e ∘ f = e ∘ g): u ∘ coeqz f g = e -> coeqz_med f g e H = u;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable T: type.
Definition class := match T return class_of T with Pack _ c => c end.

Definition Cat: Cat := T.

End ClassDef.

Module Exports.

Coercion sort: type >-> Category.
Coercion Cat: type >-> Category.obj.
Notation CoeqCategory := type.

End Exports.

End CoeqCategory.

Export CoeqCategory.Exports.

Section Coequalizer.
Context {C: CoeqCategory}.

Definition coEqz: forall {x y: C} (f g: x ~> y), C := @CoeqCategory.coEqz C (CoeqCategory.class C).
Definition coeqz: forall {x y: C} (f g: x ~> y), y ~> coEqz f g := @CoeqCategory.coeqz C (CoeqCategory.class C).
Definition coeqz_med: forall {x y z: C} (f g: x ~> y) (e: y ~> z), e ∘ f = e ∘ g -> coEqz f g ~> z := @CoeqCategory.coeqz_med C (CoeqCategory.class C).

Lemma coeqz_comm {x y: C} (f g: x ~> y): coeqz f g ∘ f = coeqz f g ∘ g.
Proof. apply CoeqCategory.coeqz_comm. Qed.
Lemma coeqz_med_comm {x y z: C} (f g: x ~> y) (e: y ~> z) (H: e ∘ f = e ∘ g): (coeqz_med f g e H) ∘ coeqz f g = e.
Proof. apply CoeqCategory.coeqz_med_comm. Qed.
Lemma coeqz_med_unique {x y z: C} (f g: x ~> y) (e: y ~> z) (u: coEqz f g ~> z) (H: e ∘ f = e ∘ g): u ∘ coeqz f g = e -> coeqz_med f g e H = u.
Proof. apply CoeqCategory.coeqz_med_unique. Qed.

End Coequalizer.


(** * Trace Sets *)

(** Building a different sort of trace semantics by looking at inductively generated (prefix-closed?) sets of traces
and then trying to do some reduction of that set

TL;DR:
> the semantics of a program is a set of traces, S
> we define some equivalence on traces ~ and obtain S/~
>> (and prove it complete)
> now any reduction S' should be between the two S/~ <= S' <= S
>> S' <= S guarantees completeness
>> S/~ <= S guarantees soundness
*)

From Coq Require Import Strings.String.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Init.Datatypes.
From Coq Require Import Lists.List.
Import ListNotations.
From Coq Require Import Program.Equality.   (* for `dependent induction` *)
(* which apparently (CTrees) smuggles in UIP(-equivalent) *)
From Coq Require Import Logic.FunctionalExtensionality. (* for equality of substitutions *)
From Coq Require Import Relations.
From Coq Require Import Sets.Ensembles.
(* From Coq Require Import Classes.RelationClasses. *)

From SymEx Require Import Expr.
Import BasicExpr.

From SymEx Require Import Maps.
Import BasicMaps.

From SymEx Require Import Parallel.

Open Scope com_scope.
Open Scope string_scope.
Open Scope list_scope.

Definition Var : Type := string.
Example X : Var := "x".
Example Y : Var := "y".

Ltac splits := repeat (try split).

(** Symbolic semantics *)
Inductive STrace_step : Type :=
| STAsgn (x:Var) (e:Aexpr)
| STCond (b:Bexpr).

Definition STrace : Type := list STrace_step.

Fixpoint can_step (s1 s2: Stmt)

Example branch_ex : In _ (traces__S <{if X <= 1 {X := Y} {Y := 1}}>) [STCond <{X <= 1}> ; STAsgn X Y].
Proof. apply Union_introl. eexists. splits. Qed.

Example par_ex : traces__S <{(X := 1 ; Y := 2) || (X := Y ; Y := X)}> [STAsgn X 1 ; STAsgn X Y ; STAsgn Y X ; STAsgn Y 2].
Proof.
  apply Union_introl. eexists. eexists. eexists. splits.
  - eexists. eexists. eexists. splits.

Definition Concatenate (A B: Ensemble STrace) : Ensemble STrace :=
  fun t => exists t1 t2, t = t1 ++ t2 /\ A t1 /\ B t2.

Example concat_ex : In _  (Concatenate
                                (Union _
                                      (Singleton _ [STAsgn X 0])
                                      (Singleton _ [STAsgn Y 1]))
                                (Union _
                                      (Singleton _ [STAsgn Y 0])
                                      (Singleton _ [STAsgn X 1])))
                         [STAsgn X 0; STAsgn Y 0].
Proof.
  exists [STAsgn X 0]. exists [STAsgn Y 0]. splits.
  apply Union_introl. apply In_singleton.
  apply Union_introl. apply In_singleton.
Qed.

Example concat_ex' : In _  (Concatenate
                                (Union _
                                      (Singleton _ [STAsgn X 0])
                                      (Singleton _ [STAsgn Y 1]))
                                (Union _
                                      (Singleton _ [STAsgn Y 0])
                                      (Singleton _ [STAsgn X 1])))
                         [STAsgn Y 1; STAsgn X 1].
Proof.
  exists [STAsgn Y 1]. exists [STAsgn X 1]. splits.
  apply Union_intror. apply In_singleton.
  apply Union_intror. apply In_singleton.
Qed.

Inductive is_interleaving : STrace -> STrace -> STrace -> Prop :=
| both_empty : is_interleaving [] [] []
| left_empty : forall t, is_interleaving [] t t
| right_empty : forall t, is_interleaving t [] t
| left_step : forall t1 t2 t x,
    is_interleaving t1 t2 t ->
    is_interleaving (t1::x) t2 (t::x)
| right_step : forall t1 t2 t x,
    is_interleaving t1 t2 t ->
    is_interleaving t1 (t2::x) (t::x)
.

Definition Interleave (A B: Ensemble STrace) : Ensemble STrace :=
  fun t => exists t1 t2, is_interleaving t1 t2 t /\ A t1 /\ B t2.

Fixpoint prog_traces__S (p:Program) : Ensemble STrace :=
  match p with
  | PNil => Singleton _ []
  | PStep p s => Concatenate (prog_traces__S p) (stmt_traces__S s)
  end
with stmt_traces__S (s:Stmt) : Ensemble STrace :=
       match s with
       | <{ x := e }> => Singleton _ [STAsgn x e]
       | <{s1 || s2}> => Interleave (prog_traces__S s1) (prog_traces__S s2)
       | <{if b s1 s2 fi}> => Union _
                                  (Concatenate (Singleton _ [STCond b]) (prog_traces__S s1))
                                  (Concatenate (Singleton _ [STCond (BNot b)]) (prog_traces__S s2))
       end
.

Example branch_ex : In _ (stmt_traces__S <{if X <= 1 {X := Y} {Y := 1} fi}>) [STCond <{X <= 1}> ; STAsgn X Y].
Proof. unfold stmt_traces__S, prog_traces__S. apply Union_introl. eexists. eexists [STAsgn X Y]. splits.
       eexists. eexists. splits. reflexivity.
Qed.

Example left_ex : Program := PStep (PStep PNil <{X := 1}>) <{Y := 2}>.
Example right_ex : Program := PStep (PStep PNil <{X := Y}>) <{Y := X}>.

Example par_ex : stmt_traces__S <{left_ex || right_ex}> [STAsgn X 1 ; STAsgn X Y ; STAsgn Y X ; STAsgn Y 2].
Proof.
  unfold left_ex, right_ex. unfold stmt_traces__S, prog_traces__S.
  exists [STAsgn X 1 ; STAsgn Y 2]. exists [STAsgn X Y ; STAsgn Y X]. splits.
  - repeat (constructor).
  - eexists. eexists. splits. reflexivity.
    + eexists. eexists. splits. reflexivity.
  - eexists. eexists. splits. reflexivity.
    + eexists. eexists. splits. reflexivity.
Qed.

(* Concrete Semantics *)
Definition Val : Type := nat.

Inductive CTrace_step : Type :=
  | CTAsgn (x:Var) (v:Val).

Definition CTrace : Type := trace CTrace_step.

Fixpoint acc_val (V0:Valuation) (t:CTrace) : Valuation :=
  match t with
  | [] => V0
  | t :: CTAsgn x v => let V := acc_val V0 t in
                 (x !-> v ; V)
  end.

Definition Aeval_t (V0:Valuation) (t:CTrace) (e:Aexpr) : nat :=
  Aeval (acc_val V0 t) e.

Definition Beval_t (V0:Valuation) (t:CTrace) (e:Bexpr) : bool :=
  Beval (acc_val V0 t) e.

Fixpoint prog_trace__C (V0 : Valuation) (p:Program) : CTrace :=
  match p with
  | PNil => []
  | PStep p s => let t1 := prog_trace__C V0 p in
      t1 ++ stmt_trace__C (acc_val V0 t1) s
  end
with stmt_trace__C (V0 : Valuation) (s:Stmt) : CTrace :=
       match s with
       | <{ x := e }> => [CTAsgn x (Aeval V0 e)]
       | <{ p1 || p2 }> => let t1 := prog_trace__C V0 p1 in
      t1 ++ prog_trace__C (acc_val V0 t1) p2
       | <{ if b p1 p2 fi }> => if Beval V0 b then prog_trace__C V0 p1 else prog_trace__C V0 p2
       end.

Example branch_ex__C : stmt_trace__C (_ !-> 0) <{if X <= 1 {Y := X} {Y := 1} fi}> = [CTAsgn Y 0].
Proof. simpl. reflexivity. Qed.

Example par_ex__C : stmt_trace__C (_ !-> 0) <{left_ex || right_ex}> = [CTAsgn X 1 ; CTAsgn Y 2 ; CTAsgn X 2 ; CTAsgn Y 2].
Proof. simpl. rewrite 2 update_eq. reflexivity. Qed.

(** Properties *)
Fixpoint acc_subst (s0:sub) (t:STrace) : sub :=
  match t with
  | [] => s0
  | t :: STAsgn x e => let s := acc_subst s0 t in
                     (x !-> Aapply s e ; s)
  | t :: _ => acc_subst s0 t
  end.

Definition acc_subst_id := acc_subst id_sub.

Definition Aapply_t (t:STrace) (e:Aexpr) : Aexpr :=
  Aapply (acc_subst_id t) e.

Definition Bapply_t (s0:sub) (t:STrace) (e:Bexpr) : Bexpr :=
  Bapply (acc_subst s0 t) e.

Fixpoint pc (s0:sub) (t:STrace) : Bexpr :=
  match t with
  | [] => BTrue
  | t :: STCond b => BAnd (Bapply_t s0 t b) (pc s0 t)
  | t :: _ => pc s0 t
  end.

Definition pc_id := pc id_sub.

Definition is_abstraction (V0:Valuation) (tc:CTrace) (ts:STrace) : Prop :=
  acc_val V0 tc = Comp V0 (acc_subst_id ts).

Example completeness_branch_ex : is_abstraction (_ !-> 0) [CTAsgn Y 0] [STCond <{X <= 1}> ; STAsgn Y X]
                       /\ Beval (_ !-> 0) (pc_id [STCond <{X <= 1}> ; STAsgn Y X]) = true.
Proof. splits.
  unfold is_abstraction, acc_subst_id, Comp. simpl. extensionality x.
  unfold update. destruct (Y =? x); reflexivity.
Qed.

Example s_trace_ex := [STAsgn X 1 ; STAsgn Y 2; STAsgn X Y ; STAsgn Y X].
Example completeness_par_ex : stmt_traces__S <{left_ex || right_ex}> s_trace_ex
                              /\ is_abstraction (_ !-> 0) (stmt_trace__C (_ !-> 0) <{left_ex || right_ex}>) s_trace_ex
                              /\ Beval (_ !-> 0) (pc_id s_trace_ex) = true.
Proof.
  splits.
  - unfold stmt_traces__S. exists [STAsgn X 1; STAsgn Y 2]. exists [STAsgn X Y; STAsgn Y X]. splits.
    + repeat constructor.
    + eexists. eexists. splits. reflexivity.
      * eexists. eexists. splits. reflexivity.
    + eexists. eexists. splits. reflexivity.
      * eexists. eexists. splits. reflexivity.
  - simpl. rewrite 2 update_eq.
    unfold is_abstraction, s_trace_ex. simpl.
    unfold acc_subst_id, acc_subst, s_trace_ex. simpl. rewrite 2 update_eq.
    extensionality x. unfold Comp, update.
    (* lol *)
    destruct (Y =? x); destruct (X =? X); destruct (Y =? Y); destruct (Y =? X); destruct (X =? Y); destruct (X =? x);
      reflexivity.
Qed.

Lemma cond_idemp : forall b t s,
    acc_subst s (t :: STCond b) = acc_subst s t.
Proof. intros. reflexivity. Qed.

Lemma acc_subst_empty : forall s,
    acc_subst s [] = s.
Proof. intros. reflexivity. Qed.

Lemma acc_subst_app : forall s0 t1 t2,
    acc_subst s0 (t1 ++ t2) = acc_subst (acc_subst s0 t1) t2.
Proof.
  intros. induction t2.
  - reflexivity.
  - destruct a.
    + simpl. rewrite IHt2. reflexivity.
    + assumption.
Qed.

Lemma pc_app : forall V0 s t1 t2, Beval V0 (pc s (t1 ++ t2)) = Beval V0 (pc s t1) && Beval V0 (pc (acc_subst s t1) t2).
Proof.
  induction t2.
  - simpl. destruct (Beval V0 (pc s t1)); reflexivity.
  - destruct a.
    + assumption.
    + unfold pc_id in *. simpl. rewrite IHt2. simpl. unfold Bapply_t, acc_subst_id. rewrite acc_subst_app.
      (* this is a mess, but it's just rearranging some conjunctions *)
      rewrite 2 andb_assoc. rewrite andb_comm. rewrite andb_assoc. rewrite andb_comm.
      rewrite andb_comm with (b1 := Beval V0 (pc (acc_subst s t1) t2)). rewrite andb_assoc. reflexivity.
Qed.

(* Lemma trace_seq_app : forall V s1 s2, trace_of V <{s1 ; s2}> = trace_of V s1 ++ trace_of' V (trace_of V s1) s2. *)
(* Proof. *)
(*   intros. destruct (trace_of V s1) eqn:H; *)
(*     unfold trace_of in *; simpl; rewrite H; reflexivity. *)
(* Qed. *)

Lemma acc_val_app : forall V0 t1 t2,
    acc_val V0 (t1 ++ t2) = acc_val (acc_val V0 t1) t2.
Proof.
  induction t2;
    [|destruct a; simpl; rewrite IHt2]; reflexivity.
Qed.

Lemma interleave_degen : forall t1 t2, is_interleaving t1 t2 (t1 ++ t2).
Proof.
  intros. induction t2.
  - constructor.
  - simpl. constructor. assumption.
Qed.

Lemma par_all_left : forall s1 s2 t1 t2, prog_traces__S s1 t1 -> prog_traces__S s2 t2 -> stmt_traces__S <{s1 || s2}> (t1 ++ t2).
Proof.
  intros. exists t1. exists t2. splits.
  - apply interleave_degen.
  - assumption.
  - assumption.
Qed.

Lemma pc_monotone : forall V0 t t', Beval V0 (pc_id (t ++ t')) = true ->
                               Beval V0 (pc_id t) = true /\ Beval V0 (pc (acc_subst_id t) t') = true.
Proof. intros. unfold pc_id, acc_subst_id in *. rewrite pc_app in H. apply andb_true_iff in H. assumption. Qed.

Theorem soundness : forall p t V0,
    prog_traces__S p t ->
    Beval V0 (pc_id t) = true ->
    exists t', prog_trace__C V0 p = t'
        /\ is_abstraction V0 t' t.
Proof.
  dependent induction p; intros.
  - exists []. splits. inversion H. unfold is_abstraction. simpl. apply comp_id.
  - dependent induction s;
      destruct H as [t1 [t2 [Happ [Hprog Hstep]]]];
      rewrite Happ in H0; unfold pc_id in H0; rewrite pc_app in H0; rewrite andb_true_iff in H0; destruct H0;
      destruct (IHp t1 V0 Hprog H) as [t' [IHprog IHabs]].
    + exists (t' :: CTAsgn x (Aeval_t V0 t' e)). splits.
      * simpl. rewrite IHprog. unfold Aeval_t. reflexivity.
      * inversion Hstep. unfold is_abstraction in *. simpl. rewrite Happ. rewrite <- H1. unfold acc_subst_id in *. rewrite acc_subst_app.
        simpl. rewrite asgn_sound. unfold Aeval_t. rewrite IHabs. reflexivity.
    + destruct Hstep; destruct H1 as [branch [cont [HApp1 [Hbranch Hcont]]]];
        inversion Hbranch; subst; rewrite pc_app in H0;
        rewrite andb_true_iff in H0; destruct H0; simpl in H0; rewrite andb_true_r in H0.
      * exists (prog_trace__C V0 p ++ prog_trace__C (acc_val V0 (prog_trace__C V0 p)) s1). splits.
        ** simpl. unfold Bapply_t in H0. simpl in H0. rewrite 2 IHabs. rewrite comp_subB. unfold acc_subst_id.
           rewrite H0. reflexivity.
        ** admit. (* true branch maintaints abstraction *)
      * exists (prog_trace__C V0 p ++ prog_trace__C (acc_val V0 (prog_trace__C V0 p)) s2). splits.
        ** simpl. unfold Bapply_t in H0. simpl in H0. rewrite 2 IHabs. rewrite comp_subB. unfold acc_subst_id.
           apply negb_true_iff in H0. rewrite H0. rewrite IHabs. unfold acc_subst_id. reflexivity.
        ** admit. (* false branch maintains abstraction *)
    + (* this is actually not true, since an abstract trace may choose a concretely "impossible" order of execution, huh *)
Admitted.

Theorem completeness : forall s V0 , exists ts,
    has_trace__S s ts /\ is_abstraction V0 (trace_of V0 s) ts /\ Beval V0 (pc_id ts) = true.
Proof.
  intros.
  (* unfold trace_of, trace_of'. *)
  dependent induction s.
  - (* x := e *)
    exists [STAsgn x e]. splits.
    + unfold trace_of. simpl. unfold is_abstraction, Aeval_t, acc_subst_id.
      simpl. rewrite asgn_sound. rewrite comp_id. reflexivity.
  - (* s1 ; s2 *)
    destruct (IHs1 V0) as [ts1 [comp [IH1 IHpc1]]].
    destruct (IHs2 (acc_val V0 (trace_of V0 s1))) as [ts2 [comp2 [IH2 IHpc2]]].
    exists (ts1 ++ ts2). splits.
    + eexists. eexists. splits; [apply comp | apply comp2].
    + rewrite trace_seq_app. admit.
    + rewrite pc_app. rewrite andb_true_iff. splits.
      * assumption.
      * unfold is_abstraction in IH1. rewrite IH1 in IHpc2.
        rewrite comp_subB in IHpc2. unfold pc_id in IHpc2.

  - (* s1 || s2 *)
    destruct (IHs1 V0) as [ts1 [comp [IH1 IHpc1]]].
    destruct (IHs2 (acc_val V0 (trace_of V0 s1))) as [ts2 [comp2 [IH2 IHpc2]]].
    exists (ts1 ++ ts2). splits.
    + apply par_all_left; assumption.
    + unfold trace_of. simpl. unfold is_abstraction in *. rewrite acc_val_app.

      (* need some lemmas about multiple composition but I cannot formulate them separate from acc_*
       which is worrying *)

(* maybe needed later *)
Fixpoint is_prefix {A:Type} (t0 t:list A) : Prop :=
  match t0 with
  | [] => True
  | x :: xs => match t with
             | [] => False
             | y :: ys => x = y /\ is_prefix xs ys
             end
  end.

Definition prefix_closure (sem: STrace -> Prop) (t:STrace) : Prop :=
  exists t', sem t' /\ is_prefix t t'.


(* Author: Russell O'Connor *)
(* This file is Public Domain *)

Require Import Coq.Lists.List.
Require Import Ensembles.
Require Import Peano_dec.
Require Import Eqdep_dec.
Require Import Arith.
Require Import Compare_dec.
Require Import Max.
Require Import misc.

Unset Standard Proposition Elimination Names.

Record Language : Type := language
  {Relations : Set; Functions : Set; arity : Relations + Functions -> nat}.

Section First_Order_Logic.

Variable L : Language.

Inductive Term : Set :=
  | var : nat -> Term
  | apply : forall f : Functions L, Terms (arity L (inr _ f)) -> Term
with Terms : nat -> Set :=
  | Tnil : Terms 0
  | Tcons : forall n : nat, Term -> Terms n -> Terms (S n).

Scheme Term_Terms_ind := Induction for Term Sort Prop
  with Terms_Term_ind := Induction for Terms Sort Prop.

Scheme Term_Terms_rec := Minimality for Term Sort Set
  with Terms_Term_rec := Minimality for Terms Sort Set.

Scheme Term_Terms_rec_full := Induction for Term
  Sort Set
  with Terms_Term_rec_full := Induction for Terms Sort Set.

Inductive Formula : Set :=
  | equal : Term -> Term -> Formula
  | atomic : forall r : Relations L, Terms (arity L (inl _ r)) -> Formula
  | impH : Formula -> Formula -> Formula
  | notH : Formula -> Formula
  | forallH : nat -> Formula -> Formula.

Definition Formulas := list Formula.

Definition System := Ensemble Formula.
Definition mem := Ensembles.In.

Section Fol_Full.

Definition orH (A B : Formula) := impH (notH A) B.

Definition andH (A B : Formula) := notH (orH (notH A) (notH B)).

Definition iffH (A B : Formula) := andH (impH A B) (impH B A).

Definition existH (x : nat) (A : Formula) := notH (forallH x (notH A)).

End Fol_Full.

Section Fol_Plus.

Definition ifThenElseH (A B C : Formula) := andH (impH A B) (impH (notH A) C).

End Fol_Plus.

Section Formula_Decideability.

Definition language_decideable :=
  ((forall x y : Functions L, {x = y} + {x <> y}) *
   (forall x y : Relations L, {x = y} + {x <> y}))%type.

Hypothesis language_dec : language_decideable.

Let nilTermsHelp : forall n : nat, n = 0 -> Terms n.
intros.
induction n as [| n Hrecn].
apply Tnil.
discriminate H.
Defined.

Lemma nilTerms : forall x : Terms 0, Tnil = x.
Proof.
assert (forall (n : nat) (p : n = 0) (x : Terms n), nilTermsHelp n p = x).
intros.
induction x as [| n t x Hrecx].
reflexivity.
discriminate p.
replace Tnil with (nilTermsHelp 0 (refl_equal 0)).
apply H.
auto.
Qed.

Let consTermsHelp : forall n : nat, Terms n -> Set.
intros.
case n.
exact
 (forall p : 0 = n, {foo : unit | eq_rec _ (fun z => Terms z) Tnil _ p = H}).
intros.
exact
 (forall p : S n0 = n,
  {t : Term * Terms n0 |
  eq_rec _ (fun z => Terms z) (Tcons n0 (fst t) (snd t)) _ p = H}).
Defined.

Lemma consTerms :
 forall (n : nat) (x : Terms (S n)),
 {t : Term * Terms n | Tcons n (fst t) (snd t) = x}.
Proof.
assert (forall (n : nat) (x : Terms n), consTermsHelp n x).
intros.
induction x as [| n t x Hrecx].
simpl in |- *.
intros.
exists tt.
elim p using K_dec_set.
apply eq_nat_dec.
simpl in |- *.
reflexivity.
simpl in |- *.
intros.
exists (t, x).
elim p using K_dec_set.
apply eq_nat_dec.
simpl in |- *.
reflexivity.
intros.
assert (consTermsHelp _ x).
apply H.
simpl in H0.
apply (H0 (refl_equal (S n))).
Qed.

Lemma term_dec : forall x y : Term, {x = y} + {x <> y}.
Proof.
induction language_dec.
assert
 (forall (f g : Functions L) (p : f = g) (ts : Terms (arity L (inr _ f)))
    (ss : Terms (arity L (inr _ g)))
    (q : arity L (inr _ f) = arity L (inr _ g)),
  eq_rec _ (fun x => Terms x) ts _ q = ss <-> apply f ts = apply g ss).
intros f g p.
eapply
 eq_ind
        with
        (x := g)
       (P :=
         fun a =>
         forall (ts : Terms (arity L (inr (Relations L) a)))
           (ss : Terms (arity L (inr (Relations L) g)))
           (q : arity L (inr (Relations L) a) = arity L (inr (Relations L) g)),
         eq_rec (arity L (inr (Relations L) a)) (fun x : nat => Terms x) ts
           (arity L (inr (Relations L) g)) q = ss <->
         apply a ts = apply g ss).
intros ts ss q.
apply
 K_dec_set
  with
    (x := arity L (inr (Relations L) g))
    (P := fun z =>
          eq_rec (arity L (inr (Relations L) g)) (fun x : nat => Terms x) ts
            (arity L (inr (Relations L) g)) z = ss <->
          apply g ts = apply g ss).
apply eq_nat_dec.
simpl in |- *.
split.
intros.
rewrite H.
auto.
intros.
inversion H.
eapply
 inj_right_pair2
                 with
                 (P :=
                   fun f : Functions L =>
                   Terms (arity L (inr (Relations L) f))).
assumption.
assumption.
auto.
intro.
elim x using
 Term_Terms_rec_full
  with
    (P0 := fun (n : nat) (ts : Terms n) =>
           forall ss : Terms n, {ts = ss} + {ts <> ss}).
intros.
induction y as [n0| f t].
induction (eq_nat_dec n n0).
rewrite a0.
left.
auto.
right.
unfold not in |- *; intros.
inversion H0.
auto.
right.
discriminate.
intros.
induction y as [n| f0 t0].
right.
discriminate.
induction (a f f0).
assert (arity L (inr (Relations L) f0) = arity L (inr (Relations L) f)).
rewrite a0.
reflexivity.
set (ss' := eq_rec _ (fun z : nat => Terms z) t0 _ H1) in *.
assert (f0 = f).
auto.
induction (H0 ss').
left.
induction (H _ _ H2 t0 t H1).
symmetry  in |- *.
apply H3.
symmetry  in |- *.
apply a1.
right.
unfold not in |- *; intros.
induction (H _ _ H2 t0 t H1).
elim b0.
symmetry  in |- *.
apply H5.
symmetry  in |- *.
assumption.
right.
unfold not in |- *; intro.
inversion H1.
auto.
intros.
left.
apply nilTerms.
intros.
induction (consTerms _ ss).
induction x0 as (a0, b0).
simpl in p.
induction (H1 b0).
induction (H0 a0).
left.
rewrite a1.
rewrite a2.
assumption.
right.
unfold not in |- *; intro.
elim b1.
rewrite <- p in H2.
inversion H2.
reflexivity.
right.
unfold not in |- *; intro.
elim b1.
rewrite <- p in H2.
inversion H2.
eapply inj_right_pair2 with (P := fun n : nat => Terms n).
apply eq_nat_dec.
assumption.
Qed.

Lemma terms_dec : forall (n : nat) (x y : Terms n), {x = y} + {x <> y}.
Proof.
intros.
induction x as [| n t x Hrecx].
left.
apply nilTerms.
induction (consTerms _ y).
induction x0 as (a, b).
simpl in p.
induction (Hrecx b).
induction (term_dec t a).
left.
rewrite a1.
rewrite a0.
assumption.
right.
unfold not in |- *; intro.
elim b0.
rewrite <- p in H.
inversion H.
reflexivity.
right.
unfold not in |- *; intro.
elim b0.
rewrite <- p in H.
inversion H.
eapply inj_right_pair2 with (P := fun n : nat => Terms n).
apply eq_nat_dec.
assumption.
Qed.

Lemma formula_dec : forall x y : Formula, {x = y} + {x <> y}.
Proof.
induction language_dec.
simple induction x; simple induction y; (right; discriminate) || intros.
induction (term_dec t t1).
induction (term_dec t0 t2).
left.
rewrite a0.
rewrite a1.
reflexivity.
right; unfold not in |- *; intros; elim b0.
inversion H.
reflexivity.
right; unfold not in |- *; intros; elim b0.
inversion H.
reflexivity.
induction (b r r0).
assert
 (forall (f g : Relations L) (p : f = g) (ts : Terms (arity L (inl _ f)))
    (ss : Terms (arity L (inl _ g)))
    (q : arity L (inl _ f) = arity L (inl _ g)),
  eq_rec _ (fun x => Terms x) ts _ q = ss <-> atomic f ts = atomic g ss).
intros f g p.
eapply
 eq_ind
        with
        (x := g)
       (P :=
         fun a =>
         forall (ts : Terms (arity L (inl _ a)))
           (ss : Terms (arity L (inl _ g)))
           (q : arity L (inl _ a) = arity L (inl _ g)),
         eq_rec _ (fun x => Terms x) ts _ q = ss <->
         atomic a ts = atomic g ss).
intros ts ss q.
elim q using K_dec_set.
apply eq_nat_dec.
simpl in |- *.
split.
intros.
rewrite H.
reflexivity.
intros.
inversion H.
eapply
 inj_right_pair2
                 with
                 (P :=
                   fun f : Relations L =>
                   Terms (arity L (inl (Functions L) f))).
assumption.
assumption.
auto.
assert (arity L (inl (Functions L) r) = arity L (inl (Functions L) r0)).
rewrite a0.
reflexivity.
induction
 (terms_dec _
    (eq_rec (arity L (inl (Functions L) r)) (fun x : nat => Terms x) t
       (arity L (inl (Functions L) r0)) H0) t0).
left.
induction (H _ _ a0 t t0 H0).
auto.
right.
induction (H _ _ a0 t t0 H0).
tauto.
right.
unfold not in |- *; intros.
inversion H.
auto.
induction (H f1).
induction (H0 f2).
left.
rewrite a0.
rewrite a1.
reflexivity.
right; unfold not in |- *; intros.
inversion H3; auto.
right; unfold not in |- *; intros.
inversion H3; auto.
induction (H f0).
left.
rewrite a0.
reflexivity.
right; unfold not in |- *; intros.
inversion H1; auto.
induction (eq_nat_dec n n0).
induction (H f0).
left.
rewrite a0.
rewrite a1.
reflexivity.
right; unfold not in |- *; intros.
inversion H1; auto.
right; unfold not in |- *; intros.
inversion H1; auto.
Qed.

End Formula_Decideability.

Section Formula_Depth_Induction.

Fixpoint depth (A : Formula) : nat :=
  match A with
  | equal _ _ => 0
  | atomic _ _ => 0
  | impH A B => S (max (depth A) (depth B))
  | notH A => S (depth A)
  | forallH _ A => S (depth A)
  end.

Definition lt_depth (A B : Formula) : Prop := depth A < depth B.

Lemma depthImp1 : forall A B : Formula, lt_depth A (impH A B).
Proof.
unfold lt_depth in |- *.
simpl in |- *.
intros.
apply le_lt_n_Sm.
apply le_max_l.
Qed.

Lemma depthImp2 : forall A B : Formula, lt_depth B (impH A B).
Proof.
unfold lt_depth in |- *.
simpl in |- *.
intros.
apply le_lt_n_Sm.
apply le_max_r.
Qed.

Lemma depthNot : forall A : Formula, lt_depth A (notH A).
Proof.
unfold lt_depth in |- *.
auto.
Qed.

Lemma depthForall : forall (A : Formula) (v : nat), lt_depth A (forallH v A).
Proof.
unfold lt_depth in |- *.
auto.
Qed.

Lemma eqDepth :
 forall A B C : Formula, depth B = depth A -> lt_depth B C -> lt_depth A C.
Proof.
unfold lt_depth in |- *.
intros.
rewrite <- H.
assumption.
Qed.

Definition Formula_depth_rec_rec :
  forall P : Formula -> Set,
  (forall a : Formula, (forall b : Formula, lt_depth b a -> P b) -> P a) ->
  forall (n : nat) (b : Formula), depth b <= n -> P b.
intros P H n.
induction n as [| n Hrecn].
intros.
apply H.
intros.
unfold lt_depth in H1.
rewrite <- (le_n_O_eq _ H0) in H1.
elim (lt_n_O _ H1).
intros.
apply H.
intros.
apply Hrecn.
apply lt_n_Sm_le.
apply lt_le_trans with (depth b).
apply H1.
apply H0.
Defined.

Definition Formula_depth_rec (P : Formula -> Set)
  (rec : forall a : Formula, (forall b : Formula, lt_depth b a -> P b) -> P a)
  (a : Formula) : P a :=
  Formula_depth_rec_rec P rec (depth a) a (le_n (depth a)).

Lemma Formula_depth_rec_indep :
 forall (Q P : Formula -> Set)
   (rec : forall a : Formula,
          (forall b : Formula, lt_depth b a -> Q b -> P b) -> Q a -> P a),
 (forall (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b a -> Q b -> P b),
  (forall (b : Formula) (p : lt_depth b a) (q : Q b), z1 b p q = z2 b p q) ->
  forall q : Q a, rec a z1 q = rec a z2 q) ->
 forall (a : Formula) (q : Q a),
 Formula_depth_rec (fun x : Formula => Q x -> P x) rec a q =
 rec a
   (fun (b : Formula) _ =>
    Formula_depth_rec (fun x : Formula => Q x -> P x) rec b) q.
Proof.
intros Q P rec H.
unfold Formula_depth_rec in |- *.
set (H0 := Formula_depth_rec_rec (fun x : Formula => Q x -> P x) rec) in *.
assert
 (forall (n m : nat) (b : Formula) (l1 : depth b <= n)
    (l2 : depth b <= m) (q : Q b), H0 n b l1 q = H0 m b l2 q).
simple induction n.
simpl in |- *.
intros.
induction m as [| m Hrecm].
simpl in |- *.
apply H.
intros.
induction
 (lt_n_O (depth b0)
    (eq_ind_r (fun n0 : nat => depth b0 < n0) p (le_n_O_eq (depth b) l1))).
intros.
simpl in |- *.
apply H.
intros.
induction
 (lt_n_O (depth b0)
    (eq_ind_r (fun n0 : nat => depth b0 < n0) p (le_n_O_eq (depth b) l1))).
simple induction m.
intros.
simpl in |- *.
apply H.
intros.
induction
 (lt_n_O (depth b0)
    (eq_ind_r (fun n1 : nat => depth b0 < n1) p (le_n_O_eq (depth b) l2))).
intros.
simpl in |- *.
apply H.
intros.
apply H1.
intros.
replace (H0 (depth a) a (le_n (depth a)) q) with
 (H0 (S (depth a)) a (le_n_Sn (depth a)) q).
simpl in |- *.
apply H.
intros.
apply H1.
apply H1.
Qed.

Definition Formula_depth_rec2rec (P : Formula -> Set)
  (f1 : forall t t0 : Term, P (equal t t0))
  (f2 : forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
        P (atomic r t))
  (f3 : forall f : Formula, P f -> forall f0 : Formula, P f0 -> P (impH f f0))
  (f4 : forall f : Formula, P f -> P (notH f))
  (f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> P b) ->
        P (forallH v a)) (a : Formula) :
  (forall b : Formula, lt_depth b a -> P b) -> P a :=
  match a return ((forall b : Formula, lt_depth b a -> P b) -> P a) with
  | equal t s => fun _ => f1 t s
  | atomic r t => fun _ => f2 r t
  | impH f g =>
      fun hyp => f3 f (hyp f (depthImp1 f g)) g (hyp g (depthImp2 f g))
  | notH f => fun hyp => f4 f (hyp f (depthNot f))
  | forallH n f => fun hyp => f5 n f hyp
  end.

Definition Formula_depth_rec2 (P : Formula -> Set)
  (f1 : forall t t0 : Term, P (equal t t0))
  (f2 : forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
        P (atomic r t))
  (f3 : forall f : Formula, P f -> forall f0 : Formula, P f0 -> P (impH f f0))
  (f4 : forall f : Formula, P f -> P (notH f))
  (f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> P b) ->
        P (forallH v a)) (a : Formula) : P a :=
  Formula_depth_rec P (Formula_depth_rec2rec P f1 f2 f3 f4 f5) a.

Remark Formula_depth_rec2rec_nice :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (a : Formula)
   (z1 z2 : forall b : Formula, lt_depth b a -> Q b -> P b),
 (forall (b : Formula) (p : lt_depth b a) (q : Q b), z1 b p q = z2 b p q) ->
 forall q : Q a,
 Formula_depth_rec2rec (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a z1 q =
 Formula_depth_rec2rec (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a z2 q.
Proof.
intros.
induction a as [t t0| r t| a1 Hreca1 a0 Hreca0| a Hreca| n a Hreca].
auto.
auto.
simpl in |- *.
apply H.
intros.
apply H2.
intros.
apply H2.
simpl in |- *.
apply H0.
intros.
apply H2.
simpl in |- *.
apply H1.
apply H2.
Qed.

Lemma Formula_depth_rec2_imp :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (a b : Formula) (q : Q (impH a b)),
 Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5
   (impH a b) q =
 f3 a (Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a) b
   (Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 b) q.
Proof.
intros.
unfold Formula_depth_rec2 at 1 in |- *.
rewrite Formula_depth_rec_indep.
simpl in |- *.
reflexivity.
intros.
apply Formula_depth_rec2rec_nice; auto.
Qed.

Lemma Formula_depth_rec2_not :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (a : Formula) (q : Q (notH a)),
 Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 (notH a) q =
 f4 a (Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a) q.
Proof.
intros.
unfold Formula_depth_rec2 at 1 in |- *.
rewrite Formula_depth_rec_indep.
simpl in |- *.
reflexivity.
apply Formula_depth_rec2rec_nice; auto.
Qed.

Lemma Formula_depth_rec2_forall :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (v : nat) (a : Formula) (q : Q (forallH v a)),
 Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5
   (forallH v a) q =
 f5 v a
   (fun (b : Formula) _ (q : Q b) =>
    Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 b q) q.
Proof.
intros.
unfold Formula_depth_rec2 at 1 in |- *.
rewrite Formula_depth_rec_indep.
simpl in |- *.
apply H1.
intros.
reflexivity.
apply Formula_depth_rec2rec_nice; auto.
Qed.

Definition Formula_depth_ind :
  forall P : Formula -> Prop,
  (forall a : Formula, (forall b : Formula, lt_depth b a -> P b) -> P a) ->
  forall a : Formula, P a.
Proof.
intros.
assert (forall (n : nat) (b : Formula), depth b <= n -> P b).
intro.
induction n as [| n Hrecn].
intros.
apply H.
intros.
unfold lt_depth in H1.
rewrite <- (le_n_O_eq _ H0) in H1.
elim (lt_n_O _ H1).
intros.
apply H.
intros.
apply Hrecn.
apply lt_n_Sm_le.
apply lt_le_trans with (depth b).
apply H1.
apply H0.
eapply H0.
apply le_n.
Qed.

Lemma Formula_depth_ind2 :
 forall P : Formula -> Prop,
 (forall t t0 : Term, P (equal t t0)) ->
 (forall (r : Relations L) (t : Terms (arity L (inl (Functions L) r))),
  P (atomic r t)) ->
 (forall f : Formula, P f -> forall f0 : Formula, P f0 -> P (impH f f0)) ->
 (forall f : Formula, P f -> P (notH f)) ->
 (forall (v : nat) (a : Formula),
  (forall b : Formula, lt_depth b (forallH v a) -> P b) -> P (forallH v a)) ->
 forall f4 : Formula, P f4.
Proof.
intros.
apply Formula_depth_ind.
simple induction a; auto.
intros.
apply H1.
apply H6.
apply depthImp1.
apply H6.
apply depthImp2.
intros.
apply H2.
apply H5.
apply depthNot.
Qed.

End Formula_Depth_Induction.

End First_Order_Logic.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_nom_rfn_sel_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall x2 L2 T2 Ts T', T2 = (t_rfn_sel x2 L2 Ts T') ->
                                    subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


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

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

Print Assumptions add.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(* This file contains the class of decidable equality and associated theory
    of updateable functions. *)

Require Import base.

(* Class of decidable equality *)
Class EqDec (A : Type) : Type :=
  eq_dec : forall a a' : A, {a = a'} + {a <> a'}.

Instance EqDec_nat : EqDec nat := eq_nat_dec.

(* Theory of updateable functions, defined over decideable domain *)
Definition upd {A} `{EqDec A} (B : Type) (f : A -> B) (a : A) (b : B) : A -> B :=
  fun a' => if eq_dec a a' then b else f a'.
Implicit Arguments upd [A H B].

Lemma upd_eq {A} `{EqDec A} : forall B (f : A -> B) a b,
  upd f a b a = b.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a)...
  intro.
  destruct n...
Qed.
Implicit Arguments upd_eq [A H B].

Lemma upd_eq' {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a = a' ->
  upd f a b a' = b.
Proof.
  intros. subst a'. apply upd_eq.
Qed.
Implicit Arguments upd_eq' [A H B].

Lemma upd_neq {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a <> a' ->
  upd f a b a' = f a'.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a')...
  intros.
  subst a'.
  destruct H0...
Qed.
Implicit Arguments upd_neq [A H B].

Instance nat_eq_dec: EqDec nat.
Proof.
  repeat intro.
 destruct (lt_eq_lt_dec a a') as [[?|?]| ?]; auto;
  right; intro; subst; eapply lt_irrefl; eauto.
Defined.

Instance EqDec_prod (A: Type) (EA: EqDec A) (B: Type) (EB: EqDec B) : EqDec (A*B).
Proof.
 hnf. decide equality; try apply eq_dec.
Defined.

Instance EqDec_list (A: Type) (EA: EqDec A) : EqDec (list A).
Proof.
 hnf. apply list_eq_dec; intros; apply EA.
Defined.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
From PLF Require Import Maps.
From PLF Require Import Imp.
From PLF Require Import Smallstep.
Hint Constructors multi.

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm
  | zro : tm
  | scc : tm -> tm
  | prd : tm -> tm
  | iszro : tm -> tm.

Inductive bvalue : tm -> Prop :=
  | bv_tru : bvalue tru
  | bv_fls : bvalue fls.
Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall t, nvalue t -> nvalue (scc t).
Definition value (t : tm) := bvalue t \/ nvalue t.
Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

Reserved Notation "t1 '-->' t2" (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      (scc t1) --> (scc t1')
  | ST_PrdZro :
      (prd zro) --> zro
  | ST_PrdScc : forall t1,
      nvalue t1 ->
      (prd (scc t1)) --> t1
  | ST_Prd : forall t1 t1',
      t1 --> t1' ->
      (prd t1) --> (prd t1')
  | ST_IszroZro :
      (iszro zro) --> tru
  | ST_IszroScc : forall t1,
       nvalue t1 ->
      (iszro (scc t1)) --> fls
  | ST_Iszro : forall t1 t1',
      t1 --> t1' ->
      (iszro t1) --> (iszro t1')
where "t1 '-->' t2" := (step t1 t2).
Hint Constructors step.

Notation step_normal_form := (normal_form step).
Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ not (value t).
Hint Unfold stuck.

(* some invalid exp *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (prd tru). unfold stuck.
  split. intros contra.
  destruct contra. inversion H; subst.
  inversion H1.
  intros contra.
  destruct contra; inversion H.
Qed.

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  intros t Hval contra; inversion Hval;subst;
    induction H; inversion contra; subst;
      try inversion H0;subst;
        eauto;
        try inversion H;subst.
Qed.

Hint Resolve value_is_nf.

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
Admitted.

Inductive ty : Type :=
  | Bool : ty
  | Nat : ty.
Reserved Notation "'|-' t '∈' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_Tru :
       |- tru ∈ Bool
  | T_Fls :
       |- fls ∈ Bool
  | T_Test : forall t1 t2 t3 T,
       |- t1 ∈ Bool ->
       |- t2 ∈ T ->
       |- t3 ∈ T ->
       |- test t1 t2 t3 ∈ T
  | T_Zro :
       |- zro ∈ Nat
  | T_Scc : forall t1,
       |- t1 ∈ Nat ->
       |- scc t1 ∈ Nat
  | T_Prd : forall t1,
       |- t1 ∈ Nat ->
       |- prd t1 ∈ Nat
  | T_Iszro : forall t1,
       |- t1 ∈ Nat ->
       |- iszro t1 ∈ Bool
where "'|-' t '∈' T" := (has_type t T).

Hint Constructors has_type.

Example has_type_1 :
  |- test fls zro (scc zro) ∈ Nat.
Proof.
  apply T_Test.
    - apply T_Fls.
    - apply T_Zro.
    - apply T_Scc.
       + apply T_Zro.
Qed.

Example has_type_not :
  not( |- test fls zro tru ∈ Bool ).
Proof.
  intros Contra. solve_by_inverts 2. Qed.

Example scc_hastype_nat__hastype_nat : forall t,
  |- scc t ∈ Nat ->
  |- t ∈ Nat.
Proof.
  intros. inversion H. assumption.
Qed.

Lemma bool_canonical : forall t,
  |- t ∈ Bool -> value t -> bvalue t.
Proof.
  intros t HT [Hb | Hn].
  - assumption.
  - induction Hn; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t ∈ Nat -> value t -> nvalue t.
Proof.
  intros t HT [Hb | Hn].
  - inversion Hb; subst; inversion HT.
  - assumption.
Qed.

Theorem progress : forall t T,
  |- t ∈ T ->
    value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_Tru and
     T_Fls, were eliminated immediately by auto *)
  - (* T_Test *)
    right. inversion IHHT1.
    (* t1 is a value *)
    apply bool_canonical in H...
    inversion H...
    (* t1 can take a step *)
    destruct H...
  - inversion IHHT.
    apply nat_canonical in H...
    right. destruct H...
  - inversion IHHT.
    apply nat_canonical in H...
    right. inversion H...
    right. destruct H...
  - inversion IHHT.
    apply nat_canonical in H...
    right. inversion H...
    right. destruct H...
Qed.

Theorem preservation : forall t t' T,
  |- t ∈ T ->
  t --> t' ->
  |- t' ∈ T.
Proof with auto.
  intros.
  generalize dependent t'.
  induction H; intros; try solve_by_invert 1.
  - inversion H2; subst...
  - inversion H0; subst...
  - inversion H0; subst...
    inversion H;subst...
  - inversion H0...
Qed.

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Print multi.
Print stuck.

Corollary soundness : forall t t' T,
  |- t ∈ T ->
  t -->* t' ->
  not (stuck t').
Proof.
  intros t t' T HT P.
  induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP. apply (preservation x y T HT H).
  unfold stuck. split; auto. Qed.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.reals.fast.CRGroupOps.
Require Export CoRN.model.setoids.CRsetoid.
Require Export CoRN.algebra.CGroups.
Require Import CoRN.reals.fast.CRcorrect.
Require Import CoRN.tactics.CornTac.

(**
** Examples of semi-groups: $\langle$#⟨#[CR],[+]$\rangle$#⟩#
*** $\langle$#⟨#[CR],[+]$\rangle$#⟩#
*)

Local Open Scope uc_scope.

Lemma CRplus_strext : bin_op_strext CRasCSetoid (ucFun2 CRplus_uc).
Proof.
 intros x1 x2 y1 y2 H.
 simpl in *.
 assert (X:(CRasCauchy_IR x1[+]CRasCauchy_IR y1)[#](CRasCauchy_IR x2[+]CRasCauchy_IR y2)).
  stepl (CRasCauchy_IR (x1+y1)%CR); [| apply eq_symmetric; apply CR_plus_as_Cauchy_IR_plus].
  stepr (CRasCauchy_IR (x2+y2)%CR); [| now apply eq_symmetric; apply CR_plus_as_Cauchy_IR_plus].
  apply CR_ap_as_Cauchy_IR_ap_1.
  assumption.
 destruct (bin_op_strext_unfolded _ _ _ _ _ _ X);[left|right];
   apply CR_ap_as_Cauchy_IR_ap_2; assumption.
Qed.

Definition CRplusasBinOp : CSetoid_bin_op CRasCSetoid :=
Build_CSetoid_bin_fun _ _ _ _ CRplus_strext.

Lemma CRisCSemiGroup : is_CSemiGroup _ CRplusasBinOp.
Proof.
 intros x y z.
 change (x + (y+z)==(x+y)+z)%CR.
 rewrite <- CR_eq_as_Cauchy_IR_eq.
 stepl ((CRasCauchy_IR x)[+](CRasCauchy_IR (y+z)%CR)); [| now apply CR_plus_as_Cauchy_IR_plus].
 stepl ((CRasCauchy_IR x)[+]((CRasCauchy_IR y)[+](CRasCauchy_IR z))); [| now
   apply plus_resp_eq; apply CR_plus_as_Cauchy_IR_plus].
 stepr ((CRasCauchy_IR (x+y)%CR)[+](CRasCauchy_IR z)); [| now apply CR_plus_as_Cauchy_IR_plus].
 stepr (((CRasCauchy_IR x)[+](CRasCauchy_IR y))[+](CRasCauchy_IR z)); [| now
   apply bin_op_is_wd_un_op_lft; apply CR_plus_as_Cauchy_IR_plus].
 apply plus_assoc_unfolded.
Qed.

Definition CRasCSemiGroup : CSemiGroup :=
Build_CSemiGroup _ _ CRisCSemiGroup.

Canonical Structure CRasCSemiGroup.


(** ListCFG: A list-based CFG Implementation *)
Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Vminus.Classes.
Require Import Vminus.Util.
Require Import Vminus.Vminus.

Require Import Vminus.CFG.
Set Bullet Behavior "Strict Subproofs".

(* ################################################################# *)
(** * List-based CFG Implementation *)

(**  One possible implementation of cfgs *)

Module ListCFG <: CFG.

  (** Blocks are labels paired with lists of instructions. *)

  Definition block := (lbl * list insn)%type.

  (** A control-flow graph is an entry label with a list of blocks. *)

  Definition t := (lbl * list block)%type.
  Local Notation cfg := t.

  Definition entry_block : cfg -> lbl := @fst _ _.

  (**  ------------------------------------------------------------------------- *)
  (** * Syntactically Well-formed ListCFGs *)

  (**
      - no duplicate block names
      - no duplicate instruction ids  (i.e. _single assignment_ )
      - there is an entry label to the CFG
      - there are no empty blocks

   *)

  (**  This definition of control-flow-graph syntactic well-formedness could
  be reformulated to use the Metatheory Library rather than the explicit use of
  NoDup here.  In particular, the ListCFG representation is an association list
  mapping labels to blocks) and the blocks themselves are also association lists.
  The NoDup requirements here could be replaced by the Metatheory Library's notion
  of [uniq].  Porting the Vminus development to better make use of the Metatheory
  library is left as an exercise for the reader :-)
  *)

  Inductive wf_cfg' : cfg -> Prop :=
    wf_cfg_intro :
      forall l bs
        (Hlbls: NoDup (map (@fst _ _) bs))
        (Huids: NoDup (flat_map (fun b => map (@fst _ _) (snd b)) bs))
        (Hentry: In l (map (@fst _ _) bs))
        (Hnonnil: ~ In [] (map (@snd _ _) bs)),
        wf_cfg' (l, bs).

  (* hack around some Coq limitation re inductive types & parameters *)
  Definition wf_cfg := wf_cfg'.

  (** EX5? (naming challenge) *)
  (** Port the above definition of wf_cfg' to use the [uniq] predicate from the Metatheory library.
      Fix up all of the proofs!
   *)

  (**  ------------------------------------------------------------------------- *)
  (** ** Implementing the interface requirements: *)

  Definition wf_pc (g:cfg) (p:pc) : Prop :=
    let (l, n) := p in
    exists is i, In (l, is) (snd g) /\ Nth i is n.

  Definition tmn_pc (g:cfg) (p:pc) : Prop :=
    let (l, n) := p in
    exists is, In (l, is) (snd g) /\ n = pred (length is).

  Definition insn_at_pc (g:cfg) (p:pc) (i:insn) : Prop :=
    let (l, n) := p in
    exists is, In (l, is) (snd g) /\ Nth i is n.

  Definition uid_at_pc (g:cfg) (p:pc) (uid:uid) : Prop :=
    exists c, insn_at_pc g p (uid, c).

  (** For all of the following exercises, reference
      CFG.v as well as the other recommended files. *)

  (** **** Exercise: 2 stars, optional (wf_pc_insn)  *)
  (** Prove that well formed program counters always
      point to an instruction (you shouldn't need any
      other definitions): *)
  Lemma wf_pc_insn : forall g, wf_cfg g ->
    forall p, wf_pc g p -> exists i, insn_at_pc g p i.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** **** Exercise: 2 stars, optional (wf_pc_tmn)  *)
  (** Prove that every block has a terminator. See
      PeanoNat.Nat and util for some helpful theorems. *)
  Lemma wf_pc_tmn : forall g, wf_cfg g ->
    forall p, wf_pc g p -> exists p', tmn_pc g p' /\ le_pc p p'.
  Proof.
  (* FILL IN HERE *) Admitted.

  (* Helper lemma: blocks have non-zero length. *)
  (** **** Exercise: 2 stars, optional (wf_cfg_block_len)  *)
  (** Prove that well formed control flow graphs
      have non-zero length. See list
      theorems about In and map. *)
  Lemma wf_cfg_block_len : forall g, wf_cfg g ->
    forall l is, In (l, is) (snd g) -> length is <> 0.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** **** Exercise: 3 stars, optional (wf_pc_le_tmn)  *)
  (** Prove there are no "gaps" in the pc labels.
      In other words, that all pcs that come before
      some arbitrary but particular pc are well formed. *)
  Lemma wf_pc_le_tmn : forall g, wf_cfg g ->
    forall p', tmn_pc g p' -> forall p, le_pc p p' -> wf_pc g p.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** **** Exercise: 3 stars, optional (wf_entry)  *)
  (** Prove there is an instruction in the entry block.
      Take a look at theorems about in and map in List. *)
  Lemma wf_entry : forall g, wf_cfg g ->
    wf_pc g (block_entry (entry_block g)).
  Proof.
    (* FILL IN HERE *) Admitted.

  (** **** Exercise: 3 stars, optional (insn_at_pc_func)  *)
  (** Prove that insn_at_pc with respect to a CFG g is a
      function from program counter to instruction. *)
  Lemma insn_at_pc_func : forall g, wf_cfg g ->
    functional (insn_at_pc g).
  Proof.
  (* FILL IN HERE *) Admitted.

  (** **** Exercise: 4 stars, optional (uid_at_pc_inj)  *)
  (** Prove that uid_at_pc with respect to a CFG g is injective.
      Take a look at List for In and map, and Util. *)
  Lemma uid_at_pc_inj : forall g, wf_cfg g ->
    injective (uid_at_pc g).
  Proof.
  (* FILL IN HERE *) Admitted.

  (** **** Exercise: 3 stars, optional (uid_at_pc_func)  *)
  (** Prove that uid_at_pc with respect to a CFG g
      is a function. *)
  Lemma uid_at_pc_func : forall g, wf_cfg g ->
    functional (uid_at_pc g).
(* FILL IN HERE *) Admitted.

  (** **** Exercise: 2 stars, optional (eq_pc_uid)  *)
  (** Prove that if two instructions are at the same
      pc in a well formed CFG, then their ids are the same. *)
  Lemma eq_pc_uid : forall g pc id1 id2 c1 c2,
    wf_cfg g ->
    insn_at_pc g pc (id1, c1) ->
    insn_at_pc g pc (id2, c2) ->
    id1 = id2.
(* FILL IN HERE *) Admitted.

  (** **** Exercise: 2 stars, optional (blocks_inj)  *)
  (** Prove that in a cfg, for each label there
      exists a single block. See Util. *)
  Lemma blocks_inj : forall g, wf_cfg g -> forall l is1 is2,
        In (l, is1) (snd g) -> In (l, is2) (snd g) -> is1 = is2.
  Proof.
  (* FILL IN HERE *) Admitted.

  (** **** Exercise: 3 stars, optional (pc_at_uid_inj)  *)
  (** Prove the other end of uid_at_pc_inj,
      showing that uid_at_pc is a bijection. *)
  Lemma pc_at_uid_inj : forall g, wf_cfg g ->
                             injective (fun x p => uid_at_pc g p x).
  Proof.
  (* FILL IN HERE *) Admitted.

  (**  ------------------------------------------------------------------------- *)
  (** ** Working with ListCFG *)

  Fixpoint remove (bs:list block) (l:lbl) : list block :=
    match bs with
    | [] => []
    | (l',is)::bs =>
      if l == l' then
        remove bs l
      else (l',is)::remove bs l
    end.

  (** [update] Adds the given instruction list as a block labeled [l].

      Note: this function does not enforce the unique-block label property.
  *)

  Definition update (bs:list block) (l:lbl) (is:list insn) : list block :=
    (l, is)::bs.

  (** Lookup the block in the list. *)

  Definition lookup (bs:list block) (l:lbl) : option (list insn) :=
    assoc Lbl.eq_dec l bs.

  (** ** Simple lemmas about CFG modifications. *)

  Lemma update_eq :
    forall (is : list insn) (l1 l2 : lbl) (bs : list block),
      l1 = l2 -> lookup (update bs l1 is) l2 = Some is.
  Proof.
    intros; unfold update, lookup.
    subst. simpl. destruct (Lbl.eq_dec l2 l2); tauto.
  Qed.

  Lemma update_neq :
    forall (l1 l2 : lbl) (is : list insn) (bs: list block),
      l1 <> l2 -> lookup (update bs l1 is) l2 = lookup bs l2.
  Proof.
    intros; subst; simpl.
    destruct (Lbl.eq_dec l2 l1); subst; tauto.
  Qed.

(**  ------------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Correspondence between [lookup] and [insn_at_pc]. *)

(** The following proposition asserts that the instruction sequence found at
    program point [p] in the control-flow graph [g] is exactly the list [is].
    Note that this connects the dynamic notion of what it means to "increment"
    the program counter to the static notion of the list of instructions.
*)

Fixpoint insns_at_pc (g:cfg) (p:pc) (is:list insn) : Prop :=
  match is with
    | nil => True
    | i :: is' => ListCFG.insn_at_pc g p i /\ insns_at_pc g (incr_pc p) is'
  end.

(** We prove that looking up the block labeled [l] in the concrete
    representation agrees with [insns_at_pc].
*)

Lemma cfg_insns_at : forall (bs:list block) (l:lbl) (is:list insn) (e:lbl),
  lookup bs l = Some is ->
  insns_at_pc (e, bs) (block_entry l) is.
Proof.
  intros.
  pose (k:=@nil insn). change is with (k ++ is) in H.
  unfold block_entry. change 0 with (length k).
  clearbody k. generalize dependent k.
  induction is; intros.
  - simpl; auto.
  - simpl. split. eexists. split.
    unfold lookup in H.
    apply assoc_in in H. simpl; eauto.
    clear H. induction k; simpl; auto.
    replace (S (length k)) with (length (k ++ [a])). apply IHis.
      rewrite <- app_assoc. auto. rewrite app_length.
      simpl. apply PeanoNat.Nat.add_1_r.
Qed.

  (**  ------------------------------------------------------------------------- *)
  (** ** Implementing fetch *)

  Definition fetch (g : cfg) (p: pc): option insn :=
    let '(entry_label, blocks) := g in
    let '(trgt_block, offset) := p in
    match (lookup blocks trgt_block) with
    | Some found_block => nth_error found_block offset
    | None => None
    end.

  (** Helper lemma for proving that fetch corresponds to insn_at_pc *)

  Lemma fetch_iff_in_cfg: forall entry_label blks trgt_label trgt_offset i,
      NoDup (map fst blks) ->
      fetch (entry_label, blks) (trgt_label, trgt_offset) = Some i <->
      exists instrs, In (trgt_label, instrs) blks /\ Nth i instrs trgt_offset.
  Proof.
    intros entry_label blks trgt_label trgt_offset i nodup.
    unfold fetch.
    destruct (lookup blks trgt_label) eqn:found.
    - unfold lookup in found. apply assoc_in in found.
      split.
      + intros. exists l. split; auto. apply nth_error_iff_Nth; auto.
      + intros [is [Hi Hnth]].
        assert (l = is).
        eapply NoDup_assoc_func; eauto. subst.
        eapply nth_error_iff_Nth; auto.
    - split.
      + intros H. inversion H.
      + intros [l [Hin Hn]].
        apply nth_error_iff_Nth in Hn. unfold lookup in found.
        apply in_assoc_none with (b:=l) in found.
        contradiction.
  Qed.

  (** [fetch] is the executable version of [insn_at_pc] *)

  Lemma insn_at_pc_fetch :
    forall g pc i, wf_cfg g ->
              insn_at_pc g pc i <-> fetch g pc = Some i.

  Proof.
    intros [l blks] pc i wf_g.
    inversion wf_g as
        [l' blks' nodup nodup_uid l_in_blks blks_not_empty [l_l' blks_blk]].
    destruct pc as [curr_label curr_offset].
    rewrite fetch_iff_in_cfg; auto.
    simpl.
    split; auto.
  Qed.

End ListCFG.