Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__angleorderrespectscongruence.
Require Export lemma__angleorderrespectscongruence2.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__ray4.
Require Export logic.
Require Export proposition__05.
Require Export proposition__19.
Definition proposition__20 : forall A B C, (euclidean__axioms.Triangle A B C) -> (euclidean__defs.TG B A A C B C).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (euclidean__axioms.nCol A B C) as H0 by exact H.
assert (* Cut *) (~(B = A)) as H1.
- intro H1.
assert (* Cut *) (euclidean__axioms.Col B A C) as H2.
-- left.
exact H1.
-- assert (* Cut *) (euclidean__axioms.Col A B C) as H3.
--- assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H3.
---- apply (@lemma__collinearorder.lemma__collinearorder B A C H2).
---- destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H4.
--- apply (@euclidean__tactics.Col__nCol__False A B C H0 H3).
- assert (* Cut *) (~(B = C)) as H2.
-- intro H2.
assert (* Cut *) (euclidean__axioms.Col A B C) as H3.
--- right.
right.
left.
exact H2.
--- apply (@euclidean__tactics.Col__nCol__False A B C H0 H3).
-- assert (* Cut *) (euclidean__axioms.neq C B) as H3.
--- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H2).
--- assert (* Cut *) (~(C = A)) as H4.
---- intro H4.
assert (* Cut *) (euclidean__axioms.Col B C A) as H5.
----- right.
right.
left.
exact H4.
----- assert (* Cut *) (euclidean__axioms.Col A B C) as H6.
------ assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H6.
------- apply (@lemma__collinearorder.lemma__collinearorder B C A H5).
------- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H11.
------ apply (@euclidean__tactics.Col__nCol__False A B C H0 H6).
---- assert (* Cut *) (exists D, (euclidean__axioms.BetS B A D) /\ (euclidean__axioms.Cong A D C A)) as H5.
----- apply (@lemma__extension.lemma__extension B A C A H1 H4).
----- destruct H5 as [D H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.neq A D) as H9.
------ assert (* Cut *) ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B A) /\ (euclidean__axioms.neq B D))) as H9.
------- apply (@lemma__betweennotequal.lemma__betweennotequal B A D H7).
------- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
exact H10.
------ assert (* Cut *) (euclidean__axioms.neq D A) as H10.
------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A D H9).
------- assert (* Cut *) (euclidean__axioms.neq B D) as H11.
-------- assert (* Cut *) ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B A) /\ (euclidean__axioms.neq B D))) as H11.
--------- apply (@lemma__betweennotequal.lemma__betweennotequal B A D H7).
--------- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H15.
-------- assert (* Cut *) (euclidean__axioms.neq D B) as H12.
--------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B D H11).
--------- assert (* Cut *) (euclidean__axioms.Cong A D A C) as H13.
---------- assert (* Cut *) ((euclidean__axioms.Cong D A A C) /\ ((euclidean__axioms.Cong D A C A) /\ (euclidean__axioms.Cong A D A C))) as H13.
----------- apply (@lemma__congruenceflip.lemma__congruenceflip A D C A H8).
----------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H17.
---------- assert (* Cut *) (~(euclidean__axioms.Col A D C)) as H14.
----------- intro H14.
assert (* Cut *) (euclidean__axioms.Col B A D) as H15.
------------ right.
right.
right.
right.
left.
exact H7.
------------ assert (* Cut *) (euclidean__axioms.Col D A B) as H16.
------------- assert (* Cut *) ((euclidean__axioms.Col A B D) /\ ((euclidean__axioms.Col A D B) /\ ((euclidean__axioms.Col D B A) /\ ((euclidean__axioms.Col B D A) /\ (euclidean__axioms.Col D A B))))) as H16.
-------------- apply (@lemma__collinearorder.lemma__collinearorder B A D H15).
-------------- destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H24.
------------- assert (* Cut *) (euclidean__axioms.Col D A C) as H17.
-------------- assert (* Cut *) ((euclidean__axioms.Col D A C) /\ ((euclidean__axioms.Col D C A) /\ ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col A C D) /\ (euclidean__axioms.Col C D A))))) as H17.
--------------- apply (@lemma__collinearorder.lemma__collinearorder A D C H14).
--------------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H18.
-------------- assert (* Cut *) (euclidean__axioms.neq A D) as H18.
--------------- assert (* Cut *) ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B A) /\ (euclidean__axioms.neq B D))) as H18.
---------------- apply (@lemma__betweennotequal.lemma__betweennotequal B A D H7).
---------------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H9.
--------------- assert (euclidean__axioms.neq D A) as H19 by exact H10.
assert (* Cut *) (euclidean__axioms.Col A B C) as H20.
---------------- apply (@euclidean__tactics.not__nCol__Col A B C).
-----------------intro H20.
apply (@euclidean__tactics.Col__nCol__False A B C H20).
------------------apply (@lemma__collinear4.lemma__collinear4 D A B C H16 H17 H19).

---------------- apply (@euclidean__tactics.Col__nCol__False A B C H0 H20).
----------- assert (* Cut *) (~(D = C)) as H15.
------------ intro H15.
assert (* Cut *) (euclidean__axioms.Col A D C) as H16.
------------- right.
right.
left.
exact H15.
------------- apply (@H14 H16).
------------ assert (* Cut *) (euclidean__axioms.Triangle A D C) as H16.
------------- apply (@euclidean__tactics.nCol__notCol A D C H14).
------------- assert (* Cut *) (euclidean__defs.isosceles A D C) as H17.
-------------- split.
--------------- exact H16.
--------------- exact H13.
-------------- assert (* Cut *) (euclidean__defs.CongA A D C A C D) as H18.
--------------- apply (@proposition__05.proposition__05 A D C H17).
--------------- assert (* Cut *) (~(euclidean__axioms.Col A C D)) as H19.
---------------- intro H19.
assert (* Cut *) (euclidean__axioms.Col A D C) as H20.
----------------- assert (* Cut *) ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col C D A) /\ ((euclidean__axioms.Col D A C) /\ ((euclidean__axioms.Col A D C) /\ (euclidean__axioms.Col D C A))))) as H20.
------------------ apply (@lemma__collinearorder.lemma__collinearorder A C D H19).
------------------ destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H27.
----------------- apply (@H14 H20).
---------------- assert (* Cut *) (euclidean__defs.CongA A C D D C A) as H20.
----------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA A C D).
------------------apply (@euclidean__tactics.nCol__notCol A C D H19).

----------------- assert (* Cut *) (euclidean__defs.CongA A D C D C A) as H21.
------------------ apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A D C A C D D C A H18 H20).
------------------ assert (* Cut *) (D = D) as H22.
------------------- apply (@logic.eq__refl Point D).
------------------- assert (* Cut *) (B = B) as H23.
-------------------- apply (@logic.eq__refl Point B).
-------------------- assert (* Cut *) (C = C) as H24.
--------------------- apply (@logic.eq__refl Point C).
--------------------- assert (* Cut *) (~(C = D)) as H25.
---------------------- intro H25.
assert (* Cut *) (euclidean__axioms.Col A C D) as H26.
----------------------- right.
right.
left.
exact H25.
----------------------- apply (@H14).
------------------------apply (@euclidean__tactics.not__nCol__Col A D C).
-------------------------intro H27.
apply (@H19 H26).

---------------------- assert (* Cut *) (euclidean__defs.Out C D D) as H26.
----------------------- apply (@lemma__ray4.lemma__ray4 C D D).
------------------------right.
left.
exact H22.

------------------------ exact H25.
----------------------- assert (* Cut *) (euclidean__defs.Out C B B) as H27.
------------------------ apply (@lemma__ray4.lemma__ray4 C B B).
-------------------------right.
left.
exact H23.

------------------------- exact H3.
------------------------ assert (* Cut *) (euclidean__axioms.BetS D A B) as H28.
------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B A D H7).
------------------------- assert (* Cut *) (euclidean__defs.LtA A D C D C B) as H29.
-------------------------- exists D.
exists A.
exists B.
split.
--------------------------- exact H28.
--------------------------- split.
---------------------------- exact H26.
---------------------------- split.
----------------------------- exact H27.
----------------------------- exact H21.
-------------------------- assert (* Cut *) (euclidean__defs.Out D A B) as H30.
--------------------------- apply (@lemma__ray4.lemma__ray4 D A B).
----------------------------right.
right.
exact H28.

---------------------------- exact H10.
--------------------------- assert (* Cut *) (euclidean__defs.Out D C C) as H31.
---------------------------- apply (@lemma__ray4.lemma__ray4 D C C).
-----------------------------right.
left.
exact H24.

----------------------------- exact H15.
---------------------------- assert (* Cut *) (euclidean__defs.Out D B B) as H32.
----------------------------- apply (@lemma__ray4.lemma__ray4 D B B).
------------------------------right.
left.
exact H23.

------------------------------ exact H12.
----------------------------- assert (* Cut *) (euclidean__axioms.Cong D B D B) as H33.
------------------------------ apply (@euclidean__axioms.cn__congruencereflexive D B).
------------------------------ assert (* Cut *) (euclidean__axioms.Cong D C D C) as H34.
------------------------------- apply (@euclidean__axioms.cn__congruencereflexive D C).
------------------------------- assert (* Cut *) (euclidean__axioms.Cong B C B C) as H35.
-------------------------------- apply (@euclidean__axioms.cn__congruencereflexive B C).
-------------------------------- assert (* Cut *) (euclidean__defs.CongA A D C B D C) as H36.
--------------------------------- exists B.
exists C.
exists B.
exists C.
split.
---------------------------------- exact H30.
---------------------------------- split.
----------------------------------- exact H31.
----------------------------------- split.
------------------------------------ exact H32.
------------------------------------ split.
------------------------------------- exact H31.
------------------------------------- split.
-------------------------------------- exact H33.
-------------------------------------- split.
--------------------------------------- exact H34.
--------------------------------------- split.
---------------------------------------- exact H35.
---------------------------------------- exact H16.
--------------------------------- assert (* Cut *) (euclidean__defs.CongA B D C A D C) as H37.
---------------------------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A D C B D C H36).
---------------------------------- assert (* Cut *) (euclidean__defs.LtA B D C D C B) as H38.
----------------------------------- apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 A D C D C B B D C H29 H37).
----------------------------------- assert (* Cut *) (~(euclidean__axioms.Col B C D)) as H39.
------------------------------------ intro H39.
assert (* Cut *) (euclidean__axioms.Col B A D) as H40.
------------------------------------- right.
right.
right.
right.
left.
exact H7.
------------------------------------- assert (* Cut *) (euclidean__axioms.Col D B A) as H41.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B D) /\ ((euclidean__axioms.Col A D B) /\ ((euclidean__axioms.Col D B A) /\ ((euclidean__axioms.Col B D A) /\ (euclidean__axioms.Col D A B))))) as H41.
--------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A D H40).
--------------------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
-------------------------------------- assert (* Cut *) (euclidean__axioms.Col D B C) as H42.
--------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B D C) /\ (euclidean__axioms.Col D C B))))) as H42.
---------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C D H39).
---------------------------------------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H47.
--------------------------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H43.
---------------------------------------- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq D A) /\ (euclidean__axioms.neq D B))) as H43.
----------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal D A B H28).
----------------------------------------- destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H11.
---------------------------------------- assert (euclidean__axioms.neq D B) as H44 by exact H12.
assert (* Cut *) (euclidean__axioms.Col B A C) as H45.
----------------------------------------- apply (@euclidean__tactics.not__nCol__Col B A C).
------------------------------------------intro H45.
apply (@euclidean__tactics.Col__nCol__False B A C H45).
-------------------------------------------apply (@lemma__collinear4.lemma__collinear4 D B A C H41 H42 H44).

----------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H46.
------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H46.
------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A C H45).
------------------------------------------- destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H47.
------------------------------------------ apply (@H14).
-------------------------------------------apply (@euclidean__tactics.not__nCol__Col A D C).
--------------------------------------------intro H47.
apply (@euclidean__tactics.Col__nCol__False A B C H0 H46).

------------------------------------ assert (* Cut *) (~(euclidean__axioms.Col C D B)) as H40.
------------------------------------- intro H40.
assert (* Cut *) (euclidean__axioms.Col B C D) as H41.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col C B D) /\ (euclidean__axioms.Col B D C))))) as H41.
--------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C D B H40).
--------------------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
-------------------------------------- apply (@H14).
---------------------------------------apply (@euclidean__tactics.not__nCol__Col A D C).
----------------------------------------intro H42.
apply (@H39 H41).

------------------------------------- assert (* Cut *) (euclidean__defs.CongA C D B B D C) as H41.
-------------------------------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA C D B).
---------------------------------------apply (@euclidean__tactics.nCol__notCol C D B H40).

