From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import logic_theories.
Require Import logic_pred_theories.
Require Import family_of_sets.

Section FamilyOfSetsTheories.
  Variable U:Type.
  Variable I X Y:Ensemble U.
  Variable XX:Ensemble (Ensemble U).
  Variable IndexedFunction : U -> Ensemble U.

  Theorem union_of_empty_family_is_empty_set:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U),
      MappingFamilyOfSets Xm IndexedFunction I XX /\ Xn = (IndexedSet Xm) -> ⋃ [ fun (i:U) => i ∈ {||} ] Xn = {||}.
  Proof.
    move => Xn Xu [[Hf HfS] H].
    rewrite H.
    apply /Extensionality_Ensembles.
    split => x H'.
    inversion H' as [x' [i' []]].
    inversion H0.
    inversion H'.
  Qed.

  Theorem intersection_of_empty_family_is_full_set:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U)
           (i:U),
      I={||} /\ i ∈ I /\ MappingFamilyOfSets Xm IndexedFunction I XX /\ Xn = (IndexedSet Xm) -> ⋂ [ fun (i:U) => i ∈ I ] Xn = Full_set U.
  Proof.
    move => Xm Xn i [HI [Hi [[Hf HfS] H]]].
    apply /Extensionality_Ensembles.
    split => x H'.
    done.
    rewrite HI in Hi.
    split => i'.
    split.
    move: Hi.
    case.
    move: Hi.
    case.
  Qed.

  Theorem intersection_of_empty_family_of_subset_is_full_set:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U)
           (i:U),
      I={||} /\ i ∈ I /\ MappingFamilyOfSubsets Xm IndexedFunction I X /\ Xn = (IndexedSet Xm) ->  ⋂ [ fun (i:U) => i ∈ I ] Xn = X.
  Proof.
    move => Xm Xn i [HI [Hi [[Hf HfS] H]]].
    apply /Extensionality_Ensembles.
    split => x H'.
    inversion H' as [x0].
    move: (H0 i) => [Hi0 Hi1].
    rewrite H in Hi1.
    inversion Hi1 as [x1 Xi []].
    rewrite Hf in H2.
    inversion H2 as [i' Xi' []].
    rewrite H7 in H6.
    apply ordered_pair_in_direct_product_iff_and in H6.
    inversion H6.
    inversion H9.
    apply H10.
    done.
    rewrite HI in Hi.
    split => i'.
    split.
    move: Hi.
    case.
    move: Hi.
    case.
  Qed.

  Theorem distr_union_of_family_of_sets:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U),
      MappingFamilyOfSets Xm IndexedFunction I XX /\ Xn = (IndexedSet Xm)
      -> ⋃ [ fun (i:U) => i ∈ I ] Xn ∩ Y = ⋃ [ fun (i:U) => i ∈ I ] (fun i:U => (Xn i) ∩ Y).
  Proof.
    move => Xm Xn [[Hf HfS] H].
    apply /Extensionality_Ensembles.
    split => x H'; inversion H'.
    inversion H0 as [x'].
    split.
    inversion H3 as [i].
    exists i.
    inversion H5.
    split.
    done.
    split; done.
    inversion H0 as [i].
    inversion H2.
    inversion H4.
    split.
    split.
    exists i.
    split; done.
    done.
  Qed.

  Theorem distr_intersection_of_family_of_sets:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U),
      MappingFamilyOfSets Xm IndexedFunction I XX /\ Xn = (IndexedSet Xm) /\ (forall (i x:U), i ∈ I /\ x ∈ Y)
      -> ⋂ [ fun (i:U) => i ∈ I ] Xn ∪ Y = ⋂ [ fun (i:U) => i ∈ I ] (fun i:U => (Xn i) ∪ Y).
  Proof.
    move => Xm Xn [[Hf HfS] [HXn HixY]].
    apply /Extensionality_Ensembles.
    +split => x H.
     inversion H.
     (* x ∈ ⋂ [fun i : U => i ∈ I] Xn -> x ∈ ⋂ [fun i : U => i ∈ I] (fun i : U => Xn i ∪ Y) *)
     inversion H0.
     split => i.
     move: (H2 i) => [Hi HXi].
     split.
     apply Hi.
     left.
     done.
     (* x ∈ Y -> x ∈ ⋂ [fun i : U => i ∈ I] (fun i : U => Xn i ∪ Y) *)
     split => i.
     move: (HixY i x) => [Hi HY].
     split.
     apply Hi.
     right.
     done.
    +have L1: (forall i:U, i ∈ I) /\ (forall x:U, x ∈ Y).
     apply forall_bound_variable_and_out_2.
     done.
     inversion L1.
     inversion H.
     have L2: (forall i:U, i ∈ I) /\ (forall (i:U), x ∈ (Xn i ∪ Y)).
     apply forall_bound_variable_and_dist_iff.
     done.
     inversion L2.
     have L3: forall (i:U), x ∈ (Xn i) \/ x ∈ Y.
     move => i.
     move: (H5 i).
     case => x1 H6; [left|right]; done.
     have L4: (forall (i:U), x ∈ (Xn i)) \/ x ∈ Y.
     apply or_comm.
     apply forall_bound_variable_or_out.
     move => i.
     apply or_comm.
     done.
     move: L4.
     case => H'.
     (* (forall i : U, x ∈ Xn i) -> x ∈ (⋂ [fun i : U => i ∈ I] Xn ∪ Y) *)
     left.
     split.
     apply forall_bound_variable_and_dist_iff.
     split.
     apply H4.
     done.
     (* (x ∈ Y) -> x ∈ (⋂ [fun i : U => i ∈ I] Xn ∪ Y) *)
     right.
     apply H'.
  Qed.

  Theorem de_morgan_in_union_intersecion_of_family_set_at_complement:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U),
      (forall (i:U), i ∈ I) /\ MappingFamilyOfSubsets Xm IndexedFunction I X /\ Xn = (IndexedSet Xm) ->
      (⋃ [ fun (i:U) => i ∈ I ] (fun (i:U) => Xn i)) ^c = ⋂ [ fun (i:U) => i ∈ I ] (fun (i:U) => (Xn i) ^c).
  Proof.
    move => Xm Xn [HiI [[Hf HfS] HXn]].
    apply /Extensionality_Ensembles.
    split => x H.
    split => i.
    split.
    apply HiI.
    move => HF.
    apply H.
    split.
    exists i.
    split.
    apply HiI.
    done.
    move => H'.
    inversion H.
    inversion H'.
    inversion H2 as [i].
    inversion H4.
    move: (H0 i) => [H0iI HxXni].
    apply HxXni.
    done.
  Qed.

  Theorem de_morgan_in_union_intersecion_of_family_set_at_complement_2:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U),
      (forall (i:U), i ∈ I) /\ MappingFamilyOfSubsets Xm IndexedFunction I X /\ Xn = (IndexedSet Xm) ->
      (⋃ [ fun (i:U) => i ∈ I ] (fun (i:U) => (Xn i)^c)) ^c = ⋂ [ fun (i:U) => i ∈ I ] (fun (i:U) => (Xn i)).
  Proof.
    move => Xm Xn [HiI [[Hf HfS] HXn]].
    apply /Extensionality_Ensembles.
    split => x H.
    split => i.
    split.
    apply HiI.
    rewrite -(Complement_Complement U (Xn i)).
    move => HF.
    apply H.
    split.
    exists i.
    split.
    apply HiI.
    done.
    move => H'.
    inversion H'.
    inversion H0 as [i].
    inversion H2.
    apply H4.
    inversion H.
    move: (H5 i) => H5'.
    inversion H5'.
    done.
  Qed.

  Theorem de_morgan_in_intersecion_union_of_family_set_at_complement:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U),
      (forall (i:U), i ∈ I) /\ MappingFamilyOfSubsets Xm IndexedFunction I X /\ Xn = (IndexedSet Xm) ->
      (⋂ [ fun (i:U) => i ∈ I ] (fun (i:U) => Xn i)) ^c = ⋃ [ fun (i:U) => i ∈ I ] (fun (i:U) => (Xn i) ^c).
  Proof.
    move => Xm Xn H.
    move: (de_morgan_in_union_intersecion_of_family_set_at_complement_2 H) => L0.
    have L1: ((⋃ [ fun (i:U) => i ∈ I ] (fun (i:U) => (Xn i) ^c)) ^c) ^c = ⋃ [ fun (i:U) => i ∈ I ] (fun (i:U) => (Xn i) ^c).
    apply Complement_Complement.
    rewrite -L1.
    rewrite L0.
    reflexivity.
  Qed.

  Theorem de_morgan_in_union_intersecion_of_family_set_at_setminus:
    forall (Xm:Ensemble (Ensemble (Ensemble (Ensemble U))))
           (Xn:U -> Ensemble U)
           (i:U),
      (forall (i:U), i ∈ I) /\ MappingFamilyOfSubsets Xm IndexedFunction I X /\ Xn = (IndexedSet Xm) ->
      X \ ⋃ [ fun (i:U) => i ∈ I ] Xn = ⋂ [ fun (i:U) => i ∈ I ] (fun (i:U) => X \ Xn i).
  Proof.
    move => Xm Xn i [HiI [Hf HXn]].
    apply /Extensionality_Ensembles.
    split => x H.
    inversion H.
    split => i'.
    split.
    apply HiI.
    split.
    apply H0.
    move => H'.
    apply H1.
    split.
    exists i'.
    split.
    apply HiI.
    done.
    inversion H.
    split.
    move: (H0 i) => [HiI' Hx].
    inversion Hx.
    apply H2.
    move => H'.
    inversion H'.
    inversion H2 as [i'].
    move: (H0 i') => [HiI' Hx].
    inversion Hx.
    apply H6.
    inversion H4.
    done.
  Qed.

End FamilyOfSetsTheories.


Require Import primRec.
Require Import cPair.
Require Import Arith.
Require Import folProp.
Require Import code.
Require Import extEqualNat.
Require Vector.

Section Code_Substitute_Term.

Variable L : Language.
Variable codeF : Functions L -> nat.

Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let var := var L.
Let apply := apply L.

Definition codeSubTermTerms : nat -> nat -> nat -> nat :=
  evalStrongRec 2
    (fun t recs v s : nat =>
     cPair
       (switchPR (cPairPi1 t)
          (cPair (cPairPi1 t) (cPairPi2 (codeNth (t - S (cPairPi2 t)) recs)))
          (switchPR (charFunction 2 beq_nat (cPairPi2 t) v) s t))
       (switchPR t
          (S
             (cPair (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
                (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs)))) 0)).

Definition codeSubTerm (t s v : nat) : nat :=
  cPairPi1 (codeSubTermTerms t s v).

Definition codeSubTerms (t s v : nat) : nat :=
  cPairPi2 (codeSubTermTerms t s v).

Lemma codeSubTermCorrect :
 forall (t : Term) (v : nat) (s : Term),
 codeSubTerm (codeTerm L codeF t) v (codeTerm L codeF s) =
 codeTerm L codeF (substituteTerm L t v s).
Proof.
set
 (g :=
  fun t0 recs v0 s0 : nat =>
  cPair
    (switchPR (cPairPi1 t0)
       (cPair (cPairPi1 t0) (cPairPi2 (codeNth (t0 - S (cPairPi2 t0)) recs)))
       (switchPR (charFunction 2 beq_nat (cPairPi2 t0) v0) s0 t0))
    (switchPR t0
       (S
          (cPair (cPairPi1 (codeNth (t0 - S (cPairPi1 (pred t0))) recs))
             (cPairPi2 (codeNth (t0 - S (cPairPi2 (pred t0))) recs)))) 0))
 in *.
intros.
elim t using
 Term_Terms_ind
  with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
           codeSubTerms (codeTerms L codeF n ts) v (codeTerm L codeF s) =
           codeTerms L codeF n (substituteTerms L n ts v s));
 intros.
simpl in |- *.
replace (codeTerm L codeF (fol.var L n)) with (cPair 0 n).
unfold codeSubTerm in |- *.
unfold codeSubTermTerms in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
simpl in |- *.
induction (eq_nat_dec v n).
rewrite a.
rewrite <- beq_nat_refl.
simpl in |- *.
reflexivity.
rewrite beq_nat_not_refl.
simpl in |- *.
reflexivity.
auto.
reflexivity.
simpl in |- *.
transitivity
 (cPair (S (codeF f))
    (codeTerms L codeF (arity L (inr (Relations L) f))
       (substituteTerms L (arity L (inr (Relations L) f)) t0 v s))).
rewrite <- H.
replace (codeTerm L codeF (fol.apply L f t0)) with
 (cPair (S (codeF f)) (codeTerms L codeF (arity L (inr (Relations L) f)) t0)).
generalize (codeF f) (codeTerms L codeF (arity L (inr (Relations L) f)) t0).
clear H t0 f.
intros.
unfold codeSubTerm in |- *.
unfold codeSubTermTerms in |- *.
fold g in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
unfold evalList in |- *.
rewrite computeEvalStrongRecHelp.
unfold compose2 in |- *.
unfold evalComposeFunc, evalOneParamList, evalList in |- *.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
assert
 (extEqual _
    (evalComposeFunc 2 1
       (Vector.cons _ (evalStrongRecHelp 2 g (cPair (S n) n0)) 0 (Vector.nil _))
       (fun b : nat => codeNth (cPair (S n) n0 - S n0) b))
    (evalStrongRec 2 g n0)).
apply (evalStrongRecHelp2 2).
apply cPairLt2.
simpl in H.
rewrite H.
clear H.
simpl in |- *.
reflexivity.
reflexivity.
reflexivity.
simpl in |- *.
unfold codeTerms in |- *.
unfold codeSubTerms in |- *.
unfold codeSubTermTerms in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
simpl in |- *.
transitivity
 (S
    (cPair (codeTerm L codeF (substituteTerm L t0 v s))
       (codeTerms L codeF n (substituteTerms L n t1 v s)))).
rewrite <- H.
rewrite <- H0.
replace (codeTerms L codeF (S n) (Tcons L n t0 t1)) with
 (S (cPair (codeTerm L codeF t0) (codeTerms L codeF n t1))).
generalize (codeTerm L codeF t0) (codeTerms L codeF n t1).
clear H0 t1 H t0 n.
intros.
unfold codeSubTerms at 1 in |- *.
unfold codeSubTermTerms in |- *.
fold g in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc, evalOneParamList, evalList in |- *.
rewrite computeEvalStrongRecHelp.
unfold compose2 in |- *.
unfold evalComposeFunc, evalOneParamList, evalList in |- *.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
assert
 (extEqual _
    (evalComposeFunc 2 1
       (Vector.cons _ (evalStrongRecHelp 2 g (S (cPair n n0))) 0 (Vector.nil _))
       (fun b : nat => codeNth (S (cPair n n0) - S n) b))
    (evalStrongRec 2 g n)).
apply (evalStrongRecHelp2 2).
apply le_lt_n_Sm.
apply cPairLe1.
simpl in H.
rewrite H.
clear H.
assert
 (extEqual _
    (evalComposeFunc 2 1
       (Vector.cons _ (evalStrongRecHelp 2 g (S (cPair n n0))) 0 (Vector.nil _))
       (fun b : nat => codeNth (S (cPair n n0) - S n0) b))
    (evalStrongRec 2 g n0)).
apply (evalStrongRecHelp2 2).
apply le_lt_n_Sm.
apply cPairLe2.
simpl in H.
rewrite H.
clear H.
simpl in |- *.
reflexivity.
reflexivity.
reflexivity.
Qed.

Lemma codeSubTermsCorrect :
 forall (n : nat) (ts : Terms n) (v : nat) (s : Term),
 codeSubTerms (codeTerms L codeF n ts) v (codeTerm L codeF s) =
 codeTerms L codeF n (substituteTerms L n ts v s).
Proof.
set
 (g :=
  fun t0 recs v0 s0 : nat =>
  cPair
    (switchPR (cPairPi1 t0)
       (cPair (cPairPi1 t0) (cPairPi2 (codeNth (t0 - S (cPairPi2 t0)) recs)))
       (switchPR (charFunction 2 beq_nat (cPairPi2 t0) v0) s0 t0))
    (switchPR t0
       (S
          (cPair (cPairPi1 (codeNth (t0 - S (cPairPi1 (pred t0))) recs))
             (cPairPi2 (codeNth (t0 - S (cPairPi2 (pred t0))) recs)))) 0))
 in *.
intros.
induction ts as [| n t ts Hrects].
simpl in |- *.
unfold codeTerms in |- *.
unfold codeSubTerms in |- *.
unfold codeSubTermTerms in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
simpl in |- *.
transitivity
 (S
    (cPair (codeTerm L codeF (substituteTerm L t v s))
       (codeTerms L codeF n (substituteTerms L n ts v s)))).
rewrite <- Hrects.
rewrite <- codeSubTermCorrect.
replace (codeTerms L codeF (S n) (Tcons L n t ts)) with
 (S (cPair (codeTerm L codeF t) (codeTerms L codeF n ts))).
generalize (codeTerm L codeF t) (codeTerms L codeF n ts).
clear Hrects ts t n.
intros.
unfold codeSubTerms at 1 in |- *.
unfold codeSubTermTerms in |- *.
fold g in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc, evalOneParamList, evalList in |- *.
rewrite computeEvalStrongRecHelp.
unfold compose2 in |- *.
unfold evalComposeFunc, evalOneParamList, evalList in |- *.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
assert
 (extEqual _
    (evalComposeFunc 2 1
       (Vector.cons _ (evalStrongRecHelp 2 g (S (cPair n n0))) 0 (Vector.nil _))
       (fun b : nat => codeNth (S (cPair n n0) - S n) b))
    (evalStrongRec 2 g n)).
apply (evalStrongRecHelp2 2).
apply le_lt_n_Sm.
apply cPairLe1.
simpl in H.
rewrite H.
clear H.
assert
 (extEqual _
    (evalComposeFunc 2 1
       (Vector.cons _ (evalStrongRecHelp 2 g (S (cPair n n0))) 0 (Vector.nil _))
       (fun b : nat => codeNth (S (cPair n n0) - S n0) b))
    (evalStrongRec 2 g n0)).
apply (evalStrongRecHelp2 2).
apply le_lt_n_Sm.
apply cPairLe2.
simpl in H.
rewrite H.
clear H.
simpl in |- *.
reflexivity.
reflexivity.
reflexivity.
Qed.

Lemma codeSubTermTermsIsPR : isPR 3 codeSubTermTerms.
Proof.
unfold codeSubTermTerms in |- *.
apply evalStrongRecIsPR.
apply
 compose4_2IsPR
  with
    (f1 := fun t recs v s : nat =>
           switchPR (cPairPi1 t)
             (cPair (cPairPi1 t)
                (cPairPi2 (codeNth (t - S (cPairPi2 t)) recs)))
             (switchPR (charFunction 2 beq_nat (cPairPi2 t) v) s t))
    (f2 := fun t recs v s : nat =>
           switchPR t
             (S
                (cPair (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
                   (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs)))) 0).
apply
 compose4_3IsPR
  with
    (f1 := fun t recs v s : nat => cPairPi1 t)
    (f2 := fun t recs v s : nat =>
           cPair (cPairPi1 t) (cPairPi2 (codeNth (t - S (cPairPi2 t)) recs)))
    (f3 := fun t recs v s : nat =>
           switchPR (charFunction 2 beq_nat (cPairPi2 t) v) s t).
apply filter1000IsPR with (g := cPairPi1).
apply cPairPi1IsPR.
apply
 filter1100IsPR
  with
    (g := fun t recs : nat =>
          cPair (cPairPi1 t) (cPairPi2 (codeNth (t - S (cPairPi2 t)) recs))).
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat => cPairPi1 t)
    (g := fun t recs : nat => cPairPi2 (codeNth (t - S (cPairPi2 t)) recs)).
apply filter10IsPR with (g := cPairPi1).
apply cPairPi1IsPR.
apply
 compose2_1IsPR
  with (f := fun t recs : nat => codeNth (t - S (cPairPi2 t)) recs).
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat => t - S (cPairPi2 t))
    (g := fun t recs : nat => recs).
apply filter10IsPR with (g := fun t : nat => t - S (cPairPi2 t)).
apply
 compose1_2IsPR
  with (f := fun t : nat => t) (f' := fun t : nat => S (cPairPi2 t)).
apply idIsPR.
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply cPairPi2IsPR.
apply cPairIsPR.
apply
 filter1011IsPR
  with
    (g := fun t v s : nat =>
          switchPR (charFunction 2 beq_nat (cPairPi2 t) v) s t).
apply
 compose3_3IsPR
  with
    (f1 := fun t v s : nat => charFunction 2 beq_nat (cPairPi2 t) v)
    (f2 := fun t v s : nat => s)
    (f3 := fun t v s : nat => t).
apply
 filter110IsPR
  with (g := fun t v : nat => charFunction 2 beq_nat (cPairPi2 t) v).
apply
 compose2_2IsPR
  with (f := fun t v : nat => cPairPi2 t) (g := fun t v : nat => v).
apply filter10IsPR.
apply cPairPi2IsPR.
apply pi2_2IsPR.
apply eqIsPR.
apply pi3_3IsPR.
apply pi1_3IsPR.
apply switchIsPR.
apply switchIsPR.
apply
 filter1100IsPR
  with
    (g := fun t recs : nat =>
          switchPR t
            (S
               (cPair (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
                  (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs)))) 0).
apply
 compose2_3IsPR
  with
    (f1 := fun t recs : nat => t)
    (f2 := fun t recs : nat =>
           S
             (cPair (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
                (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs))))
    (f3 := fun t recs : nat => 0).
apply pi1_2IsPR.
apply
 compose2_1IsPR
  with
    (f := fun t recs : nat =>
          cPair (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
            (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs))).
assert
 (forall g : nat -> nat,
  isPR 1 g ->
  isPR 2 (fun t recs : nat => g (codeNth (t - S (g (pred t))) recs))).
intros.
apply
 compose2_1IsPR
  with (f := fun t recs : nat => codeNth (t - S (g (pred t))) recs).
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat => t - S (g (pred t)))
    (g := fun t recs : nat => recs).
apply filter10IsPR with (g := fun t : nat => t - S (g (pred t))).
apply
 compose1_2IsPR
  with (f := fun t : nat => t) (f' := fun t : nat => S (g (pred t))).
apply idIsPR.
apply compose1_1IsPR with (f := fun t : nat => g (pred t)).
apply compose1_1IsPR.
apply predIsPR.
auto.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
auto.
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat =>
          cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
    (g := fun t recs : nat =>
          cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs)).
apply H.
apply cPairPi1IsPR.
apply H.
apply cPairPi2IsPR.
apply cPairIsPR.
apply succIsPR.
exists (composeFunc 2 0 (PRnil _) zeroFunc).
simpl in |- *.
auto.
apply switchIsPR.
apply cPairIsPR.
Qed.

Lemma codeSubTermIsPR : isPR 3 codeSubTerm.
Proof.
unfold codeSubTerm in |- *.
apply compose3_1IsPR.
apply codeSubTermTermsIsPR.
apply cPairPi1IsPR.
Qed.

Lemma codeSubTermsIsPR : isPR 3 codeSubTerms.
Proof.
unfold codeSubTerms in |- *.
apply compose3_1IsPR.
apply codeSubTermTermsIsPR.
apply cPairPi2IsPR.
Qed.

End Code_Substitute_Term.


(* -------------------------------------------------------------------- *)
Require Import ssreflect eqtype ssrbool ssrnat ssrfun path.

(* -------------------------------------------------------------------- *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* -------------------------------------------------------------------- *)
(* For this section:                                                    *)
(*   only move=> h, move/V: h => h, case/V: h, by ... allowed           *)
(* -------------------------------------------------------------------- *)
Goal forall (P Q : Prop), (P <-> Q) -> P -> Q.
Proof.
  move=> P Q. case => Hpq Hqp. by move/Hpq.
Qed.

Goal forall (P : nat -> Prop) (Q : Prop),
     (P 0 -> Q)
  -> (forall n, P n.+1 -> P n)
  -> P 4 -> Q.
Proof.
  move=> P Q H1 H2. by do ?move/H2.
Qed.

Goal forall (b b1 b2 : bool), (b1 -> b) -> (b2 -> b) -> b1 || b2 -> b.
Proof. (* No case analysis on b, b1, b2 allowed *)
  move=> b b1 b2 H1 H2 H.
  case/orP: H.
    by move/H1.
    by move/H2.
Qed.

Goal forall (Q : nat -> Prop) (p1 p2 : nat -> bool) x,
  ((forall y, Q y -> p1 y /\ p2 y) /\ Q x) -> p1 x && p2 x.
Proof.
  move=> Q p1 p2 n H.
  case: H. move=> H. move/H.
  by move/andP.
Qed.

Goal forall (Q : nat -> Prop) (p1 p2 : nat -> bool) x,
  ((forall y, Q y -> p1 y \/ p2 y) /\ Q x) -> p1 x || p2 x.
Proof.
  move=> Q p1 p2 x H.
  case: H. move=> H. move/H.
  by move/orP.
Qed.

(* -------------------------------------------------------------------- *)
(* No xxxP lemmas allowed                                               *)
(* -------------------------------------------------------------------- *)
Print reflect.
Lemma myidP: forall (b : bool), reflect b b.
Proof.
  case.
    exact: ReflectT.
    exact: ReflectF.
Qed.

Lemma mynegP: forall (b : bool), reflect (~ b) (~~ b).
Proof.
  case.
    exact: ReflectF.
    exact: ReflectT.
Qed.

Lemma myandP: forall (b1 b2 : bool), reflect (b1 /\ b2) (b1 && b2).
Proof.
  move=> b1 b2. case: b1.
  case: b2.
    exact: ReflectT.
    apply: ReflectF. move=> h. by case h.
  case: b2.
    apply: ReflectF. move=> h. by case h.
    apply: ReflectF. move=> h. by case h.
Qed.

Lemma myiffP:
  forall (P Q : Prop) (b : bool),
    reflect P b -> (P -> Q) -> (Q -> P) -> reflect Q b.