-------------------------------------- assert (* Cut *) (euclidean__defs.CongA B C D D C B) as H42.
--------------------------------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C D).
----------------------------------------apply (@euclidean__tactics.nCol__notCol B C D H39).

--------------------------------------- assert (* Cut *) (euclidean__defs.LtA C D B D C B) as H43.
---------------------------------------- apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 B D C D C B C D B H38 H41).
---------------------------------------- assert (* Cut *) (euclidean__defs.LtA C D B B C D) as H44.
----------------------------------------- apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence C D B D C B B C D H43 H42).
----------------------------------------- assert (* Cut *) (euclidean__axioms.Triangle B C D) as H45.
------------------------------------------ apply (@euclidean__tactics.nCol__notCol B C D H39).
------------------------------------------ assert (* Cut *) (euclidean__defs.Lt B C B D) as H46.
------------------------------------------- apply (@proposition__19.proposition__19 B C D H45 H44).
------------------------------------------- assert (* Cut *) (euclidean__defs.TG B A A C B C) as H47.
-------------------------------------------- exists D.
split.
--------------------------------------------- exact H7.
--------------------------------------------- split.
---------------------------------------------- exact H13.
---------------------------------------------- exact H46.
-------------------------------------------- exact H47.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import Coq.Logic.FunctionalExtensionality.

(* 数学的現象を追う *)

(* suahra 修正 20220903 *)

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

Variable M : finType.

(* 既約なベクトル空間 *)
Definition VS := M -> bool.
Parameter X : VS.
Parameter o : VS.

Definition belong (V : VS) (x : M) := V x.
(* 以下では不使用で、直接 V x の形で使う。 *)

Definition Subset (W V : VS) := forall (x : M), W x -> V x.

(*
csm と同じように、こちらの定義のほうが、使いやすい。
*)
Axiom MotherSet : forall x, X x = true.
Axiom EmptySet : forall x, o x = false.

(*
Axiom FullSpace : forall (V : VS), Subset V X.
Axiom ZeroSpace : forall (V : VS), Subset o V.  (* 誤記修正 *)
*)

Lemma FullSpace : forall V, Subset V X.  (* csmのSub_Motherと同じ。 *)
Proof.
  move=> X H.
  by rewrite MotherSet.
Qed.

Lemma ZeroSpace : forall V, Subset o V.   (* csmのSub_Emptyと同じ。 *)
Proof.
  move=> V H.
  by rewrite EmptySet.
Qed.

(* Endomorphism の像 : 本当は準同型の条件も付加するべきであるが使わないので略 *)
Definition ImgOf (f : M -> M) (V : VS) : M -> bool :=
  fun (y : M) => [exists x : M, (y == f x) && V x].
Notation "f @ V" := (ImgOf f V) (at level 40, left associativity).

(* ベクトル空間の直和 *)
(* Definition DirectSum (V W : VS) := fun (x : M) => V x \/ W x. *)
Definition DirectSum (V W : VS) := fun (x : M) => V x || W x.
Notation "V + W" := (DirectSum V W) (at level 50, left associativity).

Check functional_extensionality
  : forall f g : _ -> _, (forall x : _, f x = g x) -> f = g.

Lemma DirectSumC : forall (V W : VS) (f : M -> M),
    V + W = W + V.
Proof.
  move=> V W f.
  rewrite /DirectSum.
  apply: functional_extensionality => x.
  by rewrite orbC.
Qed.

Lemma DirectSumDist : forall (V W : VS) (f : M -> M),
    f @ (V + W) = f @ V + f @ W.
Proof.
  move=> V W f.
  apply: functional_extensionality => y.
  rewrite /ImgOf /DirectSum.
  apply/idP/idP.
  - case/existsP => x.
    case/andP => H1 /orP [] H2.
    + apply/orP/or_introl/existsP.
      exists x.
      apply/andP.
      by split.
    + apply/orP/or_intror/existsP.
      exists x.
      apply/andP.
      by split.
  - case/orP => /existsP [x /andP [H1 H2]].
    + apply/existsP.
      exists x.
      apply/andP.
      split=> //.
      by apply/orP/or_introl.
    + apply/existsP.
      exists x.
      apply/andP.
      split=> //.
      by apply/orP/or_intror.
Qed.

Lemma DirectSum0V : forall (V : VS),
    o + V = V.
Proof.
  move=> V.
  apply: functional_extensionality => y.
  rewrite /ImgOf /DirectSum.
  by rewrite EmptySet orFb.
Qed.

Lemma DirectSumV0 : forall (V : VS),
    V + o = V.
Proof.
  move=> V.
  apply: functional_extensionality => y.
  rewrite /ImgOf /DirectSum.
  by rewrite EmptySet orbF.
Qed.

Lemma DirectSumXV : forall (V : VS),
    X + V = X.
Proof.
  move=> V.
  apply: functional_extensionality => y.
  rewrite /ImgOf /DirectSum.
  by rewrite MotherSet orTb.
Qed.

Lemma DirectSumVX : forall (V : VS),
    V + X = X.
Proof.
  move=> V.
  apply: functional_extensionality => y.
  rewrite /ImgOf /DirectSum.
  by rewrite MotherSet orbT.
Qed.

(********)

Definition Img (f : M -> M) :=  ImgOf f X.

(* 準同型定理 : 証明される事実だが, 準同型性として使います. *)
Parameter Ker : (M -> M) -> VS.
Axiom ImgKer : forall (f : M -> M), f @ (Ker f) = o.

(* exists の equal に関する補題 *)
Check eq_existsb
  : forall (T : finType) (P1 P2 : pred T),
    P1 =1 P2 -> [exists x, P1 x] = [exists x, P2 x].
Check eq_existsb_in
  : forall (T : finType) (D P1 P2 : pred T),
    (forall x : T, D x -> P1 x = P2 x) ->
    [exists (x | D x), P1 x] = [exists (x | D x), P2 x].

Lemma eq_existsb_in'
  : forall (T : finType) (D P1 P2 : pred T),
    [exists (x | D x), P1 x] = [exists (x | D x), P2 x] ->
    (forall x : T, D x -> P1 x = P2 x).
Proof.
Admitted.

(*
Lemma test (x : M) (f : M -> M) X Y :
  [exists x0, (x == f x0) && X x0] = [exists x0, (x == f x0) && Y x0] -> X = Y.
Proof.
  move/eq_existsb_in' => H.
  apply: functional_extensionality => y.
  move: (H y) => H'.
  apply: H'.
Admitted.
*)

(* eq_existsb_in の逆が成り立つとしても。 *)
(* これは証明できないだろう。 *)
(* forall x,P(x) -> exists x,P(x) だが、逆は成り立たない。 *)
Lemma fex f X Y : f @ X = f @ Y -> X = Y.
Proof.
  rewrite /ImgOf => H.
  apply: functional_extensionality => x.
  have EQ (f' g' : M -> bool) y : f' = g' -> f' y = g' y by move=> ->.
  move: (@EQ _ _ x H).
  move/eq_existsb_in' => H'.
  rewrite H' //.
Admitted.

Lemma Endomorphism : forall (f : M -> M) (V W : VS),
    f @ V = f @ W -> V = W + Ker f.
Proof.
  move=> f V W H.
  apply: (@fex f).
  rewrite DirectSumDist.
  rewrite ImgKer DirectSumV0.
  done.
Qed.

(* *** *)

(* これは、オリジナルから無変更で証明できる。 *)
Lemma ProjectionExisits : forall (f : M -> M),
    X = Img f + Ker f <-> f @ (f @ X) = f @ X.
Proof.
  split=> Hf.
  - have H : f @ (f @ X + Ker f) = f @ X by rewrite -Hf.
    rewrite DirectSumDist in H.
    rewrite ImgKer in H.
    by rewrite DirectSumV0 in H.
  - apply: Endomorphism.
    by rewrite Hf.
Qed.

Definition ZeroComponent (V : VS) (f : M -> M) := f @ V = o.
Definition InvariantComponent (V : VS) (f : M -> M) := f @ V = V.
Definition IrreducibleComponent (V : VS) (f : M -> M) :=
  (forall (W : VS), Subset W V -> f @ W = W -> W = V \/ W = o).

(* END *)


(** * Well-definition predicate for the Sitpn Structure. *)

Require Import CoqLib.
Require Import GlobalTypes.
Require Import sitpn.Sitpn.
Require Import sitpn.SitpnFacts.
Require Import sitpn.SitpnTypes.
Require Import sitpn.SitpnSemanticsDefs.
Require Import sitpn.SitpnUtils.

Set Implicit Arguments.

(** ** Well-definition of the transition and place sets *)

(** States that a given place [p] of [sitpn] is isolated.  *)

Definition PlaceIsIsolated (sitpn : Sitpn) (p : P sitpn) : Prop :=
  forall t, pre p t = None /\ post t p = None.

(** States that [sitpn] has no isolated place. *)

Definition HasNoIsolatedPlace (sitpn : Sitpn) : Prop :=
  forall (p : P sitpn), ~PlaceIsIsolated p.

(** States that a given transition [t] of [sitpn] is isolated.  *)

Definition TransitionIsIsolated (sitpn : Sitpn) (t : T sitpn) : Prop :=
  forall p, pre p t = None /\ post t p = None.

(** States that [sitpn] has no isolated transition. *)

Definition HasNoIsolatedTransition (sitpn : Sitpn) : Prop :=
  forall (t : T sitpn), ~TransitionIsIsolated t.

(** ** Well-definition of the priority relation *)

Definition PriorityRelIsWellDefined (sitpn : Sitpn) :=
  IsStrictOrder (T sitpn) (@pr sitpn).

(** ** Definitions about transitions in conflict *)

(* States that [{a, b}] is a pair in list [l] *)

Definition IsAPair {A : Type} (eqA : A -> A -> Prop) (a b : A) (l : list A) :=
  InA eqA a l /\ InA eqA b l /\ ~eqA a b.

Definition ForallPair {A : Type} (eqA : A -> A -> Prop) (P : A -> A -> Prop) (l : list A) : Prop:=
  forall a b, IsAPair eqA a b l -> P a b.

(* Cases of mutual exclusion between two transitions

   TO DO:
   - Add mutual exclusion by mean of an "anneau memoire"

 *)