Proof.
  move=> P Q b Pb PQ QP.
  move: Pb. case: b.
    case.
      move/PQ => hp. by apply: ReflectT.
      move=> hNp. apply: ReflectF. move/QP => hp. by move/hNp: hp.
    case.
      move/PQ => hp. by apply: ReflectT.
      move=> hNp. apply: ReflectF. move/QP => hp. by move/hNp: hp.
Qed.

(* -------------------------------------------------------------------- *)
Fixpoint len (n m : nat) : bool :=
  match n, m with
  | 0    , _     => true
  | n'.+1, 0     => false
  | n'.+1, m'.+1 => len n' m'
  end.

Lemma lenP: forall n m, reflect (exists k, k + n = m) (len n m).
Proof.
  move=> n; elim: n.
    move=> m. apply: (iffP idP).
      move=> _. by exists m.
      by [].
    move=> n IH m. apply: (iffP idP).
      case: m. by [].
        move=> m /= le_nm. move/IH: le_nm=> le_nm.
        case: le_nm. move=> k eq_xk_m. exists k.
        by rewrite -eq_xk_m addnS.
      case: m.
        case. move=> k. by rewrite addnS.
        move=> m h. case: h => k.
        rewrite addnS. move=> eq_kSn_k. case: eq_kSn_k.
        move=> eq_kn_m. apply/IH. by exists k.
Qed.

(* --------------------------------------------------------------------*)
Lemma snat_ind : forall (P : nat -> Prop),
  (forall x, (forall y, y < x -> P y) -> P x)
  -> forall x, P x.
Proof.
  (* Hint: strengthen P x into (forall y, y <= x -> P x) and then
   *       perform the induction on x. *)
  move=> P ind x; move: {-2}x (leqnn x); elim: x.
    + move=> x. rewrite leqn0. move/eqP=> z_x.
      rewrite z_x. by apply: ind.
    + move=> n IHn x. rewrite leq_eqVlt. move=> h. case/orP: h.
      * move=> eq_x_Sn. rewrite (eqP eq_x_Sn). apply ind.
        move=> y. rewrite ltnS. by move/IHn.
      * rewrite ltnS. by move/IHn.
Qed.

Lemma odd_ind : forall (P : nat -> Prop),
  P 0 -> P 1 -> (forall x, P x  -> P x.+2)
  -> forall x, P x.
Proof.
  move=> P p0 p1 ind. elim/snat_ind.
  move=> x; case: x.
    + by [].
    + move=> x; case: x.
      * by [].
      * move=> x h. apply ind. by apply h.
Qed.

Lemma oddSS : forall n, odd n.+2 = odd n.
Proof.
  move=> n. by rewrite /= negbK.
Qed.

Lemma odd_add : forall m n, odd (m + n)  = odd m (+) odd n. (* using odd_ind *)
Proof.
  elim/odd_ind.
    by [].
    by [].
    move=> M IHm n. by rewrite !oddSS IHm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma nat_ind2: forall (P : nat -> Prop),
  P 0 -> P 1 -> (forall p, P p -> P p.+1 -> P p.+2)
  -> forall n, P n.
Proof.
  move=> P p0 p1 ind. elim/snat_ind.
  move=> x; case: x.
    + by [].
    + move=> x; case: x.
      * by [].
      * move=> x h. apply ind.
        by apply h. by apply h.
Qed.

Fixpoint fib n :=
  match n with
  | 0              => 1
  | 1              => 1
  | (n.+1 as p).+1 => fib p + fib n
  end.

Lemma fib0: fib 0 = 1.
Proof. by []. Qed.

Lemma fib1: fib 1 = 1.
Proof. by []. Qed.

Lemma fibSS: forall n, fib n.+2 = fib n.+1 + fib n.
Proof. by []. Qed.

Goal
  forall p q,
    (fib (p.+1 + q.+1))
    = (fib p.+1) * (fib q.+1) + (fib p) * (fib q).
Proof.
  elim/nat_ind2.
    move=> q. by rewrite add1n fib1 fib0 !mul1n fibSS.
    move=> q. rewrite add2n !fibSS !fib1 !fib0.
    by rewrite add1n mul2n mul1n -addnn addnAC.
    move=> p IHp IHSp q.
    rewrite 2!addSn fibSS -addSn IHp IHSp.
    rewrite !fibSS !mulnDl -!addnA.
    by rewrite (addnCA (fib p.+1 * fib q) _ _).
Qed.

(*
*** Local Variables: ***
*** coq-load-path: ("ssreflect" ".") ***
*** End: ***
 *)


(* These exercises require inductive proofs. *)
(* Now that you have some experience with Coq,
   you can use 'auto' tactic to avoid solving simple subgoals manually. *)

Require Import b1.
Require Import b2.
Require Import List.
Require Import Nat.
Require Import Lia.
Import ListNotations.

Section NatDict'Proofs.
  Context {V: Type}.

  (* Prove that 'remove' operation actually removes a key. *)
  (* The list inside nat_dict_list consists of pairs.
     To extract components of such list's head,
     either perform pattern matching in 'induction' tactics
     or directly 'destruct' the element of nat*V type. *)
  Lemma removed_not_contained (d: @nat_dict_list V) (n: nat):
    contains'' (remove'' d n) n = false.
  Proof. induction d. reflexivity. destruct a as [aF aS].
   destruct (Nat.eqb aF n) eqn: H.
  {unfold remove''. rewrite H. apply IHd. }
  unfold remove''. rewrite H. unfold contains''. simpl. rewrite H. apply IHd.  Qed.

  (* Define a mapping function similar to one defined for regular lists.
     It should replace values stored in dict but keep them under the same keys. *)
  Fixpoint map'' {W: Type} (f: V -> W) (d: @nat_dict_list V): @nat_dict_list W :=
    match d with
    | [] => []
    | (k, v) :: xs => (k, f v) :: map'' f xs
    end.

  (* Prove that a value stored in a mapped dict
     requires a corresponding value stored in an original dict. *)
  Lemma dict_map_get {W: Type} (m: V -> W) (d: @nat_dict_list V):
    forall n w,
      (get'' (map'' m d) n = Some w) <->
      (exists v, get'' d n = Some v /\ m v = w).
  Proof. unfold iff. split.
  { induction d.
    {simpl. intros. exfalso. inversion H.    }
    {
      destruct a as [aF aS].
      destruct (Nat.eqb aF n) eqn: H.
      {
        unfold get''.
        rewrite H.
        unfold map''.
        rewrite H.
        intros.
        exists aS.
        split.
        {reflexivity. }
        inversion H0.
        reflexivity.
      }
      {
        unfold get''.
        rewrite H.
        unfold map''.
        rewrite H.
        apply IHd.
      }
    }
  }
  {
    induction d.
    { simpl. intros.  inversion H. exfalso. inversion H0.  inversion H1. }
    {
      destruct a as [aF aS].
      destruct (Nat.eqb aF n) eqn: H; unfold get''; rewrite H;
      unfold map'';
      rewrite H.
      {
        intros.
        inversion H0.
        inversion H1.
        inversion H2 in H3.
        rewrite <- H5 in H3.
        rewrite <- H5.
        inversion H3.
        reflexivity.
      }
      {
        apply IHd.
      }
    }
  } Qed.

  (* Implement a filtering function.
     The result should contain only those keys whose values satisfy the predicate;
     in this case they remain unchanged. *)
  Fixpoint filter'' {U: Type} (f: U -> bool) (d: @nat_dict_list U): @nat_dict_list U :=
      match d with
      | [] => []
      | (k, v) :: xs => let tail := remove'' (filter'' f xs) k in
                        if f v
                        then
                          (k, v) :: tail
                        else
                          tail
      end.