(* Two transitions are in mutual exclusion by mean of an inhibitor arc
   if there exists a common input place connecting [t] by a basic arc
   and [t'] by an inhibitor arc, or the other way around.

   Note that the two connecting arcs must have the same weight to be
   mutually exclusive.

 *)

Definition MutualExclByInhib {sitpn} (t t' : T sitpn) :=
  exists p ω, (pre p t = Some (basic, ω) \/ pre p t = Some (test, ω)) /\ pre p t' = Some (inhibitor, ω)
              \/
              pre p t = Some (inhibitor, ω) /\ (pre p t' = Some (basic, ω) \/ pre p t' = Some (test, ω)).

(* Two transitions are in mutual exclusion by mean of inverse
   conditions if there exists a condition [c] associated to [t], and
   the inverse of condition [c] associated to [t']. *)

Definition MutualExclByConds {sitpn} (t t' : T sitpn) :=
  exists c, has_C t c = one /\ has_C t' c = mone
            \/ has_C t c = mone /\ has_C t' c = one.

Definition MutualExcl {sitpn} (t t' : T sitpn) :=
  MutualExclByInhib t t' \/ MutualExclByConds t t'.

(* States that in a given conflict group, conflicts are solved by
   mutual exclusion for all pair of transitions. *)

Definition AllConflictsSolvedByMutualExcl sitpn (cg : list (T sitpn)) :=
  ForallPair (@Teq sitpn) MutualExcl cg.

(* States that for a given [sitpn], and for a given conflict group
   [cg], the priority relation is a strict total order of the elements
   of [cg]. *)

Definition PrIsTotalOverConflictGroup sitpn (cg : list (T sitpn)) : Prop :=
  IsStrictTotalOrder
    { t | InA (@Teq sitpn) t cg }
    (fun t t' => (@Teq sitpn (proj1_sig t) (proj1_sig t')))
    (fun t t' => @pr sitpn (proj1_sig t) (proj1_sig t')).

(* For all place [p], and conflicting output transitions of [p], all
   pairs of conflict are either solved by mutual exclusion or the
   priority relation is a strict total order over the set of
   conflicting output transitions of [p]. *)

Definition AllConflictsSolved (sitpn : Sitpn) :=
  forall (p : P sitpn),
    AllConflictsSolvedByMutualExcl (coutputs_of_p p)
    \/ PrIsTotalOverConflictGroup (coutputs_of_p p).

(** Defines a predicate stating that an [Sitpn] is well-defined, that is:

    - The set of places and transitions of the [Sitpn] must not be empty.
    - There are no isolated (unconnected) place or transition.
    - The priority relation is a strict order over the set
      of transitions.
    - All conflicts are solved thanks to the priority relation
      or another mean of mutual exclusion.
 *)

Record IsWellDefined (sitpn : Sitpn) :=
  {
    pls_not_empty : places sitpn <> nil;
    trs_not_empty : transitions sitpn <> nil;
    no_iso_pl : HasNoIsolatedPlace sitpn;
    no_iso_tr : HasNoIsolatedTransition sitpn;
    all_confl_solved : AllConflictsSolved sitpn;
  }.


Require Import Program.

Definition type_cast {T1 T2 : Set} (H : T1 = T2) (x : T1) : T2 := eq_rect T1 (fun T3 : Set => T3) x T2 H.
Definition type_castT {T1 T2 : Type} (H : T1 = T2) (x : T1) : T2 := eq_rect T1 (fun T3 : Type => T3) x T2 H.

Lemma type_cast_type_cast_is_id A B (c1 : A = B) (c2 : B = A) x : type_cast c1 (type_cast c2 x) = x.
  dependent destruction c1.
  dependent destruction c2.
  auto.
Qed.

Lemma type_cast_invariance {A B} (eq1 eq2 : A = B) x : type_cast eq1 x = type_cast eq2 x.
  dependent destruction eq1.
  dependent destruction eq2.
  auto.
Qed.


Require Import ExtLib.Data.Vector.
Require Import ExtLib.Structures.Functor.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Section poly.
  Variable typ : Set.

  Fixpoint polymorphic@{U} (n : nat) (T : Type@{U}) : Type@{U} :=
    match n return Type@{U} with
    | 0 => T
    | S n => typ -> polymorphic n T
    end.

  Section polymorphicD.
    Context {T : Type} (TD : T -> Prop).

    Fixpoint polymorphicD {n} : polymorphic n T -> Prop :=
      match n as n return polymorphic n T -> Prop with
      | 0 => fun p => TD p
      | S n => fun p => forall t, polymorphicD (p t)
      end.
  End polymorphicD.

  Fixpoint inst {T} (n : nat)
  : polymorphic n T -> vector typ n -> T :=
    match n as n return polymorphic n T -> vector typ n -> T with
    | 0 => fun p _ => p
    | S n => fun p a => inst (p (Vector.vector_hd a)) (Vector.vector_tl a)
    end.

  Theorem inst_sound
  : forall {T} {n} (y: polymorphic n T) (P : T -> Prop) v,
      polymorphicD P y ->
      P (inst y v).
  Proof.
    induction n; simpl; eauto.
    intros; eapply IHn; eauto.
  Qed.

  Section make.
    Context {U : Type}.
    Fixpoint make_polymorphic n {struct n}
    : (vector typ n -> U) -> polymorphic n U :=
      match n as n return (vector typ n -> U) -> polymorphic n U with
      | 0 => fun P => P (Vnil _)
      | S n' => fun P => fun v => (make_polymorphic (fun V => P (Vcons v V)))
      end.

    Theorem inst_make_polymorphic
    : forall n f v,
        @inst U n (make_polymorphic f) v = f v.
    Proof.
      induction v; simpl; try rewrite IHv; reflexivity.
    Qed.

    Theorem polymorphicD_make_polymorphic
    : forall (UD : U -> Prop) n (p : vector _ n -> _),
        (forall v, UD (p v)) ->
        polymorphicD UD (make_polymorphic p).
    Proof.
      induction n; simpl; eauto.
    Qed.

  End make.
End poly.

Arguments make_polymorphic {_ _ n} _.
Arguments polymorphicD {_ _} _ {n} _.

Section fmap_polymorphic.
  Context {Z : Set} {T U : Type}.
  Variable f : T -> U.
  Fixpoint fmap_polymorphic (n : nat)
  : polymorphic Z n T -> polymorphic Z n U :=
    match n with
    | 0 => f
    | S n => fun x y => fmap_polymorphic n (x y)
    end.
End fmap_polymorphic.

Instance Functor_polymorphic Z n : Functor (polymorphic Z n) :=
{ fmap := fun T U f => @fmap_polymorphic Z T U f n }.

Arguments inst {typ T n} p v : clear implicits, rename.

Require Import MirrorCore.Reify.ReifyClass.

Section rpolymorphic.
  Context {T : Set} {U : Type}.
  Context {r : Reify U}.

  Fixpoint rpolymorphic n : Command (polymorphic T n U) :=
    match n as n return Command (polymorphic T n U) with
    | 0 => CCall (reify_scheme U)
    | S n => Patterns.CPiMeta (rpolymorphic n)
    end.

  Global Instance Reify_polymorphic n : Reify (polymorphic T n U) :=
  { reify_scheme := CCall (rpolymorphic n) }.
End rpolymorphic.

Arguments rpolymorphic _ _ _ _ : clear implicits.


Require Import String.
Require Import Arith.
Require Import Ascii.
Require Import Bool.
Require Import Coq.Strings.Byte.
Require Import Strings.String.
Open Scope list_scope.
Require Import List.
Import ListNotations.
Local Open Scope string_scope.

Scheme Equality for string.
Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

(* Instructiuni adaugate in plus fata de laborator :
   -switch++         -xor, xnor, nand nor++     -comentarii ++
   -break ++         -do-while ++               -expresii lambda ++
   -stiva ++         -tipuri de variabile ++    -siruri de caractere++

*)

Inductive AExp :=
| anum : nat -> AExp
| avar : string -> AExp
| aplus : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp
| adiv : AExp -> AExp -> AExp
| amod : AExp -> AExp -> AExp
| asub : AExp -> AExp -> AExp.

Coercion anum : nat >-> AExp.
Coercion avar : string >-> AExp.
Notation "A +' B" := (aplus A B) (at level 48).
Notation "A *' B" := (amul A B) (at level 46).
Notation "A -' B" := (asub A B) (at level 48).
Notation "A %' B" := (amod A B) (at level 46).
Notation "A /' B" := (adiv A B) (at level 46).
Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| berror
| blessthan : AExp -> AExp -> BExp
| bvar : string -> BExp
| bgrthan : AExp -> AExp -> BExp
| bor : BExp -> BExp ->BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp
| bxor : BExp -> BExp -> BExp
| bnand: BExp -> BExp -> BExp
| bnor: BExp -> BExp -> BExp.

Inductive stiva :=
| nil : stiva
| cd : nat -> stiva -> stiva .

Notation "A <=' B" := (blessthan A B) (at level 53).
Notation "A >=' B" := (bgrthan A B) (at level 53).
Notation "A '\x/' B" := (bxor A B) (at level 53).
Notation "A '\o/' B" := (bor A B) (at level 53).
Notation "A '\n/' B" := (bnor A B) (at level 53).
Notation "A '/a\' B" := (band A B) (at level 53).
Notation "A '/n\' B" := (bnand A B) (at level 53).

Check ( ( 10<='2) /a\ (btrue) ) \o/ ( ( bfalse) \x/ ( 22 >=' 2)) .
(* switch
Inductive case :=
| case1 : nat -> Stmt -> case.
*)

Inductive case:=
| case1: nat->Type-> case.

Inductive ErrorNat :=
  | error_nat : ErrorNat
  | num : nat -> ErrorNat.

Inductive ErrorBool :=
  | error_bool : ErrorBool
  | boolean : bool -> ErrorBool.

Inductive ErrorString :=
| error_string: ErrorString
| string1 : string -> ErrorString.

Coercion num: nat >-> ErrorNat.
Coercion boolean: bool >-> ErrorBool.
Coercion string1 : string >-> ErrorString.

Inductive Pair( S: Type)(T: Type) :=
| pair: S -> T -> Pair S T
| lpair : S -> T -> Pair S T -> Pair S T.
Inductive Strings :=
| null : Strings
| str : string -> Strings.

Inductive Result :=
  | err_undecl : Result
  | err_assign : Result
  | default : Result
  | res_nat : ErrorNat -> Result
  | res_bool : ErrorBool -> Result
  | res_stiva : stiva ->Result
  | res_string : ErrorString -> Result.

Inductive Stmt :=
| decl_b : string -> Stmt
| decl_n : string -> Stmt
| decl_st : string -> Stmt
| decl_string : string -> Stmt
| assign_n : string -> AExp -> Stmt
| assign_b : string -> BExp -> Stmt
| assign_string : string -> Strings -> Stmt
| push_st : string -> ErrorNat -> Stmt
| pop_st : string -> Stmt
| get_st : string -> Stmt
| empty_st : string -> Stmt
| referinta : string -> string -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt
| ifelse : BExp -> Stmt -> Stmt -> Stmt
| ifthen : BExp -> Stmt -> Stmt
| dowhile : Stmt -> BExp -> Stmt
| breakwhile : BExp -> Stmt -> string -> Stmt
| while_break_st : BExp -> Stmt -> string -> Stmt -> Stmt
| comment : string -> Stmt
| apelfct: string -> list string -> Stmt
| switchdef_base : string -> AExp -> Stmt -> Stmt
| switchdef : AExp -> Stmt ->Stmt
| switchtry : string -> Pair AExp Stmt -> Stmt
| strcatd : string -> string -> Stmt
| strcmpd :string -> Result -> Result -> Stmt
| strlenassign : string -> Result -> Stmt
| strcpyd : string -> ErrorString -> Stmt
| lambda : string -> Stmt -> Result -> Stmt.

(*
Inductive stringop :=
| sstring : string -> stringop
| sconc : string -> string -> stringop
| scmp : string -> string -> stringop
| strcpy : string -> string -> stringop.
*)
Notation " 'whileb' '(' B ')' '{' A C D '}'":=(while_break_st B A C D)(at level 96).
Notation " 'if1' '(' A ')'  'then1' B" :=(ifthen A B) (at level 96).
Notation " 'if2' '(' A ')' 'then2' B 'else2' C" := (ifelse A B C)(at level 96).

Notation " 'do1' '{' A '}' 'while1' B " := (dowhile A B) (at level 96).
Notation " X ::n= A" :=(assign_n X A )(at level 50).
Notation " X ::b= A" :=(assign_b X A )(at level 50).
Notation " 'int1' X " := (decl_n X) (at level 50).
Notation " 'strings1' X " := (decl_string X) (at level 50).
Notation " 'bool1' X " := (decl_b X) (at level 50).
Notation " 'stack' X " := (decl_st X) (at level 50).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 50).
Notation " 'For1' '(' s0 ';' b ';' s1 ')' '{' s2 '}' " :=( s0 ;; while b ( s2;; s1))(at level 96).
Notation " 'Forb' '(' s0 ';' b ';' s1 ')' '{' s2 '}' " :=( s0 ;; while_break_st b ( s2;; s1))(at level 96).
Notation " 'do' '{' s1 '}' 'while1' '(' b ')'":= ( s1;; while b s1 ) (at level 96).
Notation " x ::=& y" :=(referinta x y)(at level 49).
Notation " '/*' C '*/' " := (comment C )(at level 96).
Notation " x ::s= 'strlen' y" := (strlenassign x y) (at level 96).

Definition Env := string -> Result.
Definition env : Env := fun x => err_undecl.
Scheme Equality for Result.

(* operatii cu stringuri *)
Fixpoint strlen (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (strlen s')
  end.
(*Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.*)

Local Open Scope lazy_bool_scope.
Fixpoint strcmp (s1 : string ) (s2 : string) : bool :=
 match s1, s2 with
 | EmptyString, EmptyString => true
 | String c1 s1', String c2 s2' => Ascii.eqb c1 c2 &&& strcmp s1' s2'
 | _,_ => false
 end.
Compute eqb "saluta" "saluta".
Compute strlen "salut".

Reserved Notation "x +=+ y" (right associativity, at level 60).

Fixpoint append (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (s1' +=+ s2)
  end
where "s1 +=+ s2" := (append s1 s2) : string_scope.
Compute append "dell" (append "cf" "sal").

(*
Definition switch1:=(switchdef "var"   [ "m"::=8 ; "n"::=9 ] ) .
*)
Check "x"::=& "y".
Check if1 ( btrue ) then1 ("x"::n=3).
Check For1 ( "x"::n=13 ; "x" <=' 20 ; "x"::n="x"+'1 ) { ("s"::n="s"+'4) } .
Check /* "am adaugat un comentariu" */.

Check (
  "j"::n=20 ;;
  if2 ( "i" <=' "j")
      then2 ("s"::n=18 )
  else2
      ("s"::n=10 ) ;;
  /*"am adaugat un comentariu"*/;;
  "z" ::=& "m";;
  For1 ( "x"::n=13 ; "x" <=' 20 ; "x"::n="x"+'1 )
     { ("s"::n="s"+'4)
      }
 ).

(*semantica*)

Definition check_eq_over_types (t1 : Result)(t2 : Result) : bool :=
  match t1 with
  | err_assign => match t2 with
                   | err_assign => true
                   | _ => false
                   end
  | err_undecl => match t2 with
                   | err_undecl => true
                   | _ => false
                   end
| res_nat _x => match t2 with
                   | res_nat _y=> true
                   | _ => false
                   end
| res_bool _b => match t2 with
                   | res_bool _c => true
                   | _ => false
                   end
| default => match t2 with
                   | default => true
                   | _ => false
                   end
| res_stiva _s => match t2 with
                   | res_stiva _t => true
                   | _=>false
                   end
| res_string _s => match t2 with
                   | res_string _t => true
                   | _=>false
                   end
end.

Compute (check_eq_over_types (res_nat 1000) (res_nat 100)).
Compute (check_eq_over_types err_undecl (res_nat 100)).
Compute (check_eq_over_types (res_nat 100 ) (res_bool true)).
Compute (check_eq_over_types (res_bool true ) (res_bool false)).

Definition update (env: Env) (x: string) (v:Result) :Env :=
 fun y =>
    if ( eqb y x )
    then
          (* daca este cu tipul err_undecl => nu a mai fost folosit pana acum si val e diferita default=> nu am declarat-o*)
        if (andb (check_eq_over_types err_undecl (env y)) (negb (check_eq_over_types default v )))
        then err_undecl (* daca este nedeclarat *)
        else (*daca este nedeclarata si vreau sa o declar*)
        if (andb (check_eq_over_types err_undecl (env y)) (check_eq_over_types default v))
                then v
        else (*daca este declarata, dar neatribuita*)
            if ( andb (check_eq_over_types default (env y)) true)
                                        then v
            else (*daca sunt de acelasi tip*)
            if ( andb (check_eq_over_types (env y) v) true ) then v (* daca sunt acelasi tip*)
             else err_assign
    else (env y).

Definition env2 : Env := fun x => err_undecl.
Compute (update (update (update env2 "y" (default)) "y" (res_nat 3)) "y" (res_nat 6)) "y".
Compute (update env2 "y" (default)) "y".

Definition plus_ErrorNat (n1 n2 :ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 + v2)
    end.

Definition sub_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num n1, num n2 => if Nat.ltb n1 n2
                        then error_nat
                        else num (n1 - n2)
    end.

Definition mul_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | num v1, num v2 => num (v1 * v2)
    end.

Definition div_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, num 0 => error_nat
    | num v1, num v2 => num (Nat.div v1 v2)
    end.

Definition mod_ErrorNat (n1 n2 : ErrorNat) : ErrorNat :=
  match n1, n2 with
    | error_nat, _ => error_nat
    | _, error_nat => error_nat
    | _, num 0 => error_nat
    | num v1, num v2 => num (v1 - v2 * (Nat.div v1 v2))
    end.
Fixpoint aeval_fun (a : AExp) (env : Env) : ErrorNat :=
  match a with
  | avar v => match (env v) with
                | res_nat n => n
                | _ => error_nat
                end
  | anum v => v
  | aplus a1 a2 => (plus_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  | amul a1 a2 => (mul_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  | asub a1 a2 => (sub_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  | adiv a1 a2 => (div_ErrorNat  (aeval_fun a1 env) (aeval_fun a2 env))
  | amod a1 a2 => (mod_ErrorNat (aeval_fun a1 env) (aeval_fun a2 env))
  end.
(*Notation "S [ V /'' X ]" := (update S X V) (at level 0). *)
Reserved Notation "A =[ S ]=> N" (at level 60).
Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive aeval : AExp -> Env -> ErrorNat -> Prop :=
| const : forall n sigma, anum n =[ sigma ]=> n
| var : forall v sigma, avar v =[ sigma ]=>  match (sigma v) with
                                              | res_nat x => x
                                              | _ => error_nat
                                              end
| add : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (plus_ErrorNat i1 i2) ->
    a1 +' a2 =[sigma]=> n
| times : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (mul_ErrorNat i1 i2) ->
    a1 *' a2 =[sigma]=> n
| substract : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (sub_ErrorNat i1 i2) ->
    a1 -' a2 =[sigma]=> n
| division : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (div_ErrorNat  i1 i2) ->
    a1 /' a2 =[sigma]=> n
| modulo : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (mod_ErrorNat i1 i2) ->
    a1 %' a2 =[sigma]=> n
where "a =[ sigma ]=> n" := (aeval a sigma n).

Example ex : 5 -' 10 =[ env ]=> error_nat.
Proof.
eapply substract.
+eapply const.
+eapply const.
+simpl. auto.
Qed.

Example ex2 : 10 /' 0=[ env ]=> error_nat.
Proof.
eapply division.
+eapply const.
+eapply const.
+simpl. auto.
Qed.

Definition lt_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => boolean ( Nat.leb v1 v2) end.
Compute lt_ErrorBool 3 error_nat.

Definition gr_ErrorBool (n1 n2 : ErrorNat) : ErrorBool :=
  match n1, n2 with
    | error_nat, _ => error_bool
    | _, error_nat => error_bool
    | num v1, num v2 => boolean (negb (Nat.ltb v1 v2) )
    end.

Definition not_ErrorBool (n :ErrorBool) : ErrorBool :=
  match n with
    | error_bool => error_bool
    | boolean v => boolean (negb v)
    end.

Definition and_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean (andb v1 v2)
    end.

Definition or_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean (orb v1 v2)
    end.
Definition xor_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => match v1, v2 with
                                | true, true => boolean false
                                | false, false => boolean false
                                | _, _ => boolean true
                                end
    end.
Definition bnand_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean ( negb (andb v1 v2))
    end.
Definition bnor_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean ( negb (orb v1 v2))
    end.
Definition nxnor_ErrorBool (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
    | error_bool, _ => error_bool
    | _, error_bool => error_bool
    | boolean v1, boolean v2 => boolean ( negb (andb v1 v2))
    end.

Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval : BExp -> Env -> ErrorBool -> Prop :=
| b_error: forall sigma, berror  ={ sigma }=> error_bool
| b_true : forall sigma, btrue ={ sigma }=> true
| b_false : forall sigma, bfalse ={ sigma }=> false
| b_var : forall v sigma, bvar v ={ sigma }=>  match (sigma v) with
                                                | res_bool x => x
                                                | _ => error_bool
                                                end
| b_lessthan : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = (lt_ErrorBool i1 i2) ->
    a1 <=' a2 ={ sigma }=> b
|b_grthan : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = (gr_ErrorBool i1 i2) ->
    a1 >=' a2 ={ sigma }=> b
| b_not : forall a1 i1 sigma b,
    a1 ={ sigma }=> i1 ->
    b = (not_ErrorBool i1) ->
    bnot a1 ={ sigma }=> b
| b_and : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (and_ErrorBool i1 i2) ->
    (band a1 a2) ={ sigma }=> b
| b_or : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (or_ErrorBool i1 i2) ->
    (bor a1 a2) ={ sigma }=> b
| b_xor : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (xor_ErrorBool i1 i2) ->
    (bxor a1 a2) ={ sigma }=> b
| b_nor : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (bnor_ErrorBool i1 i2) ->
    (bnor a1 a2) ={ sigma }=> b
| b_nand : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = (bnand_ErrorBool i1 i2) ->
    (bnand a1 a2) ={ sigma }=> b
where "B ={ S }=> B'" := (beval B S B').

(* XOR, OR, NOR, NAND, NXOR*)
Compute xor_ErrorBool true false.
Compute or_ErrorBool true false.
Compute nxnor_ErrorBool (  or_ErrorBool true false) false.
Compute bnand_ErrorBool ( nxnor_ErrorBool (  or_ErrorBool true false) false) true.
Compute and_ErrorBool (bnand_ErrorBool ( nxnor_ErrorBool (  or_ErrorBool true false) false) true) true.
Compute not_ErrorBool (and_ErrorBool (bnand_ErrorBool ( nxnor_ErrorBool (  or_ErrorBool true false) false) true) true).
Example ex5 : 3 <=' 4 ={ env }=> true.
Proof.
eapply b_lessthan.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.
Example exb: 3 <=' ( 9 /' 0) ={ env }=> error_bool.
Proof.
eapply b_lessthan.
+eapply const.
+eapply division.
  ++eapply const. ++eapply const. ++auto.
+simpl. reflexivity.
Qed.

Example exor : bxor ( 3 <=' 4 ) ( 9<=' 4) ={ env }=>true.
Proof.
 eapply b_xor. eapply b_lessthan. eapply const. eapply const.
auto. eapply b_lessthan. eapply const. eapply const. auto.
simpl. auto.
Qed.
(*OPERATII STIVA*)

Definition isEmpty (s : stiva ) : bool :=
  match s with
    | nil => true
    | _     => false
  end.

Definition pop (s : stiva) : stiva :=
  match s with
    | nil => nil
    | cd _ s' => s'
  end.
Definition get (s : stiva) : nat :=
  match s with
    | nil => 0
    | cd s' _ => s'
  end.
Fixpoint lengthc (s : stiva) : nat :=
  match s with
    | nil => 0
    | cd _ s' => 1 + (lengthc s')
  end.
Check cd 3 nil.
Definition push (s : stiva)(n : nat) : stiva :=
  match s, n with
    | nil , n => (cd n nil)
    | cd s' _ , n => (cd n s)
  end.

Compute push ( cd 2 nil) 4.
Compute lengthc (push ( cd 2 nil) 4).
Check nil.
Check cd 4 (cd 3 nil).
Compute lengthc (cd 9 (cd 4 (cd 3 nil))).
Compute pop (cd 9 (cd 4 (cd 3 nil))).
Compute get(cd 9 (cd 4 (cd 3 nil))).
Notation " x s> y " := (cd x y ) ( at level 60).
Check ( 2 s> (3 s> (4 s> nil))).
Check push (2 s> (3 s> (4 s> nil))) 4.

Reserved Notation "S -{ Sigma }-> Sigma'" (at level 60).

Inductive eval : Stmt -> Env -> Env -> Prop :=
| e_nat_decl: forall a sigma sigma',
   sigma' = (update sigma a (default)) ->
   ( int1 a ) -{ sigma }-> sigma'
| e_string_decl : forall a sigma sigma' ,
   sigma' =(update sigma a (default)) ->
  ( strings1 a ) -{ sigma }-> sigma'
| e_comment : forall a sigma ,
    (comment a) -{ sigma }-> sigma
| e_bool_decl: forall a sigma sigma',
   sigma' = (update sigma a (default)) ->
   (bool1 a ) -{ sigma }-> sigma'
| e_strcpy : forall a a1 sigma sigma',
   sigma' = (update sigma a   (res_string a1) ) ->
  ( strcpyd a a1) -{ sigma }-> sigma'
| e_strlen : forall a n sigma sigma',
  sigma' = (update sigma a ( res_nat (strlen n))) ->
  (strlenassign a (res_string n)) -{ sigma }-> sigma'

| e_strcmp : forall a a' b sigma sigma',
  sigma' = (update sigma b ( res_bool (strcmp a a'))) ->
  (strcmpd b (res_string a) (res_string a') ) -{ sigma }-> sigma'

| e_stiva_decl: forall a sigma sigma' sigma'',
   sigma' = (update sigma a (default)) ->
   sigma'' = (update sigma' a (res_stiva nil)) ->
   (decl_st a ) -{ sigma }-> sigma''

| e_stiva_push : forall a n sigma sigma'',
   sigma'' =(update sigma a (res_stiva (push nil n) )) ->
   push_st a n -{ sigma }-> sigma''

| e_stiva_push2 : forall values a n sigma sigma'',
   sigma'' =(update sigma a (res_stiva (push values n) )) ->
   push_st a n -{ sigma }-> sigma''

| e_stiva_pop : forall a values sigma sigma',
   sigma' =(update sigma a (res_stiva ( pop values))) ->
   pop_st a -{ sigma }-> sigma'
| e_nat_assign: forall a i x sigma sigma',
   a =[ sigma ]=> i ->
   sigma' = (update sigma x (res_nat i)) ->
   (x ::n= a) -{ sigma }-> sigma'
| e_bool_assign: forall a i x sigma sigma',
   a ={ sigma }=> i ->
   sigma' = (update sigma x (res_bool i)) ->
   (x ::b= a) -{ sigma }-> sigma'
| e_seq : forall s1 s2 sigma sigma1 sigma2,
    s1 -{ sigma }-> sigma1 ->
    s2 -{ sigma1 }-> sigma2 ->
    (s1 ;; s2) -{ sigma }-> sigma2
| e_if_then : forall b s sigma sigma1,
    b ={ sigma }=> true ->
    s -{ sigma }-> sigma1 ->
    ifthen b s -{ sigma }-> sigma1
| e_if_then_elsetrue : forall b s1 s2 sigma sigma',
    b ={ sigma }=> true ->
    s1 -{ sigma }-> sigma' ->
    ifelse b s1 s2 -{ sigma }-> sigma'
| e_if_then_elsefalse : forall b s1 s2 sigma sigma',
    b ={ sigma }=> false ->
    s2 -{ sigma }-> sigma' ->
    ifelse b s1 s2 -{ sigma }-> sigma'
| e_whilefalse : forall b s sigma,
    b ={ sigma }=> false ->
    while b s -{ sigma }-> sigma
| e_whiletrue : forall b s sigma sigma',
    b ={ sigma }=> true ->
    (s ;; while b s) -{ sigma }-> sigma' ->
    while b s -{ sigma }-> sigma'
| e_whilebr : forall b s br s2 sigma sigma',
    b ={ sigma }=>true ->
    s -{ sigma }-> sigma' ->
    while_break_st b s br s2 -{ sigma }-> sigma'
where "s -{ sigma }-> sigma'" := (eval s sigma sigma').

(*EXPRESII LAMBDA*)
Inductive lambdaf:=
| lbd : string-> Stmt -> Result -> lambdaf.

Inductive cases:=
| baz: Result -> Stmt -> cases
| lnil.

Definition first(s:cases): Result :=
match s with
| baz a b => a
| lnil => res_nat 0
end.

Definition second(s:cases) : Stmt:=
match s with
| baz a b => b
| lnil => empty_st "err"
end.

Compute first (baz (res_nat 3)("x"::n=4)).
Compute second (baz (res_nat 3)("x"::n=4)).
Definition case2(l : list cases): cases :=
match l with
| [] => lnil
| x :: _ => x
end.
Compute first (case2 [ (baz (res_nat 3) ("x"::n=4) ) ;(baz (res_nat 7) ("x"::n=84) ) ]).

Inductive prglambda :=
| simp: Stmt->prglambda
| lamb: Stmt -> lambdaf -> Stmt -> prglambda
| pr_sw: Stmt -> string -> list cases -> prglambda .

Check pr_sw (int1 "x";; ("x"::n=2)) "x" [ (baz (res_nat 3) ("x"::n=4) ) ;(baz (res_nat 3) ("x"::n=4) ) ].
Reserved Notation  "s -+<{ sigma }>+- sigma'"(at level 50).
  Hypothesis eq_dec : forall x y : cases, {x = y}+{x <> y}.

  Fixpoint remove (x : cases) (l : list cases) : list cases :=
    match l with
      | [] => []
      | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
    end.
Definition lista:=[6;4].

Scheme Equality for AExp.
Inductive evlamb : prglambda -> Env -> Env -> Prop :=
| e_simpl : forall s sigma sigma' ,
      eval s sigma sigma' ->
      simp s -+<{ sigma }>+- sigma'
| e_lamb : forall st name st1 res  st2 sigma sigma' sigma'' sigma''' sigma'''' sigma''''',
      eval st sigma sigma' ->
      eval st1 sigma' sigma'' ->
      sigma'''' = update sigma' "rezultat" default ->
      sigma''''' = update sigma'''' "rezultat" res ->
      eval st2 sigma' sigma'''->
      lamb st (name st1 res) (st2) -+<{ sigma }>+- sigma'''''
| e_switch_true : forall stm var valoare list_cases val_x b sigma sigma' sigma'',
      eval stm sigma sigma' ->
      valoare = sigma' var ->
      val_x = first (case2 list_cases )->
      b = Result_beq val_x valoare ->
      b = true ->
      eval (second (case2 list_cases )) sigma' sigma'' ->
      pr_sw stm var list_cases -+<{ sigma }>+- sigma''
| e_switch_false : forall stm var valoare list_cases val_x b sigma sigma' list2,
      eval stm sigma sigma' ->
      valoare = sigma' var ->
      val_x = first (case2 list_cases )->
      b = Result_beq val_x valoare ->
      b = false ->
      list2 = remove (case2 list_cases) list_cases ->
      pr_sw stm var list2 -+<{ sigma }>+- sigma
where "s -+<{ sigma }>+- sigma'":= (evlamb s sigma sigma').

Create HintDb my_hints.
Hint Constructors aeval : my_hints.
Hint Constructors beval : my_hints.
Hint Constructors eval : my_hints.
Hint Constructors evlamb : my_hints.

Hint Unfold update : my_hints.
Definition program_switch :=pr_sw (int1 "x";; ("x"::n=2)) "x" [ (baz (res_nat 2) ("x"::n=4) )].
Example ex_sw1: exists state, program_switch -+<{ env }>+- state /\ state "x"=(res_nat 4).
Proof.
eexists. split. unfold program_switch. eapply e_switch_true . eapply e_seq. eapply e_nat_decl. eauto.
eapply e_nat_assign. eapply const. eauto. eauto. eauto. eauto. eauto. eapply e_nat_assign. eapply const.
eauto. simpl. unfold update. eauto.
Qed.

Definition program_main :=(simp ( int1 "x" ;; ("x"::n=10) ) ).

Example ex_declp1: exists state, program_main -+<{ env }>+- state /\ state "x"=(res_nat 10).
Proof.
eexists. split. eapply e_simpl. eapply e_seq. eapply e_nat_decl. eauto. eapply e_nat_assign.
eapply const. auto. auto.
Qed.

Create HintDb my_hints.
Hint Constructors aeval : my_hints.
Hint Constructors beval : my_hints.
Hint Constructors eval : my_hints.
Hint Constructors evlamb : my_hints.
Hint Unfold update : my_hints.

Definition pr_lamb1 :=(lamb
(
  int1 "x" ;;
  ("x"::n=10) )
  (lbd "lambda"
        (int1 "z")
        (res_nat 10))
  ("z"::n=10)).

Definition pr_lamb :=(lamb
(
  int1 "x" ;;
  ("x"::n=10) )
  (lbd "lambda"
        (int1 "z")
        (res_nat 10))
  ("z"::n=10)).
Example ex_declp12: exists state, pr_lamb -+<{ env }>+- state /\ state "rezultat"=(res_nat 10).
Proof.
eexists. split. unfold pr_lamb. eapply e_lamb. eapply e_seq. eapply e_nat_decl. eauto. eapply e_nat_assign.
eapply const. auto. eauto 4 with my_hints.
eauto 40 with my_hints. + eauto 50 with my_hints; eauto. + simpl.  eauto 50 with my_hints.
+eauto 50 with my_hints.
Qed.

Example ex_declp13: exists state, pr_lamb -+<{ env }>+- state /\ state "z"=(err_undecl).
Proof.
eexists. split. unfold pr_lamb. eapply e_lamb. eapply e_seq. eapply e_nat_decl. eauto. eapply e_nat_assign.
eapply const. auto. eauto 4 with my_hints.
eauto 40 with my_hints. + eauto 50 with my_hints; eauto. + simpl.  eauto 50 with my_hints.
+eauto 50 with my_hints.
Qed.

(* WHILE BREAK*)
Notation " 'whileb' '(' B ')' '{' A C D '}'":=(while_break_st B A C D)(at level 96).

Definition ex_decl1 :=
int1 "s";;
strings1 "m";;
("s"::n=0);;
strcpyd "m" (string1 "salut");;
("s" ::s= strlen (res_string "myplg"));;
bool1 "b";;
strcmpd "b" (res_string "veri") (res_string "veri").

Example ex_declp15: exists state, ex_decl1 -{ env }-> state /\ state "b"=(res_bool true).
Proof.
eexists. split. unfold ex_decl1. eapply e_seq. eapply e_nat_decl. auto. eapply e_seq.
+eapply e_seq. eapply e_seq. eapply e_seq.
eapply e_string_decl. eauto. eapply e_nat_assign. eauto 3 with my_hints . eauto.
++eapply e_strcpy. auto.
++ eauto 3 with my_hints . +eauto. eapply e_seq. eapply e_bool_decl. auto.
eapply e_strcmp. auto.
+simpl. eauto.
Qed.

Definition ex_decl :=
int1 "s";;
strings1 "m";;
("s"::n=0);;
strcpyd "m" (string1 "salut").

Example ex_declp: exists state, ex_decl -{ env }-> state /\ state "m"=(res_string "salut").
Proof.
eexists. split. unfold ex_decl. eapply e_seq. eapply e_nat_decl. auto. eapply e_seq.
+eapply e_seq. eapply e_string_decl. eauto. eapply e_nat_assign. eauto 3 with my_hints . eauto.
+eauto 3 with my_hints . +eauto.
Qed.

Definition ex_whilebr :=
int1 "i" ;;
int1 "j" ;;
int1 "s";;
strings1 "m";;
("j"::n=1);;
("i"::n=1);;
("s"::n=0);;
while_break_st ( "i" <=' "j") ("s"::n=18 +' "s") "break" ("i"::n="i"+'1).

Example ex_whilebr1: exists state, ex_whilebr -{ env }-> state /\ state "i"=res_nat 1.
Proof.
eexists. split. unfold ex_whilebr. eapply e_seq. eapply e_nat_decl. auto. eapply e_seq. eapply e_nat_decl. auto.
+eapply e_seq. eapply e_nat_decl. eauto. eapply e_seq. eapply e_seq. eapply e_seq. eapply e_seq.
++eapply e_string_decl. auto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_whilebr. +++eapply b_lessthan. ++++eapply var. ++++eapply var.
 ++++ simpl. reflexivity.
+++ eapply e_nat_assign. eapply add. eapply const. eapply var. auto. eauto.
+eauto.
Qed.

(* DECLARARE STIVA, STIVA NULA*)
Definition prog:=
  stack "x";;
  int1 "y".
Example eval_prog :
  exists state, prog -{ env }-> state /\ state "x" = res_stiva nil .
Proof.
 eexists. split. unfold prog.
 +eapply e_seq. ++eapply e_stiva_decl. auto. eauto.
++eapply e_nat_decl. auto.
+ simpl. eauto.
Qed.

Definition prog2:=
  stack "x";;
  int1 "y" ;;
  push_st "x" 3.
Example eval_prog4 :
  exists state, prog2 -{ env }-> state /\ state "x" = res_stiva (cd 3 nil) .
Proof.
 eexists. split. unfold prog2.
 +eapply e_seq. ++eapply e_stiva_decl. auto. auto.
++eapply e_seq. eapply e_nat_decl. auto.
+++ eapply e_stiva_push. +++++eauto.
+eauto.
Qed.

Definition prog23:=
  stack "x";;
  int1 "y" ;;
  push_st "x" 3;;
  push_st "x" 4 ;;
  push_st "x" 5 ;;
  pop_st "x".
Example eval_prog4' :
  exists state, prog23 -{ env }-> state /\ state "x" = res_stiva (cd 4 (cd 3 nil)) .
Proof.
 eexists. split. unfold prog2.
 +eapply e_seq. ++eapply e_stiva_decl. auto. auto.
++eapply e_seq. eapply e_seq. eapply e_seq. eapply e_seq. eapply e_nat_decl. auto.
+++ simpl. eauto. eauto. ++++ eauto 3 with my_hints. +++ apply e_stiva_push2 with (push nil 3). eauto. +++apply e_stiva_push2 with (push (cd 3 nil) 4).
 eauto. +++apply e_stiva_pop with (cd 5 (cd 4 (cd 3 nil))). auto.
+eauto.
Qed.

Example eval_prog2 :
  exists state, prog2 -{ env }-> state /\ state "x" =res_stiva ( cd 3 (nil)) .
Proof.
 eexists. split. unfold prog.
 +eapply e_seq. ++eapply e_stiva_decl. auto. auto.
++eapply e_seq. eapply e_nat_decl. auto.
+++ eapply e_stiva_push. simpl. eauto.
+simpl. eauto.
Qed.

Check prog.

Reserved Notation "s =;{ sigma };= sigma1"(at level 30).

Notation " 'if1' '(' A ')'  'then1' B" :=(ifthen A B) (at level 96).
Notation " 'if2' '(' A ')' 'then2' B 'else2' C" := (ifelse A B C)(at level 96).
Check ( int1 "i").
Definition sum2 :=
  int1 "i" ;;
  int1 "j" ;;
  if1 ( "i" <=' "j") then1 ("s"::n=18 ).

(*
Inductive aeval_global : program1 -> Env -> Env -> Prop :=
|declarare_variabile : forall a i x sigma sigma',
   a =[ sigma ]=> i ->
   sigma' = (update sigma x (res_nat i)) ->
   "x" bool =;{ sigma };= sigma'
where "s =;{ sigma };= sigma1" := (aeval_global s sigma sigma1).

Reserved Notation "s -;{ sigma };> sigma1"(at level 30).
*)
(* INSTRUCTIUNEA IF THEN *)
Notation " 'if1' '(' A ')'  'then1' B" :=(ifthen A B) (at level 96).
Definition ex_stmt :=
int1 "i" ;;
int1 "j" ;;
int1 "s";;
("j"::n=1);;
("i"::n=0);;
if1 ( "i" <=' "j") then1 ("s"::n=18 ).
Example eval_sum4 :
  exists state, ex_stmt -{ env }-> state /\ state "s" =res_nat 18.
Proof.
  eexists. split.
  +unfold ex_stmt. eapply e_seq.
      ++eapply e_nat_decl. eauto.
      ++eapply e_seq.
          +++eapply e_nat_decl.
              ++++eauto.
          +++eapply e_seq. eapply e_seq.
              ++++eapply e_seq. eapply e_nat_decl.
                    +++++eauto.
                    +++++eapply e_nat_assign.
                            +++++++eapply const. +++++++auto.
              ++++eapply e_nat_assign. eapply const. eauto.
              ++++eapply e_if_then.
                    +++++eapply b_lessthan.
                          ++++++eapply var.
                          ++++++eapply var.
                          ++++++ simpl. reflexivity.
                    +++++eapply e_nat_assign. eapply const. eauto.
+auto.
Qed.

(*
Inductive aeval_program : final1 -> Env -> Env -> Prop :=
| main_f : forall s sigma1 sigma2,
        s-{ sigma1 }-> sigma2 ->
        (main2 s) -;{ sigma1 };> sigma2
where "s -;{ sigma };> sigma1" := (aeval_program s sigma sigma1).

*)
(* UPDATE LA ENV*)
Definition ex4:= int1 "x" ;;
                ("x"::n= 2).

Example ex4a: exists state, ex4 -{ env }-> state /\ state "x" =res_nat 2.
Proof.
eexists. split.
unfold ex4. eapply e_seq. eapply e_nat_decl. eauto. eapply e_nat_assign. eapply const.
eauto. eauto.
Qed.

(*EROARE LA DECLARARE *)
Definition ex45:=
                ("x"::n= 2).

Example ex45a: exists state, ex45 -{ env }-> state /\ state "x" =err_undecl.
Proof.
eexists. split.
unfold ex4. eapply e_nat_assign. eapply const.
eauto. eauto.
Qed.
(*INSTRUCTIUNEA WHILE*)
Definition ex_stmt2 :=
int1 "i" ;;
int1 "j" ;;
int1 "s";;
("j"::n=1);;
("i"::n=0);;
("s"::n=0);;
while ( "i" <=' "j") (("s"::n=18 +' "s") ;; ("i"::n="i"+'1) ).

Example ex_stm2: exists state, ex_stmt2 -{ env }-> state /\ state "s"=res_nat 36.
Proof.
eexists. split. unfold ex_stmt2. eapply e_seq. eapply e_nat_decl. auto. eapply e_seq. eapply e_nat_decl. auto.
+eapply e_seq. eapply e_seq. eapply e_seq. eapply e_seq.
++eapply e_nat_decl. auto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_whiletrue. +++eapply b_lessthan. ++++eapply var. ++++eapply var.
 ++++ simpl. reflexivity.
+++eapply e_seq. eapply e_seq. eapply e_nat_assign. eapply add. eapply const. eapply var. auto. eauto. eapply e_nat_assign. eapply add. eapply var. eapply const.
auto. eauto. eapply e_whiletrue. eapply b_lessthan. eapply var. eapply var. simpl. reflexivity.
++++eapply e_seq. eapply e_seq. eapply e_nat_assign. eapply add. eapply const. eapply var. auto. eauto. eapply e_nat_assign. eapply add. eapply var. eapply const.
auto. eauto. eapply e_whilefalse. eapply b_lessthan. eapply var. eapply var. simpl. reflexivity.
+eauto.
Qed.
(*INSTRUCTIUNEA DO WHILE*)
Definition ex_stmt3 :=
int1 "i" ;;
int1 "j" ;;
bool1 "s";;
("j"::n=1);;
("i"::n=1);;
("s"::b=btrue);;
do { ("s"::b=(bxor btrue bfalse)) ;; /*"comentariu" */ ;; ("i"::n="i"+'1) } while1 ( ( "i" <=' "j") ) .
Example ex_stm23: exists state, ex_stmt3 -{ env }-> state /\ state "s"=res_bool true.
Proof.
eexists. split. unfold ex_stmt3. eapply e_seq. eapply e_nat_decl. auto. eapply e_seq. eapply e_nat_decl. auto.
+eapply e_seq. eapply e_seq. eapply e_seq. eapply e_seq.
++eapply e_bool_decl. auto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_bool_assign. +++eapply b_true. +++eauto.
++eauto. eapply e_seq. eapply e_seq. eapply e_bool_assign. eapply b_xor. eapply b_true. eapply b_false. auto.  eauto. eapply e_seq. eapply e_comment. eapply e_nat_assign. eapply add. eapply var. eapply const. auto.
auto. eapply e_whilefalse. +++eapply b_lessthan. ++++eapply var. ++++eapply var.
 ++++ simpl. reflexivity.
+eauto.
Qed.

(* INSTRUCTIUNEA FOR *)
Definition ex_stmt4 :=
int1 "i" ;;
int1 "j" ;;
bool1 "s";;
("j"::n=1);;
("i"::n=1);;
("s"::b=btrue);;
For1 ( ("i"::n=1) ; ( "i" <=' "j") ;("i"::n="i"+'1) ) { ("s"::b=bfalse ) } .

Example ex_stm234: exists state, ex_stmt4 -{ env }-> state /\ state "s"=res_bool false.
Proof.
eexists. split. unfold ex_stmt4. eapply e_seq. eapply e_nat_decl. auto. eapply e_seq. eapply e_nat_decl. auto.
+eapply e_seq. eapply e_seq. eapply e_seq. eapply e_seq.
++eapply e_bool_decl. auto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_nat_assign. +++eapply const. +++eauto.
++eapply e_bool_assign. +++eapply b_true. +++eauto.
++eauto. eapply e_seq. eapply e_nat_assign.  eapply const.  auto. eapply e_whiletrue. +++eapply b_lessthan. ++++eapply var. ++++eapply var.
 ++++ simpl. reflexivity. +++ eapply e_seq. eapply e_seq. eapply e_bool_assign. eapply b_false. eauto. eapply e_nat_assign. eapply add. eapply var. eapply const. auto.
auto. eapply e_whilefalse. ++++eapply b_lessthan. +++++eapply var. +++++eapply var.
 +++++ simpl. reflexivity.
+eauto.
Qed.

Check (boolean true).

Check "x"::b= btrue.
Check "x"::n=10.

(* Functii incercare  *)

Inductive program1 :=
| decl_fun1 : string -> list string -> Stmt -> Result -> program1
| decl_var_glob1 : string -> Result -> program1.

Inductive final1 :=
| main2 : Stmt -> final1
| prgtot : program1 -> final1 -> final1
| prgcomplex : list program1 ->final1 ->final1.

Notation " 'var_gl' x ':g1=' y " := (decl_var_glob1 x y)(at level 40).
Check var_gl "x" :g1= (res_bool (boolean true)).
Check main2 ("x"::n=10).
Check "n"::n=10.
Check prgtot
 (decl_fun1 ("prim") ( ["m" ; "n"] )
      ("n"::n=10)
       (res_bool (boolean true)))
(main2 (("x"::n=10);; (apelfct "f" [ "m" ;"n"])) ).

Reserved Notation "S ->{ Sigma }<-> Sigma'" (at level 60).

Inductive eval_program : final1 -> Env -> Env ->Prop :=
| e_main : forall s sigma sigma',
    eval s sigma sigma' ->
    (main2 s) ->{ sigma }<-> sigma'

where "S ->{ Sigma }<-> Sigma'" := (eval_program S Sigma Sigma').

Definition program_main1 :=(main2 ( int1 "x" ;; ("x"::n=10) ) ).

Example ex_sfinal: exists state, program_main1 ->{ env }<-> state /\ state "x"=res_nat 10.
Proof.
eexists. split. eapply e_main. eapply e_seq. eapply e_nat_decl. eauto. eapply e_nat_assign.
eapply const. auto. auto.
Qed.


Require Export XR_R.
Require Export XR_R1.
Require Export XR_Rmult.
Require Export XR_Rmult_comm.
Require Export XR_Rmult_1_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_ne : forall r, r * R1 = r /\ R1 * r = r.
Proof.
  intro x.
  split.
  { rewrite Rmult_comm. rewrite Rmult_1_l. reflexivity. }
  { rewrite Rmult_1_l. reflexivity. }
Qed.


Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.
Require Import StructTact.ListTactics.

Set Implicit Arguments.

Fixpoint filterMap {A B} (f : A -> option B) (l : list A) : list B :=
  match l with
    | [] => []
    | x :: xs => match f x with
                   | None => filterMap f xs
                   | Some y => y :: filterMap f xs
                 end
  end.

Section filter_map.
  Variables A B C : Type.

  Lemma map_of_filterMap :
    forall (f : A -> option B) (g : B -> C) l,
      map g (filterMap f l) = filterMap (fun x => match f x with
                                                 | Some y => Some (g y)
                                                 | None => None
                                                 end) l.
  Proof using.
    induction l; intros; simpl in *.
    - auto.
    - repeat break_match; simpl; auto using f_equal.
  Qed.

  Lemma filterMap_ext :
    forall (f g : A -> option B) l,
      (forall x, f x = g x) ->
      filterMap f l = filterMap g l.
  Proof using.
    induction l; intros; simpl in *.
    - auto.
    - repeat find_higher_order_rewrite; auto.
  Qed.

  Lemma filterMap_defn :
    forall (f : A -> option B) x xs,
      filterMap f (x :: xs) = match f x with
                             | Some y => y :: filterMap f xs
                             | None => filterMap f xs
                             end.
  Proof using.
    simpl. auto.
  Qed.

  Lemma In_filterMap :
    forall (f : A -> option B) b xs,
      In b (filterMap f xs) ->
      exists a,
        In a xs /\ f a = Some b.
  Proof using.
    intros.
    induction xs; simpl in *; intuition.
    break_match.
    - simpl in *. intuition; subst; eauto.
      break_exists_exists; intuition.
    - concludes. break_exists_exists; intuition.
  Qed.

  Lemma filterMap_app :
    forall (f : A -> option B) xs ys,
      filterMap f (xs ++ ys) = filterMap f xs ++ filterMap f ys.
  Proof using.
    induction xs; intros; simpl in *; repeat break_match; simpl in *; intuition auto using f_equal.
  Qed.

  Lemma filterMap_In :
    forall A B (f : A -> option B) a b xs,
      f a = Some b ->
      In a xs ->
      In b (filterMap f xs).
  Proof using.
    induction xs; simpl; repeat break_match; simpl; intuition (auto; try congruence).
  Qed.

  Lemma filterMap_of_filterMap :
    forall (f : B -> option C) (g : A -> option B) xs,
      filterMap f (filterMap g xs) =
      filterMap (fun a => match g a with
                         | Some b => f b
                         | None => None
                         end) xs.
  Proof using.
    induction xs; simpl; intuition.
    repeat break_match; simpl; repeat find_rewrite; auto.
  Qed.

  Lemma filterMap_all_None :
    forall (f : A -> option B) xs,
      (forall x, In x xs -> f x = None) ->
      filterMap f xs = [].
  Proof using.
    induction xs; intros; simpl in *; intuition.
    rewrite H; auto.
  Qed.

  Lemma filterMap_NoDup_inj :
    forall (f : A -> option B) l,
      (forall x1 x2 y,
          f x1 = Some y ->
          f x2 = Some y ->
          x1 = x2) ->
      NoDup l ->
      NoDup (filterMap f l).
  Proof using.
    induction l; intros.
    - constructor.
    - simpl. invc_NoDup.
      break_match; auto.
      constructor; auto.
      intro.
      find_apply_lem_hyp In_filterMap. break_exists. break_and.
      assert (a = x) by eauto.
      subst. contradiction.
  Qed.
End filter_map.


(**
* Realizability with partial combinatory algebras
*)

Require Import Coq.Classes.Morphisms.

Require Import fin.
Require Import heytingarithmetic.
Require Import pas.
Require Import pca.
Require Import standardha.
Require Import vec.

Import FIN.NOTATIONS.
Import HA.NOTATIONS.
Import PAS.NOTATIONS.
Import PCA.NOTATIONS.
Import VEC.NOTATIONS.

Local Open Scope FIN.
Local Open Scope VEC.
Local Open Scope HA.
Local Open Scope PAS.
Local Open Scope PCA.

Local Notation x01 := PAS.x01.
Local Notation x02 := PAS.x02.
Local Notation x12 := PAS.x12.
Local Notation x03 := PAS.x03.
Local Notation x13 := PAS.x13.
Local Notation x23 := PAS.x23.

Module PCA_REL.

  (**
  ** Definitions
  *)

  (**
  *** Vector of naturals to vector of representations
  *)

  Local Notation "## f" :=
    (VEC.map (fun x => #x) f) (at level 6, right associativity).

  (**
  *** Realizability
  *)

  Definition RealizabilityPred `{_ : PCA.Pca} (n : nat) :=
    VEC.t nat n -> PAS.term 0 -> Prop.

  Definition AtomicRealizability `{_ : PCA.Pca} {n} (P : HA.atom n)
    : RealizabilityPred n :=
    fun f t => STD_HA.TruthPred P f /\ t!.

  Fixpoint Realizability `{_ : PCA.Pca} {n} (P : HA.formula n)
    : RealizabilityPred n :=
  match P with
  | HA.fAtom P => AtomicRealizability P
  | P ∧ Q      =>
      fun f t => Realizability P f (π1*t) /\ Realizability Q f (π2*t)
  | P ∨ Q      =>
      fun f t => (π1*t ≃ #0 /\ Realizability P f (π2*t)) \/
                 (π1*t ≃ #1 /\ Realizability Q f (π2*t))
  | P → Q      =>
      fun f u => u! /\ forall v, Realizability P f v -> Realizability Q f (u*v)
  | ∃P         =>
      fun f t => exists n : nat, π1*t ≃ #n /\ Realizability P (f, n) (π2*t)
  | ∀P         => fun f t => forall x : nat, Realizability P (f, x) (t*#x)
  end.

  Definition IsRealizable `{_ : PCA.Pca} {n} (P : HA.formula n) : Prop :=
    exists t : PAS.term 0, forall f : VEC.t nat n, Realizability P f (t**##f).

  (**
  ** Notations
  *)

  Module NOTATIONS.

    Delimit Scope PCA_REL with PCA_REL.

    Notation "## f" := ##f (at level 6, right associativity) : PCA_REL.

  End NOTATIONS.

  (**
  ** Theorems
  *)

  Module Type THMS_SIG.

    Declare Instance realizabilityInterpretation `{_ : PCA.Pca} :
      HA.Interpretation (@IsRealizable _ _ _ _ _ _ _).

    Declare Instance realizabilityRespectsClosedTermEq `{_ : PCA.Pca} {n}
                                                       (A : HA.formula n)
                                                       (f : VEC.t nat n) :
      Proper (PAS.ClosedTermEq ==> iff) (Realizability A f).

    Axiom realizersDenote :
      forall `{_ : PCA.Pca} {n} {A : HA.formula n} {f : VEC.t nat n}
             {t : PAS.term 0},
        Realizability A f t -> t!.

  End THMS_SIG.

  (**
  ** Proofs
  *)

  Module THMS : THMS_SIG.

    Lemma realizabilityRespectful `{pca : PCA.Pca} {n} (A : HA.formula n)
                                  (f : VEC.t nat n) (u v : PAS.term 0) :
      u ≃ v -> Realizability A f u -> Realizability A f v.
    Proof.
      generalize dependent u.
      generalize dependent v.
      induction A as
        [n A | n A IHA B IHB | n A IHA B IHB | n A IHA B IHB | n A IH | n A IH];
      intros u v Huv; simpl.
      - unfold AtomicRealizability. rewrite Huv. tauto.
      - intros [HA HB]. split.
        + apply (IHA f (π1*u) (π1*v)).
          * rewrite Huv. reflexivity.
          * exact HA.
        + apply (IHB f (π2*u) (π2*v)).
          * rewrite Huv. reflexivity.
          * exact HB.
      - intros [[H H'] | [H H']].
        + left. split.
          * rewrite <- Huv. exact H.
          * apply (IHA f (π2*u) (π2*v)); [ | exact H']. rewrite Huv.
            reflexivity.
        + right. split.
          * rewrite <- Huv. exact H.
          * apply (IHB f (π2*u) (π2*v)); [ | exact H']. rewrite Huv.
            reflexivity.
      - intros [Hv H]. split; [rewrite <- Huv; exact Hv | ].
        intros w Hw. specialize (H w Hw). apply IHB with (u := v*w).
        + rewrite Huv. reflexivity.
        + exact H.
      - intros [x [Hx H]]. exists x. split; [rewrite <- Huv; exact Hx | ].
        apply IH with (u := π2*v).
        + rewrite Huv. reflexivity.
        + exact H.
      - intros H x. apply IH with (u := v*#x).
        + rewrite Huv. reflexivity.
        + apply H.
    Qed.

    Instance realizabilityRespectsClosedTermEq `{pca : PCA.Pca} {n}
                                               (A : HA.formula n)
                                               (f : VEC.t nat n) :
      Proper (PAS.ClosedTermEq ==> iff) (Realizability A f).
    Proof.
      intros u v Huv.
      split; intro H; [ | symmetry in Huv]; eauto using realizabilityRespectful.
    Qed.

    Theorem realizersDenote `{pca : PCA.Pca} {n} {A : HA.formula n}
                            {f : VEC.t nat n} {t : PAS.term 0} :
      Realizability A f t -> t!.
    Proof.
      generalize dependent t.
      induction A as
        [n A | n A IHA B _ | n A IHA B IHB | n A _ B _ | n A IH | n A IH];
      simpl; intro t.
      - unfold AtomicRealizability. tauto.
      - intros [H _]. eauto using PAS.THMS.subtermDenotes.
      - intros [ [H H'] | [H H'] ]; eauto using PAS.THMS.subtermDenotes.
      - tauto.
      - intros [x [H H'] ]. eauto using PAS.THMS.subtermDenotes.
      - intros H. specialize (H 0). eauto using PAS.THMS.subtermDenotes.
    Qed.

    Lemma realizabilitySubstitution `{pca : PCA.Pca} {n m} (A : HA.formula n)
                                    (f : VEC.t (HA.term m) n) (g : VEC.t nat m)
                                    (t : PAS.term 0) :
      Realizability (A // f) g t <-> Realizability  A (STD_HA.termVecVal f g) t.
    Proof.
      generalize dependent m. generalize dependent t.
      induction A as
        [n A | n A IHA B IHB | n A IHA B IHB | n A IHA B IHB | n A IH | n A IH];
      intros m f g; simpl.
      - unfold AtomicRealizability.
        setoid_rewrite STD_HA.THMS.atomicTruthSubstEq.
        tauto.
      - setoid_rewrite IHA. setoid_rewrite IHB. tauto.
      - setoid_rewrite IHA. setoid_rewrite IHB. tauto.
      - setoid_rewrite IHA. setoid_rewrite IHB. tauto.
      - setoid_rewrite IH. setoid_rewrite STD_HA.THMS.termVecValTermVecUpEq'.
        tauto.
      - setoid_rewrite IH. setoid_rewrite STD_HA.THMS.termVecValTermVecUpEq'.
        tauto.
    Qed.

    Lemma realizabilityLastSubstitution `{pca : PCA.Pca} {n}
                                        (A : HA.formula (S n))
                                        (t : HA.term (S n)) (f : VEC.t nat n)
                                        (x : nat) (u : PAS.term 0) :
      Realizability (A /+ t) (f, x) u <->
      Realizability A (f, STD_HA.termVal t (f, x)) u.
    Proof.
      setoid_rewrite realizabilitySubstitution.
      assert
        (STD_HA.termVecVal (HA.idVecUp;; t) (f;; x) =
         (STD_HA.termVecVal HA.idVecUp (f;; x));; STD_HA.termVal t (f;; x))
      as H by reflexivity.
      rewrite H. clear H.
      setoid_rewrite STD_HA.THMS.termVecValIdVecUpEq.
      tauto.
    Qed.

    Lemma realizabilityDownSubstitution `{pca : PCA.Pca} {n}
                                        (A : HA.formula (S n)) (t : HA.term n)
                                        (f : VEC.t nat n) (u : PAS.term 0) :
      Realizability (A /- t) f u <-> Realizability A (f, STD_HA.termVal t f) u.
    Proof.
      setoid_rewrite realizabilitySubstitution.
      assert
        (STD_HA.termVecVal (HA.idVec;; t) f =
         (STD_HA.termVecVal HA.idVec f);; STD_HA.termVal t f)
      as H by reflexivity.
      rewrite H. clear H.
      setoid_rewrite STD_HA.THMS.termVecValIdVecEq.
      tauto.
    Qed.

    Lemma realizabilityUp `{pca : PCA.Pca} {n} (A : HA.formula n)
                          (f : VEC.t nat n) (x : nat) (t : PAS.term 0) :
      Realizability (up A) (f, x) t <-> Realizability A f t.
    Proof.
      unfold HA.formulaUp.
      rewrite realizabilitySubstitution, STD_HA.THMS.termVecValIdVecUpEq.
      tauto.
    Qed.

    Lemma combinatoryCompleteness1 `{pca : PCA.Pca} {n} (t : PAS.term (S n))
                                   (f : VEC.t nat n) :
      λ t ** ##f!.
    Proof.
      apply PCA.THMS.combinatoryCompleteness1'.
      intro x. rewrite VEC.THMS.nthMapEq.
      apply PCA.THMS.natRepresentationCombinatorDenotes.
    Qed.

    Lemma combinatoryCompleteness2 `{pca : PCA.Pca} {n} (t : PAS.term n)
                                   (f : VEC.t nat n) :
      λ t ** ##f ≃ t/##f.
    Proof.
      apply PCA.THMS.combinatoryCompleteness2'.
      intro x. rewrite VEC.THMS.nthMapEq.
      apply PCA.THMS.natRepresentationCombinatorDenotes.
    Qed.

    Lemma combinatoryCompleteness2' `{pca : PCA.Pca} {n} (t : PAS.term (S n))
                                    (f : VEC.t nat n) (a : carrier) :
      λ t ** ##f * &a ≃ t/(##f, &a).
    Proof.
      cutrewrite (λ t ** ##f * &a = λ t ** (##f;; &a)); [ | reflexivity].
      apply PCA.THMS.combinatoryCompleteness2'.
      destruct x as [x | x]; simpl.
      - rewrite VEC.THMS.nthMapEq.
        apply PCA.THMS.natRepresentationCombinatorDenotes.
      - exists a. reflexivity.
    Qed.

    Fixpoint termRep `{pca : PCA.Pca} {n} (t : HA.term n) : PAS.term 0 :=
    match t with
    | HA.O'       => λ (n := n) §#0
    | HA.var x    => λ (PAS.var x)
    | HA.S' t     => λ (n := n) (§σ * §(termRep t) ** PAS.idVec 0)
    | u ﬩ v       =>
      let u' := §(termRep u) ** PAS.idVec 0 in
      let v' := §(termRep v) ** PAS.idVec 0 in
      λ (n := n) (§α * u' * v')
    | u ⋅ v       =>
      let u' := §(termRep u) ** PAS.idVec 0 in
      let v' := §(termRep v) ** PAS.idVec 0 in
      λ (n := n) (§μ * u' * v')
    end.

    Lemma termRepCorrect `{pca : PCA.Pca} {n} (t : HA.term n)
                         (f : VEC.t nat n) :
      (termRep t)**##f ≃ #(STD_HA.termVal t f).
    Proof.
      induction t as [ | x | t IHt | u IHu v IHv | u IHu v IHv];
      simpl; rewrite combinatoryCompleteness2; simpl.
      - setoid_rewrite PAS.THMS.closedTermSubstitutionEq0. reflexivity.
      - rewrite VEC.THMS.nthMapEq. reflexivity.
      - setoid_rewrite PAS.THMS.idVecProductSubstitutionEq0'.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        rewrite IHt.
        rewrite PCA.THMS.successorCombinatorCorrect.
        reflexivity.
      - setoid_rewrite PAS.THMS.idVecProductSubstitutionEq0'.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        rewrite IHu, IHv.
        rewrite PCA.THMS.additionCombinatorCorrect.
        reflexivity.
      - setoid_rewrite PAS.THMS.idVecProductSubstitutionEq0'.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        rewrite IHu, IHv.
        rewrite PCA.THMS.multiplicationCombinatorCorrect.
        reflexivity.
    Qed.

    Instance realizabilityInterpretation `{pca : PCA.Pca} :
      HA.Interpretation (@IsRealizable _ _ _ _ _ _ _).
    Proof.
      split.
      - intros [t H]. specialize (H ()). destruct H as [H _]. exact H.
      - intros n A B [u Hu] [v Hv].
        exists (λ (n := n) (§u ** PAS.idVec 0 * §v ** PAS.idVec 0)).
        intro f.
        specialize (Hu f). specialize (Hv f).
        rewrite combinatoryCompleteness2.
        simpl.
        setoid_rewrite PAS.THMS.idVecProductSubstitutionEq0'.
        destruct Hu as [_ Hu]. exact (Hu _ Hv).
      - intros n A [t H]. exists t. intro f. simpl. intro x. apply H.
      - intros n A [t H].
        exists (λ (n := (S n)) (§t ** PAS.idVec 1)).
        intros [f x].
        rewrite combinatoryCompleteness2, realizabilityUp.
        assert (##(f;; x) = (##f;; #x)) as H' by reflexivity.
        rewrite H'. clear H'.
        setoid_rewrite PAS.THMS.idVecProductSubstitutionEq1'.
        apply H.
      - intros n A B.
        exists (λ (n := n) &k).
        intro f.
        rewrite combinatoryCompleteness2. simpl.
        split; [exists k; reflexivity | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hua].
        setoid_rewrite Hua. rewrite Hua in Ha. clear dependent u.
        split; [apply PCA.THMS.kaDenotes | ].
        intros v Hb. destruct (realizersDenote Hb) as [b Hvb].
        rewrite Hvb in *. clear dependent v.
        setoid_rewrite PCA.kSpec. exact Ha.
      - intros n A B C.
        exists (λ (n := n) &s).
        intro f. rewrite combinatoryCompleteness2.
        split; [exists s; reflexivity | ].
        intros t Ha. destruct (realizersDenote Ha) as [a Ht]. rewrite Ht in *.
        clear dependent t.
        split; [ apply PCA.THMS.saDenotes | ].
        intros t Hb. destruct (realizersDenote Hb) as [b Ht]. rewrite Ht in *.
        clear dependent t.
        split; [ apply PCA.sSpec1 | ].
        intros t Hc. destruct (realizersDenote Hc) as [c Ht]. rewrite Ht in *.
        clear dependent t.
        setoid_rewrite PCA.THMS.sSpec2'.
        destruct Ha as [_ Ha], Hb as [_ Hb].
        specialize (Ha _ Hc). specialize (Hb _ Hc).
        destruct Ha as [_ Ha]. exact (Ha _ Hb).
      - intros n A B. exists (λ (n := n) §π). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [ apply PCA.THMS.pairingCombinatorDenotes | ].
        intros t Ha. destruct (realizersDenote Ha) as [a Ht]. rewrite Ht in *.
        clear dependent t.
        split; [apply PCA.THMS.pairingCombinatorDenotes' | ].
        intros t Hb. destruct (realizersDenote Hb) as [b Ht]. rewrite Ht in *.
        clear dependent t.
        split.
        + rewrite PCA.THMS.leftProjectionCombinatorCorrect. exact Ha.
        + rewrite PCA.THMS.rightProjectionCombinatorCorrect. exact Hb.
      - intros n A B. exists (λ (n := n) §π1). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [apply PCA.THMS.leftProjectionCombinatorDenotes | ].
        simpl. tauto.
      - intros n A B. exists (λ (n := n) §π2). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [apply PCA.THMS.rightProjectionCombinatorDenotes | ].
        simpl. tauto.
      - intros n A B. exists (λ (n := n) (§(π * #0))). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        destruct (PCA.THMS.natRepresentationCombinatorDenotes 0) as [x Hx].
        rewrite Hx.
        split; [apply PCA.THMS.pairingCombinatorDenotes' | ].
        intros t Ha. destruct (realizersDenote Ha) as [a Ht]. rewrite Ht in *.
        clear dependent t.
        left. split.
        + rewrite PCA.THMS.leftProjectionCombinatorCorrect, Hx. reflexivity.
        + rewrite PCA.THMS.rightProjectionCombinatorCorrect. exact Ha.
      - intros n A B. exists (λ (n := n) (§(π * #1))). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        destruct (PCA.THMS.natRepresentationCombinatorDenotes 1) as [x Hx].
        rewrite Hx.
        split; [apply PCA.THMS.pairingCombinatorDenotes' | ].
        intros t Ha. destruct (realizersDenote Ha) as [a Ht]. rewrite Ht in *.
        clear dependent t.
        right. split.
        + rewrite PCA.THMS.leftProjectionCombinatorCorrect, Hx. reflexivity.
        + rewrite PCA.THMS.rightProjectionCombinatorCorrect. exact Ha.
      - intros n A B C.
        set (t := §δ * x13 * x23 * (§π1 * x03) * (§π2 * x03)). simpl in t.
        exists (λ (n := n) §(λ t)). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [apply PCA.THMS.representationsDenote | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hu]. rewrite Hu in *.
        clear dependent u.
        split. {
          apply PAS.THMS.subtermDenotes with (v := λ t * &a * &a); [auto | ].
          cutrewrite (λ t * &a * &a = λ t ** &&(();; a;; a)); [ | reflexivity].
          apply PCA.THMS.combinatoryCompleteness1.
        }
        intros u Hb. destruct (realizersDenote Hb) as [b Hu]. rewrite Hu in *.
        clear dependent u.
        split. {
          cutrewrite (λ t * &a * &b = λ t ** &&(();; a;; b)); [ | reflexivity].
          apply PCA.THMS.combinatoryCompleteness1.
        }
        intros u Hc. destruct (realizersDenote Hc) as [c Hu]. rewrite Hu in *.
        clear dependent u.
        rewrite PCA.THMS.combinatoryCompletenessInstance3. simpl.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        destruct Ha as [[H H'] | [H H']]; rewrite H.
        + setoid_rewrite PCA.THMS.caseCombinatorCorrect0.
          destruct Hb as [_ Hb]. exact (Hb _ H').
        + setoid_rewrite PCA.THMS.caseCombinatorCorrectS.
          destruct Hc as [_ Hc]. exact (Hc _ H').
      - intros n A. exists (λ (n := n) &k). intro f.
        rewrite combinatoryCompleteness2. simpl.
        split; [exists k; reflexivity | ]. intros v [H _]. contradiction.
      - intros n A t.
        exists (λ (n := S n) (§π * §(termRep t) ** PAS.idVec 1 * PAS.lastVar)).
        intro f.
        split; [apply combinatoryCompleteness1 | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hu]. rewrite Hu in *.
        clear dependent u.
        rewrite realizabilityDownSubstitution in Ha.
        set (x := STD_HA.termVal t f). exists x.
        rewrite combinatoryCompleteness2'. simpl.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        setoid_rewrite PAS.THMS.idVecProductSubstitutionEq1'.
        rewrite termRepCorrect. fold x. fold x in Ha.
        destruct (PCA.THMS.natRepresentationCombinatorDenotes x) as [x' Hx].
        rewrite Hx.
        split.
        + apply PCA.THMS.leftProjectionCombinatorCorrect.
        + setoid_rewrite PCA.THMS.rightProjectionCombinatorCorrect. exact Ha.
      - intros n A B.
        set (t := λ (x02 * (§π1 * x12) * (§π2 * x12))).
        exists (λ (n := n) §t). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [ apply PCA.THMS.representationsDenote | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hu]. rewrite Hu in *.
        clear dependent u.
        split. {
          cutrewrite (t * &a  = t ** &&(();; a)); [ | reflexivity].
          apply PCA.THMS.combinatoryCompleteness1.
        }
        intros u Hb. destruct (realizersDenote Hb) as [b Hu]. rewrite Hu in *.
        clear dependent u.
        unfold t. rewrite PCA.THMS.combinatoryCompletenessInstance2. simpl.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        destruct Hb as [x [Hx Hb]]. rewrite Hx in *.
        simpl in Ha. specialize (Ha x). destruct Ha as [_ Ha].
        specialize (Ha _ Hb). apply realizabilityUp in Ha. exact Ha.
      - intros n A B.
        set (t := λ (x03*x23*x13)).
        exists (λ (n := n) §t). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [apply PCA.THMS.representationsDenote | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hu]. rewrite Hu in *.
        clear dependent u.
        split. {
          apply PAS.THMS.subtermDenotes with (v := t*&a*&a); [auto | ].
          cutrewrite (t * &a * &a  = t ** &&(();; a;; a)); [ | reflexivity].
          apply PCA.THMS.combinatoryCompleteness1.
        }
        intros u Hb. destruct (realizersDenote Hb) as [b Hu]. rewrite Hu in *.
        clear dependent u.
        simpl. intro x.
        destruct (PCA.THMS.natRepresentationCombinatorDenotes x) as [x' Hx].
        rewrite Hx in *.
        unfold t. rewrite PCA.THMS.combinatoryCompletenessInstance3. simpl.
        simpl in Ha. specialize (Ha x). destruct Ha as [_ Ha].
        setoid_rewrite realizabilityUp in Ha.
        rewrite <- Hx. exact (Ha _ Hb).
      - intros n A t.
        exists (λ (n := S n) (PAS.lastVar * §(termRep t) ** PAS.idVec 1)).
        split; [apply combinatoryCompleteness1 | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hu]. rewrite Hu in *.
        clear dependent u.
        rewrite realizabilityDownSubstitution, combinatoryCompleteness2'. simpl.
        setoid_rewrite PAS.THMS.idVecProductSubstitutionEq1'.
        rewrite termRepCorrect.
        apply Ha.
      - exists (λ (n := 1) &k).
        intros [f x]. destruct f.
        rewrite combinatoryCompleteness2. simpl.
        split; [ | exists k; reflexivity].
        simpl. reflexivity.
      - exists (λ (n := 2) &k).
        intros [[f x] y]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha [a Hua]]. rewrite Hua. clear dependent u.
        simpl. split; [ | apply PCA.THMS.kaDenotes].
        simpl in *. congruence.
      - exists (λ (n := 3) &k).
        intros [[[f x] y] z]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha [a Hua]]. rewrite Hua. clear dependent u.
        split; [apply PCA.THMS.kaDenotes | ].
        intros u [Hb [b Hub]]. rewrite Hub. clear dependent u.
        simpl. split; [ | eauto using PCA.kSpec].
        simpl in *. congruence.
      - exists (λ (n := 2) &k).
        intros [[f x] y]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha [a Hua]]. rewrite Hua. clear dependent u.
        simpl. split; [ | apply PCA.THMS.kaDenotes].
        simpl in *. congruence.
      - exists (λ (n := 4) &k).
        intros [[[[f x1] x2] x3] x4]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha [a Hua]]. rewrite Hua. clear dependent u.
        split; [apply PCA.THMS.kaDenotes | ].
        intros u [Hb [b Hub]]. rewrite Hub. clear dependent u.
        simpl. split; [ | eauto using PCA.kSpec].
        simpl in *. congruence.
      - exists (λ (n := 4) &k).
        intros [[[[f x1] x2] x3] x4]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha [a Hua]]. rewrite Hua. clear dependent u.
        split; [apply PCA.THMS.kaDenotes | ].
        intros u [Hb [b Hub]]. rewrite Hub. clear dependent u.
        simpl. split; [ | eauto using PCA.kSpec].
        simpl in *. congruence.
      - exists (λ (n := 1) &k).
        intros [f x]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha _]. simpl in Ha. exfalso. eapply n_Sn. eauto.
      - exists (λ (n := 2) &k).
        intros [[f x] y]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [exists k; reflexivity | ].
        intros u [Ha [a Hua]]. rewrite Hua. clear dependent u.
        simpl. split; [ | apply PCA.THMS.kaDenotes].
        simpl in *. congruence.
      - exists (λ (n := 1) &k).
        intros [f x]. destruct f.
        rewrite combinatoryCompleteness2. simpl.
        split; [ | exists k; reflexivity].
        simpl. auto.
      - exists (λ (n := 2) &k).
        intros [[f x] y]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [ | exists k; reflexivity].
        simpl. auto.
      - exists (λ (n := 1) &k).
        intros [f x]. destruct f.
        rewrite combinatoryCompleteness2. simpl.
        split; [ | exists k; reflexivity].
        simpl. auto.
      - exists (λ (n := 2) &k).
        intros [[f x] y]. destruct f.
        rewrite combinatoryCompleteness2.
        split; [ | exists k; reflexivity].
        simpl. auto.
      - intros n A.
        exists (λ (n := n) §ρ). intro f.
        rewrite combinatoryCompleteness2.
        setoid_rewrite PAS.THMS.closedTermSubstitutionEq0.
        split; [apply PCA.THMS.primitiveRecursionCombinatorDenotes | ].
        intros u Ha. destruct (realizersDenote Ha) as [a Hu]. rewrite Hu in *.
        clear dependent u.
        split; [apply PCA.THMS.primitiveRecursionCombinatorDenotes' | ].
        intros u Hb. destruct (realizersDenote Hb) as [b Hu]. rewrite Hu in *.
        clear dependent u.
        simpl. intro x.
        induction x as [ | x IHx].
        + setoid_rewrite PCA.THMS.primitiveRecursionCombinatorCorrect0.
          rewrite realizabilityDownSubstitution in Ha. exact Ha.
        + setoid_rewrite PCA.THMS.primitiveRecursionCombinatorCorrectS.
          destruct (realizersDenote IHx) as [c Hc]. rewrite Hc in *.
          simpl in Hb. specialize (Hb x). destruct Hb as [_ Hb].
          specialize (Hb _ IHx).
          setoid_rewrite realizabilityLastSubstitution in Hb. exact Hb.
    Qed.

  End THMS.

End PCA_REL.