(*...*)

  Lemma insert_others' (d: @nat_dict_list V):
  forall n v n', n <> n' -> get'' (insert'' d n v) n' = get'' d n'.
  Proof.
     intros.
     simpl.
     rewrite <- PeanoNat.Nat.eqb_neq in H.
     rewrite H.
     induction d.
     {
       simpl.
       reflexivity.
     }
     {
       destruct a as [aF aS].
       destruct (eqb aF n) eqn: H1.
       {simpl.
       rewrite H1.
       rewrite PeanoNat.Nat.eqb_eq in H1.
       rewrite <- H1 in H.
       rewrite H.
       auto. }
       simpl.
       rewrite H1.
       {
        destruct (eqb aF n') eqn: H2.
        {
          simpl.
          rewrite H2.
          auto.
        }
        {
         simpl.
         rewrite H2.
         auto.
        }
       }

     } Qed.

  Lemma contains_remove (d: @nat_dict_list V):
    forall a b : nat, (Nat.eqb a b = false) -> ((contains'' (remove'' d a) b = true )
      <-> (contains'' (d) b = true)).
  Proof.
    intros.
    induction d.
    {
     simpl.
     reflexivity.
    }
    {
      destruct a0 as [aF aS].
      destruct (Nat.eqb aF a) eqn:eqT.
      {
        simpl.
        rewrite eqT.
        apply PeanoNat.Nat.eqb_eq in eqT as eqCoq.

        (* Search Nat.eqb. *)

        (* Nat.eqb aF a = true -> Af = a *)
        (* apply Nat.eqb_implies_eq in eqT as eqCoq. *)
        rewrite <- eqCoq in H.
        unfold contains''.
        simpl.

        rewrite H.
        apply IHd.
      }
      {
        unfold remove''.
        rewrite eqT.
        unfold contains''.
        unfold get''.
        destruct (Nat.eqb aF b) eqn:eqTB.
        {reflexivity. }
        apply IHd.

      }

    } Qed.

  (* Prove that the result of filtering is actually filtered *)
  Lemma filter_elem (f: V -> bool) (d: @nat_dict_list V):
    forall n,
      (contains'' (filter'' f d) n = true) <->
      (exists v, get'' d n = Some v /\ f v = true).
  Proof.
    induction d; simpl; unfold iff; split.
    1, 2: intros; exfalso; inversion H.
    {inversion H0. inversion H1. }
    {
      destruct a as [aF aS].
      destruct (Nat.eqb aF n) eqn:eqT; destruct (f aS) eqn:fT.
      {
        eauto.
      }
      intros H.
      (* remember eqT as eqNat. *)
      apply PeanoNat.Nat.eqb_eq in eqT as eqCoq.
      subst.
      rewrite removed_not_contained in H.
      exfalso.
      inversion H.
      {
        apply PeanoNat.Nat.eqb_neq in eqT as eqCoq.
        simpl.

        inversion eqT.
        unfold contains''.
        simpl.
        rewrite eqT.
        intros LeftPart.
        apply contains_remove in LeftPart.
        2: auto.
        apply IHd in LeftPart.
        auto.
      }
      intros LeftPart.
      apply contains_remove in LeftPart.
      2: auto.

      apply IHd in LeftPart.
      auto.
    }
    {
      destruct a as [aF aS].
      destruct (Nat.eqb aF n) eqn:eqT; destruct (f aS) eqn:fT.
      {
        unfold contains''.
        unfold get''.
        rewrite eqT.
        auto.
      }
      {
        intros EX.
        exfalso.
        inversion EX.
        inversion H.
        inversion H0.
        subst.
        rewrite H1 in fT.
        inversion fT.
      }
      {
        intros.
        apply IHd in H.
        unfold contains''.
        unfold get''.
        rewrite eqT.
        fold (get'' (remove'' (filter'' f d) aF) n).
        fold (contains'' (remove'' (filter'' f d) aF) n).
        apply contains_remove; auto.
      }
      {
        intros.
        apply IHd in H.
        unfold contains''.
        unfold get''.
        apply contains_remove; auto.
      }

    }
    Qed.

  (* You (most probably) implemented list-based dictionary in a way
     that doesn't distinguish, say, [(1, 2), (3, 4)] and [(3, 4), (1, 2)] dicts. *)
  (* That is, the results of 'insert', 'contains' and other interface operations
     should be the same for them. *)
  (* Such lists are not-equal, though,
     since the only list equal to [(1, 2), (3, 4)] is exactly [(1, 2), (3, 4)]. *)
  (* We can formalize the specific notion of equivalence for dictionaries
     to prove their more complicated properties. *)
  (* Note that this equ ivalence only deals with dict interface
     and not the particular implementation. *)
  Definition sim_dicts (d1 d2: @nat_dict_list V) :=
    forall n, get'' d1 n = get'' d2 n.

(*...*)

  Lemma get_remove_differrent:
    forall d: @nat_dict_list V,forall  k n: nat,  Nat.eqb k n = false -> get'' d n = get'' (remove'' d k) n.
  Proof.
    intros.
    induction d.
    {simpl. reflexivity. }
    destruct a as [PF PS].
    destruct (Nat.eqb PF n) eqn:EqN.
    {
      simpl.
      rewrite EqN.

     apply PeanoNat.Nat.eqb_eq  in EqN as EqK.
     rewrite <- EqK in H.
     rewrite PeanoNat.Nat.eqb_sym in H.

     rewrite H.
     simpl.
     rewrite EqN.
     reflexivity.
    }
    {
      unfold get''.
      unfold remove''.
      rewrite EqN.
      destruct (Nat.eqb PF k) eqn:EqK; try rewrite EqN; apply IHd.

    }

  Qed.

  Lemma sim_dicts_trans_eq:
    forall d1 d2 k v,
      sim_dicts d1  d2
          -> sim_dicts ((k, v) :: d1) ((k, v) :: d2)
  .
  Proof.
    intros.
    unfold sim_dicts in *.
    intros.
    simpl.
    destruct (eqb k n) eqn: H1; auto.

  Qed.

  Lemma sim_dicts_trans :
    forall d1 d2 d, sim_dicts d1 d -> sim_dicts d d2 -> sim_dicts d1 d2.

  Proof.
      unfold sim_dicts in *.
      intros.
      apply eq_trans with  (y := get'' d n); auto.
  Qed.

  Lemma sim_dicts_insertion:
  forall d1 d2 k v, sim_dicts d1 d2 -> sim_dicts (insert'' d1 k v) (insert'' d2 k v)
  .
  Proof.
    intros.
    unfold sim_dicts.
    intros.
    destruct (Nat.eqb k n) eqn:Eq; auto.
    {
      simpl.
      rewrite Eq.
      auto.
    }
    {
      rewrite insert_others'.
      2: {apply PeanoNat.Nat.eqb_neq  in Eq. auto. }
      apply eq_sym.
      rewrite insert_others'.
      2: {apply PeanoNat.Nat.eqb_neq  in Eq. auto. }

      apply eq_sym.
      apply H.

    } Qed.

  Lemma remove_remove_with_same:
  forall (d: @nat_dict_list V) k, remove'' (remove'' d k) k = remove'' d k.
  Proof.
    intros.
    induction d.
    {
      simpl.
      reflexivity.
    }
    {
      destruct a as [aF aS].
      destruct (eqb aF k) eqn:EqK.
      {
        simpl.
        rewrite EqK.
        apply IHd.
      }
      simpl.
      rewrite EqK.
      simpl.
      rewrite EqK.
      rewrite IHd.
      reflexivity.

    } Qed.

  Lemma insert_remove_eq:
  forall (d: @nat_dict_list V) k v, insert'' (remove'' d k) k v = insert'' d k v
  .
  Proof.
    intros.
    induction d.
    {
      simpl.
      reflexivity.
    }
    {
      destruct a as [aF aS].
      destruct (eqb aF k) eqn:EqK.
      {
        simpl.
        rewrite EqK.
        rewrite IHd.
        unfold insert''.
        simpl.
        rewrite EqK.
        reflexivity.
      }
      {
        simpl.
        rewrite EqK.
        unfold insert''.
        simpl.
        rewrite EqK.
        rewrite remove_remove_with_same.
        reflexivity.
      }

    }

  Qed.

  (* Prove that an insertion makes a preceding removal pointless.
     To ease the proof, you may want to prove separately that:
     - sim_dicts relation is transitive
     - an insertion of the same key-value pair preserves sim_dicts
     - a double insertion of the same key-value pair
       is similar (in terms of sim_dicts) to a single insertion
     - insertions of separate keys commute
       (that is, their results are related by sim_dicts).
     Also, it can be easier to operate on level of a higher level of 'insert's
     instead of a lower level of list 'cons'es.
     To replace 'cons' with 'insert', use 'fold' tactic.
*)
  Lemma insert_remove_simpl (d: @nat_dict_list V) (n: nat) (v: V):
    sim_dicts (insert'' (remove'' d n) n v) (insert'' d n v).
  Proof.
    rewrite insert_remove_eq.
    unfold sim_dicts.
    reflexivity.
  Qed.

End NatDict'Proofs.


Require Import Coq.Lists.List. Import ListNotations.

Require Import
        Coq.Bool.Bool
        Coq.Strings.Ascii
        Coq.Strings.String.

Local Open Scope string.
Local Open Scope char.

From SRC Require Export CStrings.

(* Act II - Scene 0, Before Semirings *)

Inductive regex : Type :=
  | Eps : regex
  | Sym : bool -> ascii -> regex
  | Alt : regex -> regex -> regex
  | Seq : regex -> regex -> regex
  | Rep : regex -> regex.

Fixpoint empty (x : regex) : bool :=
  match x with
    | Eps => true
    | Sym _ _ => false
    | Alt p q => empty p || empty q
    | Seq p q => empty p && empty q
    | Rep r => true
  end.

Fixpoint final (x : regex) : bool :=
  match x with
    | Eps => false
    | Sym b _ => b
    | Alt p q => final p || final q
    | Seq p q => final p && empty q || final q
    | Rep r => final r
  end.

Fixpoint shift (m : bool) (x : regex) (c : ascii)
  : regex :=
  match x with
    | Eps => Eps
    | Sym _ x =>
      Sym (m && (eq_ascii x c)) x
    | Alt p q =>
      Alt (shift m p c) (shift m q c)
    | Seq p q =>
      Seq (shift m p c)
          (shift (m && empty p || final q) q c)
    | Rep r =>
      Rep (shift (m || final r) r c)
  end.

Definition rmatch' (r : regex) (s : lstring) : bool :=
  match s with
    | [] => empty r
    | (c :: cs) =>
      final (fold_left (shift false) cs (shift true r c))
  end.

Definition rmatch (r : regex) (s : string) : bool :=
  rmatch' r (str_to_lstr s).

Compute shift true (Seq (Sym false "a") (Rep (Sym false "b"))) "a".
Compute shift true (Seq (Sym true "a") (Rep (Sym false "b"))) "b".
Compute rmatch (Seq (Sym true "a") (Sym false "b")) "ab".


(** A library of relation operators defining sequences of transitions
  and useful properties about them. *)

Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Stream.
Import ListNotations.

Section Sequences_Traces.
  Variable A E: Type.                 (**r the type of states *)
  Variable R: A -> list E -> A -> Prop.       (**r the transition relation, from one state to the next *)

  (** ** Finite sequences of transitions *)

  (** Zero, one or several transitions: reflexive, transitive closure of [R]. *)

  Inductive star : A -> list E -> A -> Prop :=
  | star_refl: forall a,
      star a nil a
  | star_step : forall a b c l1 l2,
      R a l1 b -> star b l2 c -> star a (l1 ++ l2) c
  .

  Lemma star_one:
    forall (a b: A) l, R a l b -> star a l b.
  Proof.
    intros a b l H.
    replace l with (l ++ []); try now rewrite app_nil_r.
    apply star_step with (b := b);
      eauto using star.
  Qed.

  Lemma starans:
    forall (a b: A) (lab : list E), star a lab b ->
                               forall c (lbc : list E), star b lbc c -> star a (lab ++ lbc) c.
  Proof.
    intros a b lab Hab.
    induction Hab; intros.
    assumption.
    rewrite <- app_assoc.
    eapply star_step. eassumption.
    apply IHHab. eassumption.
  Qed.

  (** One or several transitions: transitive closure of [R]. *)

  Inductive plus: A -> list E -> A -> Prop :=
  | plus_left : forall a b c l l',
      R a l b -> star b l' c -> plus a (l ++ l') c.

  Lemma plus_one:
    forall a b l, R a l b -> plus a l b.
  Proof.
    intros a b l H.
    replace l with (l ++ []);
      eauto using star, plus.
    now rewrite app_nil_r.
  Qed.

  Lemma plus_star:
    forall a b l,
      plus a l b -> star a l b.
  Proof.
    intros. inversion H; eauto using star.
  Qed.

  Lemma plus_starans:
    forall a b c lab lbc, plus a lab b -> star b lbc c ->
                     plus a (lab ++ lbc) c.
  Proof.
    intros. inversion H; subst; eauto using plus, starans.
    rewrite <- app_assoc.
    eapply plus_left. eassumption.
    eapply starans; eauto.
  Qed.

  Lemma star_plusans:
    forall a b c lab lbc, star a lab b -> plus b lbc c ->
                     plus a (lab ++ lbc) c.
  Proof.
    intros.
    inversion H0; inversion H; subst;
      eauto using plus_left, plus, star, starans.
    rewrite <- app_assoc.
    eapply plus_left; eauto using star, starans.
  Qed.

  Lemma plus_right:
    forall a b c l l', star a l b -> R b l' c -> plus a (l ++ l') c.
  Proof.
    intros a b c l  l' H H0.
    eapply star_plusans. eauto. apply plus_one; eauto.
  Qed.

  (** ** Infinite sequences of transitions *)

  Variable measure: A -> nat.                  (**r the anti-stuttering measure *)

  (* Infinite execution: either produces the whole stream, or a prefix and then
     silent divergence *)
  CoInductive infseq: @stream E -> A -> Prop :=
  | infseq_step: forall a s b l,
      R a l b -> infseq s b -> infseq (Stream.app_list_stream l s) a.

  (* CF CompCert smallstep file *)
  CoInductive infseq_N : @stream E -> nat -> A -> Prop :=
  | infseq_N_star : forall a b n1 n2 l s,
      n2 < n1 ->
      star a l b ->
      infseq_N s n2 b ->
      infseq_N (Stream.app_list_stream l s) n1 a
  | infseq_N_plus : forall a b n1 n2 l s,
      plus a l b ->
      infseq_N s n2 b ->
      infseq_N (Stream.app_list_stream l s) n1 a.

  Lemma infseq_N_inv : forall n s a,
      infseq_N s n a ->
      exists l, exists s', exists n', exists a',
              R a l a' /\ infseq_N s' n' a' /\ Stream.app_list_stream l s' = s.
  Proof.
    intros n. pattern n.
    eapply well_founded_ind with (R := lt).
    apply PeanoNat.Nat.lt_wf_0.
    intros x H s a H0.
    inversion H0; subst; clear H0.
    - inversion H2; subst; clear H2.
      + apply H with n2. now apply H1.
        apply H3.
      + exists l1. exists (app_list_stream l2 s0). exists x. exists b0.
        repeat split; eauto.
        eapply infseq_N_star; eauto.
        clear.
        induction l1; eauto.
        simpl; now rewrite IHl1.
    - inversion H1; subst; clear H1.
      exists l0, (app_list_stream l' s0), n2, b0.
      repeat split; eauto.
      inversion H3; subst; clear H3.
      assumption.
      eapply infseq_N_plus; eauto.
      econstructor; eauto.
      clear.
      induction l0; eauto.
      simpl; now rewrite IHl0.
  Qed.

  Lemma infseq_N_infseq :
    forall a s n, infseq_N s n a -> infseq s a.
  Proof.
    cofix Hfix.
    intros a s n H.
    destruct (infseq_N_inv H) as [l [s' [n' [a' [HR [Hinf Heq]]]]]].
    subst.
    apply infseq_step with (b := a').
    eauto.
    eapply Hfix; eauto.
  Qed.

  Lemma infseq_infseq_N :
    forall a n s, infseq s a -> infseq_N s n a.
  Proof.
    cofix Hfix.
    intros a n s H.
    inversion H; subst.
    eapply infseq_N_plus with (n2 := 0).
    replace l with (l ++ []) by now rewrite app_nil_r.
    econstructor. eauto. econstructor.
    eapply Hfix. eauto.
  Qed.

  (* Now, we can start defining interesting notions of infseq.
     [infseq_prod s a] means that [a] actually produces the stream [s]*)
  CoInductive infseq_prod : @stream E -> A -> Prop :=
  | infseq_prod_star: forall a b l s,
      star a l b ->
      l <> [] ->
      infseq_prod s b ->
      infseq_prod (app_list_stream l s) a
  .

  Lemma star_infseq_prod : forall a b l s,
      star a l b ->
      infseq_prod s b ->
      infseq_prod (app_list_stream l s) a.
  Proof.
    intros a b l s H H0.
    inversion H0; subst.
    assert (star a (l ++ l0) b0) by now eapply starans; eauto.
    replace (app_list_stream l (app_list_stream l0 s0)) with (app_list_stream (l ++ l0) s0).
    econstructor; eauto.
    now destruct l, l0.
    clear.
    induction l; auto.
    now simpl; rewrite IHl.
  Qed.

  Lemma star_inv : forall a l b,
      star a l b ->
      (a = b /\ l = []) \/ plus a l b.
  Proof.
    intros a l b H.
    inversion H; subst; clear H.
    - left; auto.
    - right; econstructor; eauto.
  Qed.

  Lemma star_infseq : forall a l b s,
      star a l b ->
      infseq s b ->
      infseq (app_list_stream l s) a.
  Proof.
    intros a l b s H H0.
    induction H.
    - eauto.
    - rewrite app_list_stream_app.
      now econstructor; eauto.
  Qed.

  Lemma infseq_prod_infseq : forall s a,
      infseq_prod s a ->
      infseq s a.
  Proof.
    assert (forall s a n, infseq_prod s a -> infseq_N s n a).
    {
      cofix Hfix.
      intros s a n H.
      inversion H; subst.
      destruct l as [| e l]; try congruence.
      replace (app_list_stream (e :: l) s0) with (app_list_stream ([e] ++ l) s0) in H by reflexivity.
      destruct (star_inv H0) as [[] |]; try congruence.
      inversion H3; subst; clear H3.
      rewrite app_list_stream_app.
      eapply infseq_N_plus.
      - eapply plus_one. eauto.
      - eapply Hfix.
        replace ([e] ++ l) with (e :: l) in H by reflexivity.
        rewrite <- H4 in H.
        eapply star_infseq_prod.
        eauto. eauto.
    }
    intros s a H0.
    eapply infseq_N_infseq.
    eapply H.
    eassumption.
    Unshelve.
    all: exact 0.
  Qed.

  (* Infinitely many silent steps *)
  CoInductive infseq_silent: A -> Prop :=
  | infseq_silent_step: forall a b,
      R a [] b -> infseq_silent b -> infseq_silent a.

  (* CF CompCert smallstep file *)
  CoInductive infseq_silent_N : nat -> A -> Prop :=
  | infseq_silent_N_star : forall a b n1 n2 ,
      n2 < n1 ->
      star a [] b ->
      infseq_silent_N n2 b ->
      infseq_silent_N n1 a
  | infseq_silent_N_plus : forall a b n1 n2,
      plus a [] b ->
      infseq_silent_N n2 b ->
      infseq_silent_N n1 a.

  Lemma infseq_silent_N_inv : forall n a,
      infseq_silent_N n a ->
      exists n', exists a',
          R a [] a' /\ infseq_silent_N n' a'.
  Proof.
    intros n. pattern n.
    eapply well_founded_ind with (R := lt).
    apply PeanoNat.Nat.lt_wf_0.
    intros x H a H0.
    inversion H0; subst; clear H0.
    - inversion H2; subst; clear H2.
      + apply H with n2. now apply H1.
        apply H3.
      + exists x. exists b0.
        assert (Heq: l1 = [] /\ l2 = []) by now apply app_eq_nil.
        destruct Heq; subst.
        split; auto.
        eapply infseq_silent_N_star; eauto.
    - inversion H1; subst; clear H1.
      exists n2, b0.
      assert (Heq: l = [] /\ l' = []) by now apply app_eq_nil.
      destruct Heq; subst.
      split; auto.
      inversion H5; subst; clear H5.
      assumption.
      eapply infseq_silent_N_plus; eauto.
      rewrite <- H1.
      econstructor; eauto.
  Qed.

  Lemma infseq_silent_N_infseq_silent :
    forall a n, infseq_silent_N n a -> infseq_silent a.
  Proof.
    cofix Hfix.
    intros a n H.
    destruct (infseq_silent_N_inv H) as [n' [a' [Hr Hinf]]].
    apply infseq_silent_step with (b := a').
    eauto.
    eapply Hfix; eauto.
  Qed.

  Lemma infseq_silent_infseq_silent_N :
    forall a n, infseq_silent a -> infseq_silent_N n a.
  Proof.
    cofix Hfix.
    intros a n H.
    inversion H; subst.
    eapply infseq_silent_N_plus with (n2 := 0).
    replace [] with ([] ++ [] : list E) by reflexivity.
    econstructor; eauto; eapply star_refl.
    now eapply Hfix.
  Qed.

  Lemma infseq_silent_infseq :
    forall a s, infseq_silent a -> infseq s a.
  Proof.
    cofix Hfix.
    intros a s H.
    inversion H; subst; clear H.
    replace s with (app_list_stream [] s) by reflexivity.
    econstructor; eauto.
  Qed.

  Lemma infseq_infseq_silent :
    forall P s a, (infseq s a -> P a) ->
             (infseq_silent a -> P a).
  Proof.
    intros P s a X H.
    apply X. now apply infseq_silent_infseq.
  Qed.

  Lemma diverges_infseq_silent:
    forall s0,
      (forall s1 t1, star s0 t1 s1 -> exists s2, R s1 [] s2) ->
      infseq_silent s0.
  Proof.
    cofix Hfix; intros.
    destruct (H s0 []) as [s1 H']. constructor.
    econstructor; try eassumption.
    apply Hfix.
    intros s2 t1 H0.
    eapply H. eapply star_step; eauto.
  Qed.

  Definition irred (a: A) : Prop := forall b e, ~(R a e b).

  (*
  Inductive behavior :=
  | Reactive : @stream E -> behavior
  | Diverges : list E -> behavior
  | Terminates : list E -> behavior
  .
  *)

  (** ** Determinism properties for functional transition relations. *)

  (** A transition relation is functional if every state can transition to at most
  one other state. *)

  Hypothesis R_functional:
    forall a b c l1 l2, R a l1 b -> R a l2 c -> b = c /\ l1 = l2.

  Lemma star_infseq_prod_inv : forall a l b,
      star a l b ->
      forall s, infseq_prod s a ->
           exists s', infseq_prod s' b /\ s = app_list_stream l s'.
  Proof.
    induction 1; intros.
    - eexists; eauto.
    - inversion H1; subst; clear H1.
      inversion H2; subst; clear H2.
      congruence.
      assert (b1 = b /\ l0 = l1) as [? ?]
          by (now eapply R_functional; eassumption); subst.
      specialize (IHstar (app_list_stream l3 s0)).
      destruct IHstar as [s' [? ?]].
      eapply star_infseq_prod; eauto.
      exists s'. split; eauto.
      clear -H6.
      induction l1. simpl. rewrite H6. reflexivity.
      simpl. rewrite IHl1. reflexivity.
  Qed.

  Lemma infseq_prod_inv : forall a l1 b,
      star a l1 b ->
      forall c l2 s1 s2,
        star a l2 c ->
        l1 <> [] -> l2 <> [] ->
        infseq_prod s1 b ->
        infseq_prod s2 c ->
        exists a', exists l, exists s1', exists s2',
                l <> [] /\
                infseq_prod s1' a' /\ infseq_prod s2' a' /\
                app_list_stream l1 s1 = app_list_stream l s1' /\
                app_list_stream l2 s2 = app_list_stream l s2'.
  Proof.
    induction 1; intros.
    congruence.
    inversion H1; subst; clear H1. congruence.
    assert (b = b0 /\ l1 = l3) as [? ?] by (eapply R_functional; eassumption); subst.
    destruct l3.
    - simpl in *. eapply IHstar; eauto.
    - exists b0. exists (e :: l3). exists (app_list_stream l2 s1). exists (app_list_stream l4 s2).
      repeat split.
      congruence.
      eapply star_infseq_prod; eauto.
      eapply star_infseq_prod; eauto.
      eapply app_list_stream_app. eapply app_list_stream_app.
  Qed.

  (** Uniqueness of finite transition sequences. *)

  Lemma star_star_inv:
    forall a b l1, star a l1 b ->
              forall c l2, star a l2 c ->
                      (exists l3, l1 = l2 ++ l3 /\ star c l3 b) \/
                      (exists l3, l2 = l1 ++ l3 /\ star b l3 c).
  Proof.
    induction 1; intros.
    - right; now eexists.
    - inversion H1; subst.
      + left. eexists; split; eauto using star.
        now rewrite app_nil_l.
      + assert (b = b0) by (eapply R_functional; eauto).
        assert (He: l1 = l3) by (eapply R_functional; eauto).
        subst b0 l3.
        edestruct (IHstar c0) as [[l3 [IH1 IH2]] | [l3 [IH1 IH2]]]. eauto.
        * subst.
          left.
          eexists; split; eauto using star.
          now rewrite app_assoc.
        * subst.
          right.
          eexists; split; eauto using star.
          now rewrite app_assoc.
  Qed.

  Lemma finseq_unique:
    forall a b b' l l',
      star a l b -> irred b ->
      star a l' b' -> irred b' ->
      b = b' /\ l = l'.
  Proof.
    intros.
    destruct (star_star_inv H H1) as [[l'' [H3 H4]] | [l'' [H3 H4]]].
    - inversion H4; split; subst; auto; try elim (H2 _ _ H5).
      apply app_nil_r.
    - inversion H4; split; subst; auto; try elim (H0 _ _ H5).
      now rewrite app_nil_r.
  Qed.

  Lemma infseq_silent_star_inv : forall a b l,
    star a l b ->
    infseq_silent a ->
    l = [] /\ infseq_silent b.
  Proof.
    intros a b l H.
    induction H.
    - auto.
    - intros H1.
      inversion H1; subst; clear H1.
      destruct (R_functional H H2); subst; eauto.
  Qed.

  (** A state cannot both diverge and terminate on an irreducible state. *)

  (*
  Lemma infseq_star_inv:
    forall a b l s, star a l b -> infseq s a -> infseq (l++s) b.
  Proof.
    induction 1; intros.
  - auto.
  - inversion H1; subst.
    assert (b = b0) by (eapply R_functional; eauto). subst b0.
    apply IHstar; auto.
  Qed.
   *)

  Lemma infseq_finseq_excl:
    forall a b l s,
      star a l b -> irred b -> infseq s a -> False.
  Proof.
    intros.
    assert (exists s', infseq s' b).
    { generalize dependent s.
      induction H; intros.
      - inversion H1; subst; elim (H0 _ _ H).
      - inversion H2; subst.
        + assert (b = b0) by (eapply R_functional; eauto).
          subst b0.
          eapply IHstar; eassumption.
    }
    destruct H2 as [s' Hs'].
    inversion Hs'; subst; elim (H0 _ _ H2).
  Qed.

  Lemma infseq_silent_irred_excl:
    forall a,
      irred a -> infseq_silent a -> False.
  Proof.
    intros a H H0.
    unfold irred in *.
    destruct H0.
    now apply (H b []).
  Qed.

  Lemma infseq_silent_finseq_excl:
    forall a b c l l',
      star a l b ->
      star a l' c ->
      infseq_silent b ->
      irred c ->
      False.
  Proof.
    intros a b c l l' H H0 H1 H2.
    destruct (star_star_inv H H0) as [[l'' [H3 H4]] | [l'' [H3 H4]]].
    - inversion H4; subst.
      + now eapply infseq_silent_irred_excl.
      + unfold irred in H2.
        eapply H2; eassumption.
    - induction H4; subst.
      + now eapply infseq_silent_irred_excl.
      + inversion H1; subst.
        assert (b = b0 /\ l1 = []) as [? ?] by (eapply R_functional; eauto); subst.
        simpl in *.
        apply IHstar; eauto.
        replace l with (l ++ []) by now apply app_nil_r.
        eapply starans. eauto.
        replace [] with ([] ++ [] : list E) by reflexivity.
        econstructor; eauto. constructor.
  Qed.

  (** If there exists an infinite sequence of transitions from [a],
  all sequences of transitions arising from [a] are infinite. *)

  (*
  Lemma infseq_all_seq_inf:
    forall a, infseq a -> all_seq_inf a.
  Proof.
    intros. unfold all_seq_inf. intros.
    assert (infseq b) by (eapply infseq_star_inv; eauto).
    inversion H1. subst. exists b0; auto.
  Qed.
  *)

  Lemma plus_infseq :
    forall a b s l,
      plus a l b -> infseq s b ->
      infseq (Stream.app_list_stream l s) a.
  Proof.
    intros until l.
    intros H.
    inversion H; subst.
    eapply star_infseq.
    econstructor; eauto.
  Defined.

  (** Alternative view of streams *)
  CoInductive stream' :=
  | scons' : forall (l : list E) (s : stream'), l <> [] -> stream'.

  Program Definition split_traceinf' (l : list E) (s: stream') (NE: l <> []): E * stream' :=
    match l with
    | nil => _
    | e :: nil => (e, s)
    | e :: t' => (e, @scons' t' s _)
    end.
  Next Obligation.
    destruct t'; congruence.
  Qed.

  CoFixpoint stream_of_stream' (s': stream') : stream :=
    match s' with
    | @scons' t T'' NOTEMPTY =>
      let (e, tl) := @split_traceinf' t T'' NOTEMPTY in
      scons e (stream_of_stream' tl)
    end.

  Remark unroll_stream':
    forall T, T = match T with @scons' t T' NE => @scons' t T' NE end.
  Proof.
    intros. destruct T; auto.
  Qed.

  Remark unroll_stream:
    forall (T : @stream E), T = match T with scons t T' => scons t T' end.
  Proof.
    intros. destruct T; auto.
  Qed.

  Lemma stream_stream'_app:
    forall t T NE,
      stream_of_stream' (@scons' t T NE) = Stream.app_list_stream t (stream_of_stream' T).
  Proof.
    induction t.
    intros. elim NE. auto.
    intros. simpl.
    rewrite (unroll_stream (stream_of_stream' (@scons' (a :: t) T NE))).
    simpl. destruct t. auto.
    simpl. f_equal. apply IHt.
  Qed.

End Sequences_Traces.


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 5 *)

Require Import Frap.Frap.

Module Type S.
  Inductive arith : Set :=
  | Const(n: nat)
  | Var(x: var)
  | Plus(e1 e2: arith).

  Inductive cmd :=
  | Skip
  | Assign(x: var)(e: arith)
  | Sequence(c1 c2: cmd)
  | If(e: arith)(thn els: cmd)
  | While(e: arith)(body: cmd).

  Definition valuation := fmap var nat.

  Fixpoint interp(e: arith)(v: valuation)(a: nat): Prop :=
    match e with
    | Const n => a = n
    | Var x =>
      match v $? x with
      | None => True (* any a is possible! *)
      | Some n => a = n
      end
    | Plus e1 e2 => exists a1 a2, interp e1 v a1 /\ interp e2 v a2 /\ a = a1 + a2
    end.

  (* 4 points for "values" *)
  Parameter values_alias_for_grading: arith -> valuation -> nat -> Prop.

  (* 1 point *)
  Parameter values_example: forall a,
    2 <= a ->
    values_alias_for_grading (Plus (Var "y") (Var "z")) ($0 $+ ("y", 2)) a.

  (* 4 points *)
  Parameter interp_to_values: forall e v a,
      interp e v a -> values_alias_for_grading e v a.

  (* 4 points *)
  Parameter values_to_interp: forall e v a,
      values_alias_for_grading e v a -> interp e v a.

  (* 2 points *)
  Parameter values_to_interp_induction_on_e: forall e v a,
      values_alias_for_grading e v a -> interp e v a.

  (* 7 points for "eval" *)
  Parameter eval_alias_for_grading: valuation -> cmd -> valuation -> Prop.

  Example the_answer_is_42 :=
    Sequence (Assign "x" (Var "oops"))
             (Sequence (If (Var "x")
                           (Assign "tmp" (Plus (Var "x") (Var "x")))
                           (Assign "tmp" (Const 1)))
                       (If (Var "tmp")
                           (Assign "answer" (Const 42))
                           (Assign "answer" (Const 24)))).

  (* 1 point *)
  Parameter read_last_value: forall x v c n,
      values_alias_for_grading (Var x) (v $+ (x, c)) n -> n = c.

  (* 7 points *)
  Parameter the_answer_is_indeed_42:
    forall v, eval_alias_for_grading $0 the_answer_is_42 v -> v $? "answer" = Some 42.

  Example loop_of_unknown_length :=
    (While (Var "x") (Assign "counter" (Plus (Var "counter") (Const 1)))).

  (* 7 points *)
  Parameter eval_loop_of_unknown_length: forall n initialCounter,
      eval_alias_for_grading ($0 $+ ("counter", initialCounter))
                             loop_of_unknown_length
                             ($0 $+ ("counter", initialCounter + n)).

  (* 4 points *)
  Parameter run: nat -> valuation -> cmd -> valuation -> Prop.

  (* 14 points *)
  Parameter run_to_eval: forall fuel v1 c v2,
      run fuel v1 c v2 ->
      eval_alias_for_grading v1 c v2.

  Definition wrun(v1: valuation)(c: cmd)(v2: valuation): Prop :=
    exists fuel, run fuel v1 c v2.

  (* 17 points *)
  Parameter run_monotone: forall fuel1 fuel2 v1 c v2,
      fuel1 <= fuel2 ->
      run fuel1 v1 c v2 ->
      run fuel2 v1 c v2.

  (* 1 point *)
  Parameter WRunSkip: forall v,
      wrun v Skip v.

  (* 2 points *)
  Parameter WRunAssign: forall v x e a,
      interp e v a ->
      wrun v (Assign x e) (v $+ (x, a)).

  (* 2 points *)
  Parameter WRunSeq: forall v c1 v1 c2 v2,
      wrun v c1 v1 ->
      wrun v1 c2 v2 ->
      wrun v (Sequence c1 c2) v2.

  (* 2 points for statement
     1 point for proof *)
  (* Parameter WRunIfTrue: TODO_FILL_IN. *)

  (* 2 points for statement
     1 point for proof *)
  (* Parameter WRunIfFalse: TODO_FILL_IN. *)

  (* 3 points for statement
     1 point for proof *)
  (* Parameter WRunWhileTrue: TODO_FILL_IN. *)

  (* 2 points for statement
     1 point for proof *)
  (* Parameter WRunWhileFalse: TODO_FILL_IN. *)

  (* 10 points *)
  Parameter eval_to_wrun: forall v1 c v2,
      eval_alias_for_grading v1 c v2 ->
      wrun v1 c v2.

End S.


Theorem vp31: ~False.
Proof.
        intro a.
        assumption.
Qed.

Theorem vp32:
        forall P:Prop, ~~~P -> ~P.
Proof.
        intros P h1 p.
        apply h1.
        intro h2.
        auto.
Qed.

Theorem vp32_:
        forall P:Prop, ~~~P -> ~P.
Proof.
        unfold not.
        intros P h1 p.
        elim h1.
        intros h2.
        elim h2.
        assumption.
Qed.

Theorem vp33:
        forall P Q : Prop, ~~~P -> P -> Q.
Proof.
        unfold not.
        intros P Q h1 p.
        elim h1.
        intros h2.
        elim h2.
        assumption.
Qed.

Theorem vp34:
        forall P Q:Prop, (P -> Q) -> ~Q -> ~ P.
Proof.
        unfold not.
        intros P Q h1 h2 p.
        elim h2.
        apply h1;assumption.
Qed.
Lemma test1:
        forall P Q:Prop, (P -> P/\Q) -> ~(P /\ Q) -> (P \/ Q) -> ~(P \/ Q) -> Q.
Proof.
        unfold not.
        intros P Q h1 h2 h3 h4.
        elim h1.
Abort.

Theorem vp35:
        forall P Q R:Prop, (P -> Q) -> (P -> ~ Q) -> P -> R.
Proof.
        unfold not.
        intros P Q R h1 h2 p.
        elim h2.
        assumption.
        apply h1; assumption.
Qed.

Axiom dyslexic_imp : forall P Q:Prop, (P -> Q) -> (Q -> P).

Axiom dyslexic_contrap : forall P Q:Prop,(P -> Q) -> (~P -> ~ Q).

Lemma wrongLemma1:
        False.
Proof.
        assert(H1 : forall P: Prop, P -> False).
        assert(H2 : forall P: Prop, False -> P).
        intros P h1;elim h1.
        intro P;apply dyslexic_imp;apply H2.
        apply(H1 (1+1=2) eq_refl).
Qed.

Lemma wongLemma2:
        False.
Proof.
        assert(H2: forall Q:Prop, ~Q).
        intros Q;apply dyslexic_contrap with (Q:= Q)(P:= False).
        intro h1; elim h1.
        intro h1; elim h1.
        apply(H2 (1+1=2) eq_refl).
Qed.

Theorem vp5:
        forall (A:Set) (a b c d:A) ,a = c \/ b = c \/ c = c \/ d = c.
Proof.
        intros A a b c d.
        right;right;left;reflexivity.
Qed.

Theorem vp61:
        forall A B C:Prop, A/\(B/\C) -> (A/\ B)/\C.
Proof.
        intros A B C h1.
        split.
        split.
        elim h1.
        intros;assumption.
        elim h1;intros h2 h3;elim h3;intros;assumption.
        elim h1;intros h2 h3;elim h3;intros;assumption.
Qed.

Theorem vp62:
        forall A B C D : Prop, (A -> B) /\ (C -> D)/\A/\C -> B /\ D.
Proof.
        intros A B C D h1.
        elim h1.
        intros h2 h3.
        elim h3 .
        intros h4 h5.
        elim h5;intros h6 h7.
        split;[apply h2;assumption|apply h4;assumption].
Qed.

Theorem vp63:
        forall A:Prop, ~(A/\~A).
Proof.
        unfold not.
        intros A h1.
        elim h1;intros h3 h4;apply h4;assumption.
Qed.

Theorem vp64 :
        forall A B C:Prop, A \/ (B \/ C) -> (A \/ B) \/ C.
Proof.
        intros A B C h1.
        elim h1.
        intro h2;left;left;assumption.
        intro h2;elim h2;[intro h3;left;right;assumption | intro h3;right;assumption].
Qed.

Theorem vp65 :
        forall A:Prop, ~~(A\/~A).
Proof.
        unfold not.
        intros A h1.
        apply h1.
        right.
        intros a.
        apply h1.
        left;assumption.
Qed.

Theorem vp66 :
        forall A B :Prop,(A \/B) /\ ~A -> B.
Proof.
        unfold not.
        intros A B h1.
        elim h1.
        intros h2 h3.
        elim h2.
        intro h4;elim h3;assumption.
        intro;assumption.
Qed.

Axiom classic :
        forall P:Prop, ~~P -> P.

Theorem excluded_middle :
        forall P:Prop, P \/ ~P.
Proof.
        intros P.
        unfold not.
        apply (classic _ (vp65 P) ).
Qed.

Theorem de_morgan_not_and_not:
        forall P Q:Prop, ~(~P /\ ~Q) -> P\/ Q.
Proof.
        unfold not.
        intros P Q h1.
        assert (P \/ ~P).
        apply excluded_middle.
        assert (Q \/ ~Q).
        apply excluded_middle.
        elim H.
        intro;left;assumption.
        elim H0.
        intros;right;assumption.
        intros;elim h1;split;assumption.
Qed.

Theorem implies_to_or:
        forall P Q:Prop,
        (P -> Q) -> (~P \/ Q).
Proof.
        intros P Q h1.
        apply de_morgan_not_and_not.
        unfold not.
        intro h2.
        elim h2.
        intros h3 h4.
        assert P.
        assert (hc : P \/ ~P).
        apply de_morgan_not_and_not.
        apply vp63.
        elim hc.
        intro;assumption.
        intro;elim h3;assumption.
        apply h4;apply h1;assumption.
Qed.

Theorem peirce:
        forall P Q:Prop, ((P -> Q) -> P) -> P.
Proof.
        intros P Q h1.
        assert (h2: ~P \/ P).
        apply implies_to_or.
        intro;assumption.
        elim h2.
        unfold not.
        intro h3.
        apply h1.
        intro p;elim h3;assumption.
        intro;assumption.
Qed.

Theorem classic__:
        forall P:Prop, ~~P -> P.
Proof.
        unfold not.
        intros P h1.
        apply peirce with (Q:= ~~P).
        assert (h2: (((~P -> False) -> ~P) -> ~P)).
        apply peirce with (Q:=False) (P := ~P).
        intro h3.
        assert (h4: (((P \/ ~P) -> False) -> (P \/ ~P)) -> P \/~P).
        apply peirce with (P:= (P \/ ~P)) (Q := False).
        assert (h5 : ((P \/ ~P) -> False) -> (P \/ ~P)).
        intro h5.
        assert (h6 : ~~(P \/ ~P)).
        unfold not.
        intro h7.
        apply h7.
        elim h7.
        right.
        intro;apply h7;left;assumption.
        elim h6.
        assumption.
        assert (h8 : P\/~P).
        apply h4;assumption.
        elim h8.
        intro;assumption.
        intro;elim h1;assumption.
Qed.
Theorem ex_imp_ex :
        forall (A:Type) (P Q : A -> Prop), (ex P) -> (forall x : A, P x -> Q x) ->(ex Q).
Proof.
        intros A P Q h1 h2.
        elim h1.
        intros a h3.
        apply (ex_intro) with (x := a).
        apply h2;assumption.
Qed.

Section vp9.
        Variable A:Set.
        Variable (P Q : A -> Prop).
Theorem vp91:
        (exists x:A, P x \/ Q x) -> (ex P) \/ (ex Q).
Proof.
        intros h1.
        elim h1.
        intros a h2.
        elim h2.
        intro h3;left;exists a;assumption.
        intro h3;right;exists a;assumption.
Qed.

Theorem vp92:
        (ex P)\/(ex Q) -> exists x : A, P x \/ Q x.
Proof.
        intro h1.
        elim h1.
        intro h2;elim h2;intros a h3;exists a;left;assumption.
        intro h2;elim h2;intros a h3;exists a;right;assumption.
Qed.

Theorem vp93:
        (exists x:A, (forall R:A -> Prop, R x)) -> 2 = 3.
Proof.
        intros h1.
        elim h1.
        intros a h2.
        assert False.
        apply (h2 (fun (a:A) => False)).
        elim H.
Qed.

Theorem vp94:
        (forall x: A, P x) -> ~(exists y:A, ~ P y).
Proof.
        unfold not.
        intros h1 h2.
        elim h2.
        intros a h3.
        apply h3;apply h1.
Qed.

End vp9.

Require Import Arith.

Theorem plus_permute2:
        forall n m p: nat, n + m + p = n + p + m.
Proof.
        intros n m p.
        rewrite <- plus_assoc.
        pattern (m+p) at 1.
        rewrite -> plus_comm.
        rewrite -> plus_assoc.
        reflexivity.
Qed.

Theorem vp11:
        forall (A:Type)(x y z : A), x = y -> y = z -> x = z.
Proof.
        intros A x y z h1 h2.
        rewrite -> h1; rewrite -> h2;reflexivity.
Qed.

Definition my_True: Prop :=
        forall P : Prop, P -> P.

Definition my_I : my_True :=
        fun (P : Prop) (a : P) => a.

Definition my_False : Prop :=
        forall P : Prop, P.

Definition my_False_ind :
        forall P : Prop, my_False -> P :=
        fun (P : Prop) (a : my_False) => (a P).

Definition my_not (P:Prop) : Prop := P -> my_False.

Section vp13.
Theorem vp131: my_not(my_False).
Proof.
        unfold my_not.
        intro;assumption.
Qed.

Theorem vp132 :forall P: Prop, my_not(my_not(my_not(P))) -> my_not(P).
Proof.
        unfold my_not.
        intros P h1 p.
        apply h1.
        intro h2.
        apply h2;assumption.
Qed.

Theorem vp133:
        forall P Q:Prop, my_not(my_not(my_not(P))) -> P -> Q.
Proof.
        unfold my_not.
        intros P Q h1 p.
        assert (h0: my_False).
        apply h1.
        intros h2;apply h2;assumption.
        apply (h0 Q).
Qed.

Theorem vp134:
        forall P Q : Prop, (P -> Q) -> my_not (Q) -> my_not (P).
Proof.
        unfold my_not.
        intros P Q h1 h2 p.
        apply h2;apply h1;assumption.
Qed.

Theorem vp135:
        forall P Q R:Prop, (P -> Q) -> (P -> my_not(Q)) -> P -> R.
Proof.
        unfold my_not.
        intros P Q R h1 h2 p.
        assert (h0: my_False).
        apply h2;[assumption|apply h1;assumption].
        apply (h0 R).
Qed.

Section leibniz.
Set Implicit Arguments.
Unset Strict Implicit.
Variable A:Set.

Definition leibniz (a b : A) : Prop :=
        forall P : A -> Prop, P a -> P b.

Require Import Relations.

Theorem leibniz_sym : symmetric A leibniz.
Proof.
        unfold symmetric.
        intros x y h1.
        assert (h0: leibniz x x).
        unfold leibniz;intros;assumption.
        apply (h1 _ h0).
        assumption.
Qed.

Theorem leibniz_refl : reflexive A leibniz.
Proof.
        unfold reflexive.
        unfold leibniz; intros;assumption.
Qed.

Theorem leibniz_trans : transitive A leibniz.
Proof.
        unfold transitive.
        intros x y z h1 h2.
        apply h2;assumption.
Qed.

Theorem leibniz_equiv : equiv A leibniz.
Proof.
        unfold equiv.
        split.
        apply leibniz_refl.
        split;[apply leibniz_trans|apply leibniz_sym].
Qed.

Theorem leibniz_least_reflexive :
        forall R: relation A, reflexive A R -> inclusion A leibniz R.
Proof.
        unfold inclusion.
        intros R h1 x y h2.
        apply h2.
        apply h1.
Qed.

Theorem leibniz_eq :
        forall a b : A, leibniz a b -> a = b.
Proof.
        intros a b h1.
        apply h1.
        reflexivity.
Qed.

Theorem eq_leibniz_ind :
        forall a b : A, a = b -> leibniz a b.
Proof.
        intros a b h1;rewrite <- h1;apply leibniz_refl.
Qed.

Theorem leibniz_ind :
        forall (x : A) ( P : A -> Prop) , P x -> forall y : A, leibniz x y -> P y.
Proof.
        intros a P h1 y h2.
        apply h2.
        apply h1.
Qed.

Unset Implicit Arguments.
End leibniz.

Definition my_and (P Q:Prop) :=
        forall R:Prop, (P -> Q -> R) -> R.

Definition my_or (P Q:Prop) :=
        forall R:Prop, (P -> R) -> (Q -> R) -> R.

Definition my_ex (A:Set) (P : A -> Prop) :=
        forall R:Prop, (forall a:A, P a -> R) -> R.

Theorem vp151:
        forall P Q:Prop, my_and P Q -> P.
Proof.
        intros P Q h1.
        apply h1.
        intros;assumption.
Qed.

Theorem vp152:
        forall P Q:Prop, my_and P Q -> Q.
Proof.
        intros P Q h1;apply h1;intros;assumption.
Qed.

Theorem vp153:
        forall P Q R:Prop, (P -> Q -> R) -> my_and P Q -> R.

Proof.
        intros P Q R h1 h2.
        apply h1.
        apply h2;intros;assumption.
        apply h2;intros;assumption.
Qed.

Theorem vp154:
        forall P Q:Prop, P -> my_or P Q.

Proof.
        intros P Q p.
        unfold my_or.
        intros R h1 h2;apply h1;assumption.
Qed.

Theorem vp155:
        forall P Q:Prop, Q -> my_or P Q.
Proof.
        unfold my_or.
        intros P Q q R h1 h2.
        apply h2;assumption.
Qed.

Theorem vp156:
        forall P Q R:Prop, (P -> R) -> (Q -> R) -> my_or P Q -> R.

Proof.
        intros P Q R h1 h2.
        unfold my_or.
        intros h3.
        apply h3;assumption.
Qed.

Theorem vp158:
        forall P Q:Prop, my_or P Q -> my_or Q P.
Proof.
        unfold my_or;intros P Q h1.
        intros R h3 h2;apply h1;assumption.
Qed.

Theorem vp157:
        forall P:Prop,my_or P my_False -> P.
Proof.
        unfold my_or;intros P h1;apply h1;intros.
        assumption.
        apply (H P).
Qed.

Theorem vp159:
       forall (A:Set) (P: A -> Prop) (a : A), P a -> my_ex A P.
Proof.
        intros A P a h1.
        unfold my_ex.
        intros R h2.
        apply h2 with (a:=a).
        assumption.
Qed.

Theorem vp1510:
        forall (A:Set) (P:A->Prop),
                my_not (my_ex A P) -> forall a: A, my_not (P a).
Proof.
        unfold my_not.
        unfold my_ex.
        intros A P h1 h2 h3.
        apply h1.
        intros R h4.
        apply h4 with (a:=h2).
        assumption.
Qed.

Definition my_le (n p :nat):=
        forall P: nat -> Prop, P n -> (forall q: nat, P q -> P (S q)) -> P p.

Lemma my_le_n :
        forall n:nat ,my_le n n.
Proof.
        intros n.
        unfold my_le.
        intros P h1 h2.
        assumption.
Qed.

Lemma my_le_S :
        forall n p : nat , my_le n p -> my_le n (S p).
Proof.
        unfold my_le.
        intros n p h1 P h2 h3.
        apply h3.
        apply h1.
        assumption.
        assumption.
Qed.

Lemma my_le_le :
        forall n p : nat, my_le n p -> n <= p.
Proof.
        intros n p h1.
        apply h1.
        reflexivity.
        apply le_S.
Qed.


(* This file contains the floating-point functional model in IEEE-754
  format of the 2Sum algorithm, along with a theorem regarding the
  correctness of the 2Sum algorithm *)

Require Import vcfloat.VCFloat.
Require Import float_acc_lems op_defs dd_tactics.
Require Import DDModels.
From Flocq Require Import Pff2Flocq Core.

Require Import mathcomp.ssreflect.ssreflect.

Section TwoSumCorrect.

Context {NANS: Nans} {t : type}.

Variables (a b : ftype t).
Hypothesis (FIN : is_finite_p (TwoSumF a b)).

Theorem TwoSumF_correct :
  FT2R (TwoSumF_err a b) = FT2R a + FT2R b - FT2R (TwoSumF_sum a b).
Proof.
set (s  := BPLUS a b).
set (a' := BMINUS s b).
set (b' := BMINUS s a').
set (da := BMINUS a a').
set (db := BMINUS b b').
destruct FIN as (FINs & FINd).
(* use TwoSum correct from Flocq, not double-double paper *)
pose proof (TwoSum_correct (@emin t) (fprec t) choice
    (fprec_gt_one t) emin_le_0 choiceP (FT2R b) (FT2R a)) as Hc.
rewrite Rplus_comm; rewrite <- Hc; clear Hc; rewrite_format.
(* algebra *)
rewrite <- Rplus_opp, Rplus_comm, <- Rplus_assoc.
replace (FT2R b + FT2R a) with (FT2R a + FT2R b) by nra.
(* rewrites from correctness theorems *)
unfold TwoSumF_err, TwoSumF_sum, TwoSumF, fst, snd in *.
BPLUS_correct t a b; field_simplify.
fold s a' b' da db in FINd; fold s a' b' da db. BPLUS_correct t da db.
rewrite Rplus_comm; repeat f_equal.
{ subst db; BMINUS_correct t b b'.
  subst b' s; BMINUS_correct t (BPLUS a b) a'; rewrite H4.
  repeat f_equal.
  subst a'. BMINUS_correct t (BPLUS a b) b; rewrite H4.
  repeat f_equal. }
{ subst da; BMINUS_correct t a a'.
  subst a' s. BMINUS_correct t (BPLUS a b) b; rewrite H4.
  repeat f_equal. }
all: apply Binary.generic_format_B2R.
Qed.

Theorem TwoSum_is_DW:
  double_word (TwoSumF_sum a b) (TwoSumF_err a b).
Proof.
  rewrite /double_word TwoSumF_correct // /TwoSumF_sum /= /common.rounded.
destruct FIN as (FINm & FINp).
unfold TwoSumF_err, TwoSumF_sum, TwoSumF, fst, snd in *.
  BPLUS_correct t a b.
Qed.

End TwoSumCorrect.

Section TwoSumAcc.

Context {NANS: Nans} {t : type}.

Variables (a b : ftype t).
Hypothesis (FIN : is_finite_p (TwoSumF a b)).

Notation ulp := (Ulp.ulp Zaux.radix2 (SpecFloat.fexp (fprec t) (femax t))).
Notation u   := (bpow Zaux.radix2 (- fprec t)).

Theorem TwoSum_accuracy:
    Rabs (FT2R (TwoSumF_err a b))  <= /2 * ulp (FT2R a + FT2R b).
Proof.
rewrite TwoSumF_correct; auto. unfold TwoSumF_sum. simpl.
rewrite Rabs_minus_sym.
pose proof error_le_half_ulp
  Zaux.radix2 (SpecFloat.fexp (fprec t) (femax t)) choice (FT2R a + FT2R b) as HE.
destruct FIN as (FINs & FINd); simpl in FINs.
BPLUS_correct t a b. fold (@FT2R t); auto.
Qed.

End TwoSumAcc.


Require Import Omega.
(* ordinary coq proof with giant term *)
Theorem OCP_leq0_then_eq0 m (H : m <= 0) : m = 0.
Proof. omega. (*Show Proof.*) Defined.


Lemma and_comm: forall P Q, P/\Q -> Q /\ P.
Proof.
intros.
destruct H.
split.
 * assumption.
 * assumption.
Qed.

Print and_comm.

Lemma or_comm: forall P Q, P \/ Q -> Q \/ P.
Proof.
intros.
destruct H.
 * right.
   assumption.
 * left;assumption.
Qed.

Print False.

Lemma ZFalszu: False -> 2+2=5.
Proof.
intro.
destruct H.
Qed.

Print ex.

Check @ex nat (fun x:nat => x+1 = 2).

Lemma istnieje1: exists x, x+1=2.
Proof.
exists 1.
simpl.
trivial.
Qed.

Lemma istnieje2: forall m n, (exists x, x+n = m) -> (n=m) \/ (exists k, m = S k).
Proof.
intros.
destruct H.
destruct x.
* left.
  simpl in H.
  assumption.
* right.
  simpl in H.
  exists (x+n).
  symmetry.
  assumption.
Qed.


Set Loose Hint Behavior "Strict".
Require Import Coq.NArith.NArith.

Local Open Scope N_scope.

Definition Nlt_dec: forall (l r : N), {l < r} + {l >= r}.
  refine (fun l r =>
    match N.compare l r as k return N.compare l r = k -> _ with
      | Lt => fun pf => left _ _
      | _ => fun pf => right _ _
    end (refl_equal _));
  abstract congruence.
Defined.


Require Export ProjectiveGeometry.Dev.projective_plane_axioms.

Section s_basicPlaneFacts.

Context `{PP : ProjectivePlane'}.
Context `{EP : EqDecidability Point}.

Lemma incidABl : forall (A B:Point)(l:Line), ~Incid A l /\ Incid B l -> ~ A [==] B.
Proof.
intros l1 l2 A H Hl2l1;rewrite Hl2l1 in *; tauto.
Qed.

Hint Resolve incidABl : incidence.

Lemma incidAl1l2 :forall (l1 l2:Line)(A:Point), ~Incid A l1 /\ Incid A l2 -> l2 <> l1.
Proof.
intros A B l H HAB; subst A; tauto.
Qed.

Hint Resolve incidAl1l2 : incidence.

Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
  ~A[==]B -> Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> l1=l2.
Proof.
intros A B l1 l2 HAB HAl1 HBl1 HAl2 HBl2.
assert ((A=B)\/(l1=l2)).
apply uniqueness; intuition.
intuition.
Qed.

Lemma a2_unique : forall(l m :Line)(A B :Point),
  l<>m -> Incid A l -> Incid A m -> Incid B l -> Incid B m -> A[==]B.
Proof.
intros l1 l2 A B Hl1l2 HAl1 HAl2 HBl1 HBl2.
assert ((A[==]B)\/(l1=l2)).
apply uniqueness; intuition.
intuition.
Qed.

Lemma second_point : forall A:Point, forall l:Line, Incid A l -> {B : Point | (~ B [==]A) /\ (Incid B l)}.
Proof.
intros A l HAl.
elim (a3_1 l).
intros P1 H2.
elim H2; intros P2 H'.
elim H'; intros P3 H''.
elim (eq_dec_u A P1).
intros HAP1.
exists P2.
rewrite HAP1.
intuition.
intros HAP1.
exists P1.
intuition.
Qed.

Lemma third_point : forall A B : Point, forall l:Line,
~ A [==]B /\ Incid A l /\ Incid B l ->
{C : Point | ~A[==]B /\ ~B[==]C /\ ~A[==]C /\ Incid C l}.
Proof.
intros A B l HABl.
elim (a3_1 l).
intros P1 H2.
elim H2; intros P2 H'.
elim H'; intros P3 H''.
elim (eq_dec_u A P1).
intros HAP1.

decompose [and] H''.
intuition.
rewrite <- HAP1 in *.

elim (eq_dec_u B P2).
intros HBP2.
rewrite <- HBP2 in *.
exists P3.
intuition.
intros HBP2.
exists P2.
intuition.
intros HBP2.
decompose [and] HABl; clear HABl.
decompose [and] H''; clear H''.
decompose [and] H2;clear H2.

elim (eq_dec_u B P1).
intros HBP1.
elim (eq_dec_u A P2).
intros.
exists P3.
rewrite HBP1 in *.
rewrite a in *.
intuition.

intros HAP2.
rewrite HBP1 in *.

elim (eq_dec_u B P2).
intros.
rewrite a in *.
cut False;
intuition.

exists P2.
intuition.
exists P1.
intuition.
Qed.

Lemma line_equivalence : forall l1 l2, l1 = l2 <-> forall M : Point, (Incid M l1 <-> Incid M l2).
Proof.
intros.
split.

intros.
split.

intros.
rewrite H in H0;assumption.
intros.
rewrite <-H in H0;assumption.

intros.
assert(HH := a3_1 l1).
destruct HH.
destruct s.
destruct s.
destruct a.
destruct H1.
destruct H2.
destruct H3.
destruct H4.
assert(HH := H x).
assert(HH0 := H x0).
destruct HH.
assert(HH := H6 H3).
destruct HH0.
assert(HH0 := H8 H4).
assert(HH1 := uniqueness x x0 l1 l2 H3 H4 HH HH0).
destruct HH1.
rewrite H10 in H0.
apply False_ind;apply H0;reflexivity.
assumption.
Qed.

End s_basicPlaneFacts.


(** Calculation of the simple arithmetic language with exceptions and
(global) state. *)

Require Import List.
Require Import Tactics.
Require Import Coq.Program.Equality.
Module State (Import mem : Memory).

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Throw : Expr
| Catch : Expr -> Expr -> Expr
| Get : Expr
| Put : Expr -> Expr -> Expr.

Definition state := nat.

(** * Semantics *)

Fixpoint eval (x: Expr) (q : state) : option nat * state :=
  match x with
    | Val n => (Some n, q)
    | Add x1 x2 => match eval x1 q with
                   | (Some m, q') => match eval x2 q' with
                                   | (Some n, q'') => (Some (m + n), q'')
                                   | (None, q'') => (None, q'')
                                   end
                   | (None, q') => (None, q')
                   end
    | Throw => (None, q)
    | Catch x h => match eval x q with
                   | (Some n, q') => (Some n, q')
                   | (None, q') => eval h q'
                   end
    | Get => (Some q, q)
    | Put x y => match eval x q with
                 | (Some n, q') => eval y n
                 | (None, q') => (None, q')
                 end
  end.

(** * Compiler *)

Inductive Code : Set :=
| LOAD : nat -> Code -> Code
| ADD : Reg -> Code -> Code
| STORE : Reg -> Code -> Code
| THROW : Code
| UNMARK : Code -> Code
| MARK : Reg -> Code -> Code -> Code
| READ : Code -> Code
| WRITE : Code -> Code
| HALT : Code.

Fixpoint comp' (x : Expr) (r : Reg) (c : Code) : Code :=
  match x with
  | Val n => LOAD n c
  | Add e1 e2 => comp' e1 r (STORE r (comp' e2 (next r) (ADD r c)))
  | Throw => THROW
  | Catch e1 e2 => MARK r (comp' e2 r c) (comp' e1 (next r) (UNMARK c))
  | Get => READ c
  | Put x y => comp' x r (WRITE (comp' y r c))
  end.

Definition comp (x : Expr) : Code := comp' x first HALT.

Definition Han := option Reg.

Inductive RVal : Set :=
| VAL : nat -> RVal
| HAN : Code -> Han -> RVal.

(** * Virtual Machine *)

Inductive Conf' : Type :=
| conf : Code -> nat -> Han -> state -> Conf'
| fail : Han -> state -> Conf'.

Definition Conf : Type := Conf' * Mem RVal.

Notation "⟨ x , y , z , q , s ⟩" := (conf x y z q, s).
Notation "⟪ x , q , s ⟫" := (fail x q, s).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_load n a c s q p : ⟨LOAD n c, a , p, q, s⟩ ==> ⟨c , n, p, q, s⟩
| vm_add c s a r n q p : s[r]=  VAL n -> ⟨ADD r c, a , p, q, s⟩ ==> ⟨c , n + a, p, q, s⟩
| vm_store c s a r q p : ⟨STORE r c, a, p, q, s⟩ ==> ⟨c , a, p, q, s[r:=VAL a]⟩
| vm_throw a s q p : ⟨THROW, a, p, q, s⟩ ==> ⟪p, q, s⟫
| vm_fail p p' s q c : s[p] = HAN c p' -> ⟪ Some p, q, s⟫ ==> ⟨c, 0, p', q, s⟩
| vm_unmark p p' s a q c c' : s[p] = HAN c' p' ->
                            ⟨UNMARK c, a, Some p, q, s⟩ ==> ⟨c, a, p', q, s⟩
| vm_mark p r s a c c' q : ⟨MARK r c' c, a, p, q, s⟩ ==> ⟨c, a, Some r, q, s[r:= HAN c' p]⟩
| vm_read a c s q p : ⟨READ c, a , p, q, s⟩ ==> ⟨c , q, p, q, s⟩
| vm_write a c s q p : ⟨WRITE c, a , p, q, s⟩ ==> ⟨c , a, p, a, s⟩
where "x ==> y" := (VM x y).

Inductive cle : Conf -> Conf -> Prop :=
 | cle_mem  f s s' : s ⊑ s' -> cle (f, s) (f, s').

Hint Constructors cle : core.

(** * Calculation *)

(** Boilerplate to import calculation tactics *)
Module VM <: Machine.
Definition Conf := Conf.
Definition Pre := cle.
Definition Rel := VM.
Lemma monotone : monotonicity cle VM.
prove_monotonicity. Qed.
Lemma preorder : is_preorder cle.
prove_preorder. Qed.
End VM.

Module VMCalc := Calculation mem VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec : forall e r c a p s q,
  freeFrom r s ->
  ⟨comp' e r c, a, p, q, s⟩
    =|>
    match eval e q with
    | (Some n, q') => ⟨c , n, p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.

(** Setup the induction proof *)

Proof.
  induction e;intros.

(** Calculation of the compiler *)

(** - [x = Val n]: *)

  begin
    match eval (Val n) q with
    | (Some n', q') => ⟨c , n' ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  = {auto}
      ⟨ c, n, p, q, s⟩.
  <== {apply vm_load}
      ⟨ LOAD n c, a, p, q, s ⟩.
  [].

(** - [x = Add x1 x2]: *)

  begin
    match eval (Add e1 e2) q with
    | (Some n, q') => ⟨c , n ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  = {auto}
    match eval e1 q with
    | (Some n, q') => match eval e2 q' with
                      | (Some n', q'') => ⟨c , n + n' , p, q'', s⟩
                      | (None, q'') => ⟪p, q'', s⟫
                      end
    | (None, q') => ⟪p, q', s⟫
    end.
  ⊑ { auto }
    match eval e1 q with
    | (Some n, q') => match eval e2 q' with
                      | (Some n', q'') => ⟨c , n + n' ,p, q'', s[r:=VAL n]⟩
                      | (None, q'') => ⟪p, q'', s[r:=VAL n]⟫
                      end
    | (None, q') => ⟪p, q', s⟫
    end.
  <== { apply vm_add }
      match eval e1 q with
      | (Some n, q') => match eval e2 q' with
                        | (Some n', q'') => ⟨ADD r c , n' ,p, q'', s[r:=VAL n]⟩
                        | (None, q'') => ⟪p, q'', s[r:=VAL n]⟫
                        end
      | (None, q') => ⟪p, q', s⟫
      end.
  <|= {apply IHe2}
      match eval e1 q with
      | (Some n, q') => ⟨comp' e2 (next r) (ADD r c) , n ,p, q', s[r:=VAL n]⟩
      | (None, q') => ⟪p, q', s⟫
      end.
  <== { apply vm_store }
      match eval e1 q with
      | (Some n, q') => ⟨STORE r (comp' e2 (next r) (ADD r c)) , n ,p, q', s⟩
      | (None, q') => ⟪p, q', s⟫
      end.
  <|= { apply IHe1 }
    ⟨comp' e1 r (STORE r (comp' e2 (next r) (ADD r c))), a,p, q, s⟩.
  [].

(** - [x = Throw]: *)

  begin
    match eval Throw q with
    | (Some n, q') => ⟨c , n ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  = { auto }
      ⟪p, q, s⟫.
  <== { apply vm_throw }
      ⟨THROW, a, p, q, s⟩.
  [].

(** - [x = Catch x1 x2]: *)

  begin
    match eval (Catch e1 e2) q with
    | (Some n, q') => ⟨c , n ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  = { auto }
      match eval e1 q with
      | (Some n, q') => ⟨c , n ,p, q', s⟩
      | (None, q') => match eval e2 q' with
                      | (Some n', q'') => ⟨c , n' ,p, q'', s⟩
                      | (None, q'') => ⟪p, q'', s⟫
                      end
      end.
  <|= { apply IHe2 }
      match eval e1 q with
      | (Some n, q') => ⟨c , n ,p, q', s⟩
      | (None, q') => ⟨comp' e2  r c , 0 ,p, q', s⟩
      end.
  ⊑ { eauto }
      match eval e1 q with
      | (Some n, q') => ⟨c , n ,p, q', s⟩
      | (None, q') => ⟨comp' e2  r c , 0 ,p, q', s[r:= HAN (comp' e2  r c) p]⟩
      end.
  <== {apply vm_fail}
      match eval e1 q with
      | (Some n, q') => ⟨c , n ,p, q', s⟩
      | (None, q') => ⟪Some r, q', s[r:= HAN (comp' e2  r c) p]⟫
      end.
  ⊑ {auto}
      match eval e1 q with
      | (Some n, q') => ⟨c , n ,p, q', s[r:= HAN (comp' e2  r c) p]⟩
      | (None, q') => ⟪Some r, q', s[r:= HAN (comp' e2  r c) p]⟫
      end.
  <== {eapply vm_unmark}
      match eval e1 q with
      | (Some n, q') => ⟨UNMARK c , n,Some r, q', s[r:= HAN (comp' e2  r c) p]⟩
      | (None, q') => ⟪Some r, q', s[r:= HAN (comp' e2  r c) p]⟫
      end.
  <|= {apply IHe1}
      ⟨comp' e1 (next r) (UNMARK c) , a ,Some r, q, s[r:= HAN (comp' e2  r c) p]⟩.
  <== {apply vm_mark}
      ⟨MARK r (comp' e2  r c) (comp' e1 (next r) (UNMARK c)) , a ,p, q, s⟩.
  [].

  begin
    match eval Get q with
    | (Some n, q') => ⟨c , n ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  = {auto}
      ⟨c , q ,p, q, s⟩.
  <== {apply vm_read}
      ⟨READ c , a ,p, q, s⟩.
  [].

  begin
    match eval (Put e1 e2) q with
    | (Some n, q') => ⟨c , n ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  = {auto}
    match eval e1 q with
    | (Some n, q') => match eval e2 n with
                      | (Some n', q'') => ⟨c , n' ,p, q'', s⟩
                      | (None, q'') => ⟪p, q'', s⟫
                      end
    | (None, q') => ⟪p, q', s⟫
    end.
  <|= {apply IHe2}
    match eval e1 q with
    | (Some n, q') => ⟨comp' e2 r c , n ,p, n, s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  <== {apply vm_write}
    match eval e1 q with
    | (Some n, q') => ⟨WRITE (comp' e2 r c) , n ,p, q', s⟩
    | (None, q') => ⟪p, q', s⟫
    end.
  <|= {apply IHe1}
      ⟨comp' e1 r (WRITE (comp' e2 r c)) , a ,p, q, s⟩.
  [].
Qed.

(** * Soundness *)

(** Since the VM is defined as a small step operational semantics, we *)
(* have to prove that the VM is deterministic and does not get stuck in *)
(* order to derive soundness from the above theorem. *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst;eauto.
  rewrite H in *; dist. rewrite H in H4. dist. rewrite H in H6. dist.
Qed.

Theorem sound x a p q q' s n C :
  freeFrom first s -> eval x q = (Some n, q')
  -> ⟨comp x, a, p, q, s⟩ =>>! C -> exists s', C = ⟨HALT, n,p, q', s'⟩.
Proof.
  intros F E M.
  pose (spec x first HALT a p s q F). unfold Reach in *. repeat autodestruct.
  pose (determ_trc determ_vm) as D.
  unfold determ in D. inversion H0. subst. eexists. eapply D. apply M.
  rewrite E in *.
  split. inversion H1. subst.

  apply H. intro Contra. destruct Contra.
  inversion H3.
Qed.

End State.