From iris.algebra Require Import
  proofmode_classes.

From caml5 Require Import
  prelude.
From caml5.algebra Require Export
  base.

Record nat_max := {
  nat_max_car : nat ;
}.
Add Printing Constructor nat_max.

Canonical nat_max_O :=
  leibnizO nat_max.

Implicit Types n m : nat.
Implicit Types x y z : nat_max.

#[local] Instance nat_max_valid : Valid nat_max :=
  λ _,
    True.
#[local] Instance nat_max_validN : ValidN nat_max :=
  λ _ _,
    True.
#[local] Instance nat_max_pcore : PCore nat_max :=
  Some.
#[local] Instance nat_max_op : Op nat_max :=
  λ x1 x2,
    Build_nat_max (nat_max_car x1 `max` nat_max_car x2).
#[local] Instance nat_max_unit : Unit nat_max :=
  Build_nat_max 0.

Lemma nat_max_op_eq n1 n2 :
  Build_nat_max n1 ⋅ Build_nat_max n2 = Build_nat_max (n1 `max` n2).
Proof.
  done.
Qed.

Lemma nat_max_included x1 x2 :
  x1 ≼ x2 ↔
  nat_max_car x1 ≤ nat_max_car x2.
Proof.
  split.
  - intros [y ->]. simpl. lia.
  - exists x2. rewrite /op /nat_max_op Nat.max_r; last lia. destruct x2. done.
Qed.

Lemma nat_max_ra_mixin :
  RAMixin nat_max.
Proof.
  apply ra_total_mixin; apply _ || eauto.
  - intros [] [] []. rewrite !nat_max_op_eq Nat.max_assoc //.
  - intros [] []. rewrite nat_max_op_eq Nat.max_comm //.
  - intros []. rewrite nat_max_op_eq Nat.max_id //.
Qed.
Canonical nat_max_R :=
  discreteR nat_max nat_max_ra_mixin.
#[global] Instance nat_max_cmra_discrete :
  CmraDiscrete nat_max_R.
Proof.
  apply discrete_cmra_discrete.
Qed.

Lemma nat_max_ucmra_mixin :
  UcmraMixin nat_max.
Proof.
  split; try apply _ || done. intros []. done.
Qed.
Canonical nat_max_UR :=
  Ucmra nat_max nat_max_ucmra_mixin.

#[global] Instance max_nat_core_id x :
  CoreId x.
Proof.
  constructor. done.
Qed.

Lemma nat_max_local_update x y x' :
  nat_max_car x ≤ nat_max_car x' →
  (x, y) ~l~> (x', x').
Proof.
  move: x y x' => [n] [m] [n'] /= ?.
  rewrite local_update_unital_discrete => [[p]] _.
  rewrite !nat_max_op_eq => [= ?].
  split; first done. f_equal. lia.
Qed.

#[global] Instance nat_max_op_idemp :
  IdemP (=@{nat_max}) (⋅).
Proof.
  intros []. rewrite nat_max_op_eq. f_equal. lia.
Qed.

#[global] Instance nat_max_is_op n1 n2 :
  IsOp (Build_nat_max (n1 `max` n2)) (Build_nat_max n1) (Build_nat_max n2).
Proof.
  done.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
Require Import bigops ssralg matrix poly.

(*****************************************************************************)
(* This file contains the definitions of:                                    *)
(*  - char_poly A  : Characteristic polynomial of A                          *)
(*  - phi : the isomorphism between the rings  M(R[X]) and M(R)[X]           *)
(*    with R a commutative and                                               *)
(*     M(R[X]) : matrices with coefficients in the polynomial ring of R      *)
(*     M(R)[X] : polynomials with coefficients in the matrix ring of R       *)
(*  - Zpoly : the injection from the polynomial ring to M(R)[X]              *)
(* In addition to the lemmas relevant to these definitions, this file also   *)
(* contains a proof of the Cayley-Hamilton Theorem.                          *)
(*****************************************************************************)

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

Import GRing.Theory.
Import Monoid.Theory.

Open Local Scope ring_scope.

Section Cayley.

Variable R : comRingType.

Variable n : pos_nat.

Notation Local nn := (pos_nat_val n) (only parsing).
Notation Local "'R'" := R
  (at level 0, format "'R'").
Notation Local "'R' [ 'X' ]" := {poly R}
  (at level 0, format "'R' [ 'X' ]").
Notation Local "'M' ( 'R' )" := (matrix R nn nn)
  (at level 0, format "'M' ( 'R' )").
Notation Local "'M' ( 'R' [ 'X' ] )" :=
  (matrix (poly_ringType R) nn nn)
  (at level 0, format "'M' ( 'R' [ 'X' ] )").
Notation Local "'M' ( 'R' ) [ 'X' ]" := {poly (matrix R n n)}
  (at level 0, format "'M' ( 'R' ) [ 'X' ]").

(* The characteristic polynomial *)
Open Scope matrix_scope.
Definition matrixC (A : M(R)) : M(R[X]) := \matrix_(i, j) (A i j)%:P.

Definition char_poly (A : M(R)) : R[X] := \det ('X%:M - matrixC A).

(* The isomorhism phi : M(R[X]) <-> M(R)[X] *)

Definition phi (A : M(R[X])) : M(R)[X] :=
  \poly_(k < \max_i \max_j size (A i j)) \matrix_(i, j) (A i j)`_k.

Lemma coef_phi : forall A i j k, (phi A)`_k i j = (A i j)`_k.
Proof.
move=> A i j k; rewrite coef_poly.
case: (ltnP k _) => le_m_k; rewrite mxE // nth_default //.
apply: leq_trans (leq_trans (leq_bigmax i) le_m_k); exact: (leq_bigmax j).
Qed.

Lemma phi_polyC : forall A, phi (matrixC A) = A%:P.
Proof.
move=> A; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi !mxE !coefC; case k; last rewrite /= mxE.
Qed.

Lemma phi_zero : phi 0 = 0.
Proof.
apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi mxE !coef0 mxE.
Qed.

Lemma phi_add : forall (A1 A2 : M(R[X])), phi (A1 + A2) = (phi A1) + (phi A2).
Proof.
move=> A1 A2; apply/polyP => k; apply/matrixP=> i j.
by rewrite coef_phi !mxE !coef_add_poly mxE !coef_phi.
Qed.

Lemma phi_opp : forall A, phi (- A) = - phi A.
Proof.
move=> A; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi mxE coef_opp mxE coef_phi coef_opp.
Qed.

Lemma phi_one : phi 1 = 1.
Proof.
apply/polyP=> k; apply/matrixP=> i j.
rewrite coef_phi mxE (fun_if (fun p : {poly _} => p`_k)) coef0 !coefC.
by case: k => [|k]; rewrite /= !mxE // if_same.
Qed.

Lemma phi_mul : forall (A1 A2 : M(R[X])), phi (A1 * A2) = (phi A1) * (phi A2).
Proof.
move=> A1 A2; apply/polyP=> k; apply/matrixP=> i j.
rewrite !coef_phi !mxE !coef_mul summxE coef_sum.
pose F k1 k2 := (A1 i k1)`_k2 * (A2 k1 j)`_(k - k2).
transitivity (\sum_k1 \sum_(k2 < k.+1) F k1 k2); rewrite {}/F.
  by apply: eq_bigr=> k1 _; rewrite coef_mul.
rewrite exchange_big /=; apply: eq_bigr=> k2 _.
by rewrite mxE; apply: eq_bigr=> k1 _; rewrite !coef_phi.
Qed.

(* Writing a polynomial as a polynomial on matrices *)

Definition Zpoly (p : R[X]) : M(R)[X] := \poly_(i < size p) (p`_i)%:M.

Lemma coef_Zpoly : forall p k, (Zpoly p)`_k = (p`_k)%:M.
Proof.
move=> p k; rewrite coef_poly; case: (ltnP k _) => // le_p_k.
by rewrite nth_default // scalar_mx0.
Qed.

Lemma ZpolyX : Zpoly 'X = 'X.
Proof.
apply/polyP=> k; apply/matrixP=> i j; rewrite coef_Zpoly !coefX.
by case: (k == _); rewrite !mxE ?if_same.
Qed.

Lemma phi_Zpoly : forall p, phi p%:M = Zpoly p.
Proof.
move=> p; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi coef_Zpoly !mxE; case: (i == j); rewrite ?coef0.
Qed.

(* The theorem in three lines! *)

Theorem Cayley_Hamilton : forall A, (Zpoly (char_poly A)).[A] = 0.
Proof.
move=> A; apply/eqP; apply/factor_theorem.
rewrite -phi_Zpoly -mulmx_adjl phi_mul; move: (phi _) => q; exists q.
by rewrite phi_add phi_opp phi_Zpoly phi_polyC ZpolyX.
Qed.

End Cayley.


(** Calculation of the simple arithmetic language with exceptions
(using CRASH instruction to signal uncaught exceptions). *)

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

(** * Syntax *)

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

(** * Semantics *)

Fixpoint eval (x: Expr) : option nat :=
  match x with
    | Val n => Some n
    | Add x y => match eval x with
                   | Some n => match eval y with
                               | Some n' => Some (n + n')
                               | None => None
                               end
                   | None => None
                   end
    | Throw => None
    | Catch x y => match eval x with
                   | Some n => Some n
                   | None => eval y
                   end
  end.

(** * Compiler *)

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

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

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

Definition Han : Set := Code * Reg.

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

(** * Virtual Machine *)

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

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

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

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

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

Hint Constructors cle : core.

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Machine.
Definition Conf := Conf.
Definition Pre := cle.
Definition Rel := VM.
Lemma monotone : monotonicity cle VM.
prove_monotonicity. Qed.
Lemma preorder : is_preorder cle.
prove_preorder. Qed.
End VM.

Module VMCalc := Calculation mem VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec : forall e r c a h m ,
  freeFrom r m ->
  ⟨comp e r c, a, h, m⟩
    =|>
    match eval e with
    | Some n => ⟨c , n, h, m⟩
    | None => ⟪h, m⟫
    end.

(** Setup the induction proof *)

Proof.
  induction e;intros.

(** Calculation of the compiler *)

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

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

(** - [x = Add e1 e2]: *)

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

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

  begin
    match eval Throw with
    | Some n => ⟨c , n ,h, m⟩
    | None => ⟪h, m⟫
    end.
  = { auto }
      ⟪h, m⟫.
  <== { apply vm_throw }
      ⟨THROW, a, h, m⟩.
  [].

(** - [x = Catch e1 e2]: *)

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

Definition empty := (@empty val).

(** Specification of the whole compiler *)

Theorem spec' e a h : ⟨compile e, a, h, empty⟩  =|> match eval e with
                                                      | Some n => ⟨HALT, n, h, empty⟩
                                                      | None => ⟪h, empty⟫
                                                    end.
Proof.
  begin
    match eval e with
    | Some n => ⟨HALT, n, h, empty⟩
    | None => ⟪h, empty⟫
    end.
  <|= {apply spec; apply empty_mem_free}
      ⟨comp e first HALT, a,h, empty⟩.
  [].
Qed.

(** * Soundness *)

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

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

Theorem sound' x a r C :
  ⟨compile x, a, (CRASH, r), empty⟩ =>>! C ->
  ((exists m n, C = ⟨HALT, n, (CRASH, r), m⟩ /\ eval x = Some n)
   \/ ((forall n h m, C <> ⟨HALT, n, h, m⟩) /\ eval x = None)).
Proof.
  intros E.
  pose (spec' x a (CRASH, r)). unfold Reach in *. repeat autodestruct.
  pose (determ_trc determ_vm) as D.
  unfold determ in D. inversion H0. subst.
  remember (eval x) as X.
  destruct X.
  - left. inversion H0. subst. inversion H1. subst. eexists. eexists.
    split. eapply D. eapply E. split. apply H. intro Contra. destruct Contra.
    inversion H3. reflexivity.
  - right. inversion H0. subst. inversion H1. subst.
    remember (get r m') as G. split;auto.
    destruct G. destruct v.
    + assert (C = ⟪ (CRASH, r), m' ⟫) as R. eapply D. eapply E. split. auto. intro Contra. destruct Contra.
      inversion H3. rewrite H9 in HeqG. inversion HeqG. subst. intros. intro Contra. inversion Contra.
    + assert (C = ⟨ CRASH, 0, h, m' ⟩) as R.
      eapply D. eapply E. split. eapply trc_step_trans. apply H. econstructor. eauto. intro Contra. destruct Contra.
      inversion H3. subst. intros. intro Contra. inversion Contra.
    + assert (C = ⟪ (CRASH, r), m' ⟫) as R. eapply D. eapply E. split. auto. intro Contra. destruct Contra.
      inversion H3. rewrite H9 in HeqG. inversion HeqG. subst. intros. intro Contra. inversion Contra.
Qed.

End Exception.


Require Import Definitions.
Require Import Arith.
Lemma ack_0x_fst:forall x y,
ack 0 y<=ack x y.
induction x.
auto.
induction y.
change (1<=ack x 1).
apply (le_trans _ 2 _).
auto.
apply IHx.
change (ack 0(S y)<=ack x(ack(S x)y)).
apply (le_trans _ (ack 0(ack (S x)y))_).
apply le_n_S.
apply IHy.
apply IHx.
Qed.
Lemma ack_0x_fst_lt:forall x y,
ack 0 y<ack (S x) y.
induction x.
induction y.
auto.
change (ack 0 (S y)<ack 0 (ack 1 y)).
apply le_n_S.
apply IHy.
intros.
elim y.
change(ack 0 0<(ack(S x)1)).
apply (le_trans _ 3 _).
auto.
apply (IHx 1).
intros.
change (ack 0(S n)<ack (S x)(ack(S(S x))n)).
apply (lt_trans _ ((ack 0(ack (S (S x))n)))_).
repeat apply le_n_S.
apply (H).
apply IHx.
Qed.

Lemma ack_incr_snd:forall x y1 y2,
y1<=y2->ack x y1<=ack x y2.
induction x.
intros.
apply le_n_S.
exact H.
intros.
elim H.
auto.
intros.
change (ack (S x) y1<=ack x (ack (S x)m)).
apply (le_trans _ (S(ack(S x)m))_).
apply (le_S _ _ H1).
apply ack_0x_fst.
Qed.

Lemma ack_incr_snd_lt:forall x y1 y2,
y1<y2->ack x y1<ack x y2.
induction x.
intros.
apply le_n_S.
exact H.
intros.
elim H.
change(ack (S x) y1 < ack x(ack(S x)y1)).
apply ack_0x_fst.
intros.
change (ack (S x) y1<ack x (ack (S x)m)).
apply (le_trans _ (S(ack(S x)m))_).
apply (le_S _ _ H1).
apply ack_0x_fst.
Qed.

Lemma ack_S_fst_lt:forall x y1 y2,
y1<=y2->ack x y1<ack (S x) y2.
intros x y1 y2.
intros.
elim H.
case y1.
change(ack x 0<ack x 1).
apply ack_incr_snd_lt.
auto.
intros.
change (ack x (S n)<ack x(ack (S x) n)).
apply ack_incr_snd_lt.
apply ack_0x_fst_lt.
intros.
apply (le_trans _ (S(ack(S x)m)) _
(le_S _ _ H1)).
change (ack 0(ack(S x)m)<=ack x(ack(S x)m)).
apply (ack_0x_fst x (ack (S x) m)).
Qed.

Lemma ack_incr:forall x1 x2 y1 y2:nat,
x1<=x2->y1<=y2->ack x1 y1<=ack x2 y2.
intros.
apply (le_trans _ (ack x1 y2) _).
apply ack_incr_snd.
apply H0.
elim H.
auto.
intros.
apply (le_trans _(ack m y2)_).
auto.
apply le_S_n.
apply lt_S.
apply ack_S_fst_lt.
auto.
Qed.
Check lt_S.
Print lt_S.

Lemma ack_mov:forall a m n:nat,
ack m (n+a)<=ack(a+m) n.
induction a.
intros.
rewrite plus_comm.
apply le_n.
intros.
elim n.
apply (IHa m 1).
intros.
simpl.
rewrite plus_comm.
simpl.
rewrite plus_comm.
change (ack m (S(S(n0+a)))<=
ack (a+m)(ack (S(a+m)) n0)).
apply (le_trans _ (ack (a+m) (S(S n0)))).
apply (IHa m (S(S n0))).
apply ack_incr_snd.
apply (le_trans _ (ack m (n0+S a))).
change (ack 0 (S n0) <= ack m (n0 + S a)).
apply ack_incr.
apply le_0_n.
rewrite plus_comm.
apply le_n_S.
apply le_plus_r.
apply H.
Qed.

Print eq_rec.

Program Fixpoint fin_sum{n:nat}
        (arg:fin n->nat){struct n}:nat:=
  match n with
  |0=>0
  |S n'=> let ut := (eq_rec n (fun t => fin t -> nat) _ (S n') _ :fin(S n')->nat) in
   (hd ut)+(fin_sum (tl ut:fin n'->nat))
end.
Print fin_sum.
Print fin_sum_obligation_1.
Eval compute in fin_sum (fun i:fin 2=>if i then 2 else 1).
Goal forall n,
forall arg:fin (S n)->nat,
fin_sum arg=(hd arg)+(fin_sum (tl arg)).
intros.
simpl.
unfold fin_sum_obligation_2.
unfold fin_sum_obligation_1.
simpl.
reflexivity.
Qed.

Program Fixpoint fin_max{n:nat}
(arg:fin n->nat){struct n}:nat:=
match n with
|0=>0
|S n'=>
((arg (_)):nat)+(fin_max (_:fin n'->nat))
end.
Obligation 1.
left.
exact tt.
Defined.
Obligation 2.
apply tl in arg.
apply arg.
apply H.
Defined.
Eval compute in fin_max (fun i:fin 2=>if i then 1 else 0).

Definition fin_max_max:forall n:nat,
forall arg:fin n->nat,
forall i:fin n,
(arg i<=fin_max arg).
induction n.
simpl.
intros.
induction i.
intros.
generalize (IHn (tl arg));intro.
simpl.
case i.
intro;case u;clear u.
apply le_plus_trans.
auto.
intros.
unfold fin_max_obligation_2.
simpl.
fold fin in f.
rewrite plus_comm.
apply le_plus_trans.
apply H.
Defined.

Theorem fin_sum_upp:forall n:nat,
forall arg:fin n->nat,
forall i:fin n,
arg i<=fin_sum arg.
induction n.
intros.
case i.
intros.
simpl.
unfold fin_sum_obligation_1,fin_sum_obligation_2.
simpl.
case i.
intros.
case u.
apply le_plus_l.
intros.
apply (le_trans _ (fin_sum (tl arg))).
apply IHn with (arg:=tl arg).
apply le_plus_r.
Qed.

Definition tot_le{n}(a b:fin n->nat):Prop:=
forall i:fin n,
a i<= b i.
Theorem tot_le_prim_le:forall n:nat,
forall f:prim_rec n,
forall a b:fin n->nat,
tot_le a b->eval f a<=eval f b.
fix IHf 2.
intros n f.
generalize (refl_equal n).
refine match f as ff in prim_rec nn return
n=nn->forall a b:fin nn->nat,tot_le a b->eval ff a <= eval ff b
with
    | pr_proj n i => _
    | pr_succ => _
    | pr_const n k => _
    | pr_compose m n fs g => _
    | pr_primrec n f g => _
end.

 intros.
 simpl.
 apply (H0 i).

 intros.
 simpl.
 apply le_n_S.
 apply H0.

 intros.
 simpl.
 auto.

 intros.
 simpl.
 apply IHf.
 unfold tot_le.
 intros.
 apply IHf.
 exact H0.
Guarded.

 intros.
 unfold eval.
 fold eval.
 case (a F0).
 case (b F0).
 apply IHf.
 unfold tot_le.
 intro.
 compute.
 apply H0.
 intros.
 simpl.
Abort.
Lemma tot_le_fin_sum:forall n:nat,
forall a b:fin n->nat,
tot_le a b->fin_sum a<=fin_sum b.
induction n.
compute.
auto.
intros.
change ((hd a)+(fin_sum (tl a))<=(hd b)+(fin_sum (tl b))).
apply plus_le_compat.
apply H.
apply IHn.
intro.
apply H.
Qed.
Lemma ack_1_n:forall n:nat,
ack 1 n=S(S n).
induction n.
auto.
change (ack 0 (ack 1 n)=S(S(S n))).
rewrite IHn.
auto.
Qed.

Lemma ack_2_n:forall n:nat,
ack 2 n=2*n+3.
induction n.
auto.
change (ack 1 (ack 2 n)=2*S n+3).
rewrite ack_1_n.
rewrite IHn.
ring.
Qed.

Lemma ack_twice_le:forall x,
3<=x->forall y:nat,
2*ack x y<=ack x (S y).
intro x.
case x.
intros.
apply le_Sn_0 in H.
case H.
intros.
change (2*ack(S n)y<=ack n(ack(S n)y)).
apply le_S_n in H.
apply (le_trans _ (ack 2(ack(S n)y))).
rewrite ack_2_n.
apply le_plus_l.
apply ack_incr.
exact H.
apply le_n.
Qed.

Lemma ack_mult:forall x,
3<=x->
forall m y,
(S m)*ack x y<=ack x (y+m).
intros x H m.
elim m.
intros.
rewrite plus_0_r.
rewrite mult_1_l.
apply le_n.
intros.
rewrite<-plus_n_Sm.
apply (le_trans _ (2*(ack x (y+n)))).
apply (le_trans _ (2*(S n*ack x y))).
rewrite mult_assoc.
apply mult_le_compat_r.
elim n.
apply le_n.
intros.
simpl in *.
repeat apply le_n_S.
repeat apply le_S_n in H1.
rewrite (plus_comm n0 )in *.
apply le_S.
apply H1.
apply mult_le_compat_l.
apply H0.
apply ack_twice_le.
exact H.
Qed.

Lemma pile_ack:
forall n:nat,
forall xs:fin n->nat,
{mc:nat|
forall c,
fin_sum (fun i : fin n => ack (xs i)c)
<=n*ack mc c}.
induction n.
intros.
exists 0.
intros.
simpl.
apply le_0_n.

intros.
destruct (IHn (tl xs)).
exists (x+(xs F0)+3).
simpl.
unfold fin_sum_obligation_1,
fin_sum_obligation_2.
simpl.
unfold hd.
unfold tl.
intro.
apply plus_le_compat.
apply ack_incr.
rewrite plus_comm.
rewrite plus_assoc.
apply le_plus_r.
apply le_n.
apply (le_trans _ (n*ack x c)).
apply l.
apply mult_le_compat_l.
apply ack_incr.
rewrite <-plus_assoc.
apply le_plus_l.
apply le_n.
Qed.

Lemma tot_le_sum:
forall n:nat,
forall a b:fin n->nat,
tot_le a b->fin_sum a<=fin_sum b.
induction n.
auto.
intros.
simpl.
unfold fin_sum_obligation_1,
fin_sum_obligation_2.
simpl.
unfold hd,tl.
apply plus_le_compat.
apply H.
apply IHn.
intro.
apply H.
Qed.

Theorem ack_is_not_primitive_recursive :

  forall f : prim_rec 2, exists m, exists n,
    eval f (fun i => if i then m else n) <> ack m n.
Lemma wider:
forall a:nat,
forall f:prim_rec a,
{m:nat|
forall arg:fin a->nat,
eval f arg
<ack m (fin_sum arg)}.
fix IHf 2.
intros.
generalize (refl_equal a).
refine match f as ff in prim_rec aa
return aa = a ->
{m : nat|
  forall arg : fin aa->nat,
 eval ff arg < ack m (fin_sum arg)}
with
    | pr_proj n i => _
    | pr_succ => _
    | pr_const n k => _
    | pr_compose m n fs g => _
    | pr_primrec n f g => _
end.
(* pr_proj*)
intros.
simpl.
exists  1.
intros.
apply (le_lt_trans _ (fin_sum arg)).
apply fin_sum_upp.
apply ack_0x_fst.

(* pr_succ *)

intros.
exists 1.
intros.
unfold eval.
change (ack 0 (arg F0)<ack 1(fin_sum arg)).
apply ack_S_fst_lt.
apply fin_sum_upp.

(* pr_const *)

intros.
exists k.
intros.
unfold eval.
elim k.
apply le_n_S.
apply le_0_n.
intros.
apply (lt_le_trans _ (S(ack n0 (fin_sum arg)))).
apply lt_n_S.
apply H0.
apply ack_S_fst_lt.
auto.
Guarded.

(* pr_compose *)

intros.
simpl.
destruct (IHf n g).
Print sig.
generalize (fun i:fin n =>
match IHf _ (fs i) return nat with
|exist m1 _=> m1 end).
intros IHfm.
destruct (pile_ack n (fun i:fin n =>
match IHf _ (fs i) return nat with
|exist m1 _=> m1 end)).
exists (3+x+x0).
intro.
apply (lt_le_trans _ (ack x (fin_sum(fun i:fin n=>eval(fs i)arg))) _).
apply l.
assert(forall i:fin n,
{ci:nat|eval (fs i) arg<=ack ci (fin_sum arg)}).
intros.
destruct(IHf m (fs i)).
exists x1.
apply le_S_n.
apply le_S.
apply l1.
assert ( {cs :fin n-> nat | forall i:fin n,eval (fs i) arg <= ack (cs i) (fin_sum arg)}).
Check exist.
refine (exist (fun i:fin n=>
match (H0 i) with
|exist ci Hi=>_:Prop end) _).
intros.

exists
simpl.
apply (le_trans _ (
ack x (fin_sum (fun i:fin n
=>ack (match (IHf m (fs i))with
|exist ci _=>ci end) (fin_sum arg))))).
apply ack_incr_snd.
apply tot_le_sum.
intro.
generalize (fs i).
intros.
simpl.
Check falso.
apply (H0 c).
intro.
destruct
apply IHf.
exists n.

Admitted.
Lemma argv_equal:forall (n:nat),
forall f:prim_rec n,
forall (arg1 arg2:fin n->nat),
(forall i:fin n,arg1 i=arg2 i)->
eval f arg1=eval f arg2.
fix IHf 2.
intros n f.
generalize (refl_equal n).
refine match f as ff in prim_rec nn return nn=n->
forall arg1 arg2:fin nn->nat,(forall i : fin nn, arg1 i = arg2 i) -> eval ff arg1 = eval ff arg2
with
    | pr_proj n i => _
    | pr_succ => _
    | pr_const n k => _
    | pr_compose m n fs g => _
    | pr_primrec n f g => _
end.
simpl.
intros.
apply H0.
simpl.
intros.
rewrite H0.
auto.
simpl.
auto.
simpl.
intros.
Guarded.
apply IHf.
intro.
apply IHf.
apply H0.
Guarded.
intros.
unfold eval.
rewrite (H0 F0).
fold eval.
elim (arg2 F0).
apply (IHf _ _ (tl arg1) (tl arg2)).
unfold tl.
intro.
apply H0.
intros.
rewrite H1.
apply IHf.
intro i;case i.
auto.
intro.
fold fin in *.
case f1.
intro.
reflexivity.
intro.
apply H0.
Qed.

intros.
generalize wider.
intros.
destruct (H 2 f).
exists x.
exists x.
generalize(H0 x (le_n x));intro.
intro.
assert (forall i:fin 2,(fun _ : fin 2 => x)i=(fun i : fin 2 => if i then x else x)i).
intro.
case i;auto.
rewrite <-(argv_equal  _ _ _ _ H3) in H2.
rewrite H2 in H1.
case (le_Sn_n _ H1).
Qed.


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Properties of Unary and Binary Operations                               *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics.

(* --LATER: eliminate the use of the section *)
(* --LATER: add inversion lemmas *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Definitions *)

Section Definitions.
Variables (A : Type).
Implicit Types f g : A -> A -> A.
Implicit Types i : A -> A.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Commutativity, associativity *)

(** Commutativity *)

Definition comm f := forall x y,
  f x y = f y x.

(** Associativity *)

Definition assoc f := forall x y z,
  f x (f y z) = f (f x y) z.

(** Combined associativity commutativity *)

Definition comm_assoc f := forall x y z,
  f x (f y z) = f y (f x z).

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Distributivity *)

(** Distributivity of unary operator *)

Definition distrib i f := forall x y,
  i (f x y) = f (i x) (i y).

(** comm distributivity of unary operator *)

Definition distrib_comm i f := forall x y,
  i (f x y) = f (i y) (i x).

(** Left distributivity *)

Definition distrib_l f g := forall x y z,
  f x (g y z) = g (f x y) (f x z).

(** Right distributivity *)

Definition distrib_r f g := forall x y z,
  f (g y z) x = g (f y x) (f z x).

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Neutral and absorbant *)

(** Left Neutral *)

Definition neutral_l f e:= forall x,
  f e x = x.

(** Right Neutral *)

Definition neutral_r f e := forall x,
  f x e = x.

(** Left Absorbant *)

Definition absorb_l f a := forall x,
  f a x = a.

(** Right Absorbant *)

Definition absorb_r f a := forall x,
  f x a = a.

(** Idempotence *)

Definition idempotent i := forall x,
  i (i x) = i x.

(** Idempotence *)

Definition involutive i := forall x,
  i (i x) = x.

(** Idempotence for binary operators *) (* TEMPORARY strange terminology! *)

Definition idempotent2 f := forall x,
  f x x = x.

(** Self Neutral *)

Definition self_neutral f e x :=
  f x x = e.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inverses *)

(** Left Inverse *)

Definition inverse_for_l f e a b :=
  f a b = e.

(** Right Inverse *)

Definition inverse_for_r f e a b :=
  f b a = e.

(** Left Inverse function -- todo arguments in order f i e ? *)

Definition inverse_l f e i := forall x,
  f (i x) x = e.

(** Right Inverse function *)

Definition inverse_r f e i := forall x,
  f x (i x) = e.

(** Self Inverse *)

Definition self_inverse i x :=
  i x = x.

End Definitions.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Morphism and automorphism *)

(** Morphism *)

Definition morphism (A B : Type) (h : A->B) (f : A->A->A) (g : B->B->B) :=
  forall x y, h (f x y) = g (h x) (h y).

(** Auto-morphism *)

Definition automorphism A := @morphism A A.
Arguments automorphism [A].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Injectivity *)

Definition injective A B (f : A -> B) :=
  forall x y, f x = f y -> x = y.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Lemmas *)

Section OpProperties.
Variables (A : Type).
Implicit Types h : A -> A.
Implicit Types f g : A -> A -> A.

Lemma idempotent_inv : forall h x y,
  idempotent h ->
  y = h x ->
  h y = y.
Proof using. intros. subst*. Qed.

(** For comm operators, right-properties can be derived from
    corresponding left-properties *)

Lemma neutral_r_of_comm_neutral_l : forall f e,
  comm f ->
  neutral_l f e ->
  neutral_r f e.
Proof using. introv C N. intros_all. rewrite* C. Qed.

Lemma inverse_r_of_comm_inverse_l : forall f e i,
  comm f ->
  inverse_l f e i ->
  inverse_r f e i.
Proof using. introv C I. intros_all. rewrite* C. Qed.

Lemma distrib_r_of_comm_distrib_l : forall f g,
  comm f ->
  distrib_l f g ->
  distrib_r f g.
Proof using.
  introv C N. intros_all. unfolds distrib_l.
  do 3 rewrite <- (C x). auto.
Qed.

Lemma comm_assoc_of_comm_and_assoc : forall f,
  comm f ->
  assoc f ->
  comm_assoc f.
Proof using.
  introv C S. intros_all. rewrite C.
  rewrite <- S. rewrite~ (C x).
Qed.

End OpProperties.

(* 2021-08-11 15:24 *)


(* Pentru Variabile *)

Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.
Require Import Ascii.
Check length("alex").
Compute length("alex").
Check nat.
Inductive NaturalV :=
| eroare_nat : NaturalV
| numar : nat -> NaturalV.
Check NaturalV.
Check numar 3.
Inductive BooleanV :=
| eroare_bool : BooleanV
| boolean : bool -> BooleanV.
Check boolean false.
Inductive CharV :=
| eroare_char : CharV
| caracter : ascii -> CharV.
Check caracter "v".
Scheme Equality for CharV.
Coercion numar : nat >-> NaturalV.
Coercion boolean: bool >-> BooleanV.
Coercion caracter: ascii >-> CharV.
Inductive Stiva ( tip : Set ) : Set :=
| stiva_vida : Stiva tip
| stiva_nevida : tip -> Stiva tip -> Stiva tip.
Check Stiva.
Check Stiva nat.
Check Stiva bool.
Check (stiva_nevida nat 6 (stiva_vida nat)) .
Check stiva_nevida bool false (stiva_vida bool).
Check (stiva_nevida nat 3 ( stiva_nevida nat 2  (stiva_vida nat)  ) ).
Check stiva_vida NaturalV.
Check CharV.
Check Stiva CharV.
Definition Stiva_Push  (x:Set)( L : Stiva x ) ( p : x ) : Stiva x :=
match L with
| _ => (stiva_nevida x p L )
end.
Compute (Stiva_Push nat (stiva_vida nat) 3).
Compute (Stiva_Push CharV (stiva_vida CharV) (caracter "r") ).

Definition Stiva_Pop  (x:Set)( L : Stiva x ) : Stiva x :=
match L with
| stiva_nevida _ p L' => L'
| _ =>stiva_vida x
end.
Compute Stiva_Pop nat ( stiva_vida nat ).
Compute Stiva_Pop nat (stiva_nevida nat 6 ( stiva_vida nat )).
Compute Stiva_Pop nat (stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))).

Definition Stiva_Top (x:Set)(eroare:x)(L : Stiva x) : x :=
match L with
| stiva_nevida _ p _  => p
| stiva_vida _ => eroare
end.

Compute (Stiva_Top NaturalV eroare_nat  (stiva_nevida NaturalV 6 ( stiva_vida NaturalV )) ).
Check (Stiva_Top NaturalV eroare_nat  (stiva_nevida NaturalV 6 ( stiva_vida NaturalV )) ).
Compute (Stiva_Top NaturalV eroare_nat  (stiva_vida NaturalV) ).

Fixpoint nrelem_stiva (X: Set)(L : Stiva X ) : nat :=
match L with
| stiva_vida _ => 0
| stiva_nevida _ p L' => 1 + (nrelem_stiva _ L')
end.

Compute nrelem_stiva nat (stiva_vida nat).
Compute nrelem_stiva nat (stiva_nevida nat 3 (stiva_vida nat)).

Fixpoint alipire_stive (X: Set) (L1 : Stiva X ) (L2 : Stiva X ) : Stiva X :=
match L1 with
| _ =>match L2 with |stiva_vida _ => L1
                    | stiva_nevida _ p L=> (alipire_stive _ (Stiva_Push _ L1 p) L)
                       end
end.

Compute alipire_stive nat (stiva_vida nat)(stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))).
Compute alipire_stive nat (stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))) (stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))).
Definition concat_stive (X: Set) (L1 : Stiva X ) (L2 : Stiva X ) : Stiva X :=
match L1 with
| _ => (alipire_stive _ L1 (alipire_stive _ (stiva_vida _ ) L2 ) )
end.

Compute concat_stive nat (stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))) (stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))).
Definition Copie_Stiva (X:Set) (destinatie:Stiva X)(decopiat:Stiva X) : Stiva X :=
match destinatie with
| _ => concat_stive _ decopiat (stiva_vida _)
end.

Compute (Copie_Stiva nat (stiva_nevida nat 7 (stiva_nevida nat 6 ( stiva_vida nat ))) (stiva_nevida nat 5 (stiva_vida nat)) ) .

Definition strlen (L : Stiva CharV) : nat :=
match L with
|_ => nrelem_stiva CharV L
end.
Compute strlen ( (stiva_nevida CharV (caracter "a") (stiva_nevida CharV (caracter "b") ( stiva_vida CharV ))) ).

Definition strcpy (destinatie : Stiva CharV)(decopiat : Stiva CharV): Stiva CharV  :=
match destinatie with
| _ => Copie_Stiva CharV destinatie decopiat
end.

Compute (strcpy  (stiva_nevida CharV (caracter "a") (stiva_nevida CharV (caracter "b") ( stiva_vida CharV ))) (stiva_vida CharV)).

Definition strcat (destinatie : Stiva CharV)(decopiat : Stiva CharV): Stiva CharV  :=
match destinatie with
| _ => concat_stive CharV destinatie decopiat
end.
Compute (strcat  (stiva_nevida CharV (caracter "a") (stiva_nevida CharV (caracter "b") ( stiva_vida CharV ))) (stiva_vida CharV)).

Fixpoint strchr (L : Stiva CharV)(carac : CharV) : bool :=
match L with
|stiva_vida _ => false
|stiva_nevida _ p L'=> if(CharV_beq ( Stiva_Top _ eroare_char L) carac) then true else (strchr L' carac)
end.
Compute (strchr  (stiva_nevida CharV (caracter "a") (stiva_nevida CharV (caracter "b") ( stiva_vida CharV ))) (caracter "d")).
Compute (strchr  (stiva_nevida CharV (caracter "a") (stiva_nevida CharV (caracter "b") ( stiva_vida CharV ))) (caracter "d")).
(*
Inductive Vector ( tip : Type ) : nat-> Type :=
| vector_vid : Vector tip 0
| vector_nevid : tip -> forall n , Vector tip n -> Vector tip (S n).

Check Vector.
Check vector_vid.
Check vector_vid nat .
Check (vector_nevid nat 3 0 ( vector_vid nat )) .
Check  (vector_nevid nat 3 1 (vector_nevid nat 3 0 ( vector_vid nat ))) .
Check Vector nat 2.
Check Stiva nat.
Check vector_nevid nat 3 0.
(* pentru a arata elementul de pe ultima pozitie*)
Definition UltimaPozitie ( x : Set ) i ( v : Vector x (S i) ) : x :=
match v with
| vector_nevid _ a _ _ => a
end.

Compute (UltimaPozitie nat 1 (vector_nevid nat 5 1 (vector_nevid nat 3 0 ( vector_vid nat ))) ).

Compute (UltimaPozitie nat 2 (vector_nevid nat 6 2 (vector_nevid nat 5 1 (vector_nevid nat 3 0 ( vector_vid nat )))) ).
(* similiar ca stiva *)
Definition Vector_pop (X : Set) n (v : Vector X (S n)) : Vector X n :=
match v with
| vector_nevid  _ _ _ tl => tl
  end.

Compute (Vector_pop nat 1 (vector_nevid nat 5 1 (vector_nevid nat 3 0 ( vector_vid nat ))) ).*)

Inductive Pair : Type :=
|pereche : Type  -> string -> Pair.

Check pereche nat "ar" .

Inductive Struct : Type :=
|struct_vid : Struct
|struct_nevid : Pair -> Struct ->Struct.

Check Struct.
Check struct_vid.
Check (struct_nevid (pereche bool "b")(struct_nevid (pereche nat "a") struct_vid)).
Check EmptyString.
Fixpoint GetV (S : Struct)(x : string) : string :=
match S with
|struct_vid => ""
|(struct_nevid ( pereche tip sir) s') => if ( string_beq  sir x ) then sir else GetV s' x
end.
Compute GetV (struct_nevid (pereche bool "b")(struct_nevid (pereche nat "a") struct_vid)) "a".
Require Import Nat.
(* tipul general de date *)
Inductive Rvalue :=
| eroare_nedeclarare : Rvalue
| eroare_asignare : Rvalue
| cons_nat : NaturalV-> Rvalue
| cons_bool : BooleanV -> Rvalue
| cons_char : CharV -> Rvalue
| cons_stiva_nat : (Stiva NaturalV) -> Rvalue
| cons_stiva_bool : (Stiva BooleanV) -> Rvalue
| cons_stiva_char : (Stiva CharV) -> Rvalue
| cons_struct : Struct -> Rvalue.
Check cons_stiva_nat (stiva_vida NaturalV).
Check cons_nat.
Check NaturalV.
Definition Env := string -> Rvalue.
Definition env0 : Env := fun x => eroare_nedeclarare.
Definition acelasi_tip ( r1 : Rvalue)(r2 : Rvalue) : bool :=
match r1 with
| eroare_nedeclarare => match r2 with |eroare_nedeclarare =>true
                                      |_ => false
                                       end
| eroare_asignare=>match r2 with |eroare_asignare => true
                                 |_ =>false
                                  end
| cons_nat x => match r2 with |cons_nat y=> true
                              | _ => false end

| cons_bool x => match r2 with |cons_bool y=> true
                               | _ => false end
| cons_char x => match r2 with |cons_char y=> true
                              | _ => false end
|cons_stiva_nat x => match r2 with | cons_stiva_nat y => true
                                   |_=>false end
|cons_stiva_bool x => match r2 with | cons_stiva_bool y => true
                                   | _ =>false end
|cons_stiva_char x => match r2 with | cons_stiva_char y => true
                                   |_=>false end
|cons_struct x => match r2 with | cons_struct y => true
                                | _ => false end
end.

Compute acelasi_tip (cons_nat 100) (cons_bool false).
Compute acelasi_tip (cons_nat 100) (cons_nat 4).

Definition update (env : Env) ( x: string ) ( v : Rvalue ) : Env :=
fun y =>
 if(string_beq x y)
  then
      if ( andb ( acelasi_tip (env y) eroare_nedeclarare) true )
                       then  v
         else if (andb ( acelasi_tip (env y) v) true ) then v else eroare_asignare
 else (env y).
Notation "S [ V /' X ]" := (update S X V) ( at level 0).
Compute (env0 "x").
Compute (update env0 "x" (cons_stiva_nat (stiva_vida NaturalV))).
Compute ((update env0 "x" (cons_stiva_nat (stiva_vida NaturalV))) "x").

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

Notation "A +' B" := (aplus A B) (at level 50,left associativity).
Notation "A *' B" := (amul A B) (at level 48,left associativity).
Notation "A -' B" := (asub A B) (at level 50,left associativity).
Notation "A /' B" := (adiv A B) (at level 48,left associativity).
Notation "A %' B" := (amod A B) (at level 50,left associativity).
Coercion anum : NaturalV >-> AExp.
Coercion avar : string >-> AExp.
Check 2 +' 3.
Check "sa" +' "bs".
Check avar "a".
Check (3 -' "a") *' 2.
Check 2 +' (Stiva_Top NaturalV eroare_nat  (stiva_nevida NaturalV 6 ( stiva_vida NaturalV )) ).
Definition plus_natural ( A1 A2 : NaturalV ) : NaturalV :=
match A1,A2 with
| _ ,eroare_nat => eroare_nat
| eroare_nat , _ => eroare_nat
| numar n1 , numar n2 => numar (n1 + n2)
end.

Compute plus_natural eroare_nat (numar 2).
Compute plus_natural (numar 2) (numar 2).
Compute plus_natural 1 eroare_nat.

Definition minus_natural ( A1 A2 : NaturalV ) : NaturalV :=
match A1,A2 with
| _ ,eroare_nat => eroare_nat
| eroare_nat , _ => eroare_nat
| numar n1 , numar n2 =>if(ltb n1 n2) then eroare_nat else numar (n1 - n2)
end.

Compute minus_natural 1 eroare_nat.
Compute minus_natural 1 3.
Compute minus_natural 5 0.

Definition mul_natural ( A1 A2 : NaturalV ) : NaturalV :=
match A1,A2 with
| _ ,eroare_nat => eroare_nat
| eroare_nat , _ => eroare_nat
| numar n1 , numar n2 => numar (n1 * n2)
end.

Compute mul_natural 1 3.

Definition div_natural ( A1 A2 : NaturalV ) : NaturalV :=
match A1,A2 with
| _ ,eroare_nat => eroare_nat
| eroare_nat , _ => eroare_nat
| _ , numar 0 => eroare_nat
| numar n1 , numar n2 => numar (div n1 n2)
end.

Compute div_natural 1 3.
Compute div_natural 1 0.

Definition mod_natural ( A1 A2 : NaturalV ) : NaturalV :=
match A1,A2 with
| _ ,eroare_nat => eroare_nat
| eroare_nat , _ => eroare_nat
| _ , numar 0 => eroare_nat
| numar n1 , numar n2 => numar ( n1 - n2*(div n1 n2))
end.

Compute mod_natural 1 3.
Compute mod_natural 1 0.

Reserved Notation "A =[ S ]=> N" (at level 60).

Inductive aeval : AExp -> Env -> NaturalV -> Prop :=
| const : forall c sigma , anum c =[ sigma ]=> c
| var : forall c sigma , avar c =[ sigma ]=> match (sigma c) with | cons_nat x => x
                                                                  | _ => eroare_nat end
| add : forall a1 a2 n1 n2 x sigma,
 a1 =[ sigma ]=> n1 ->
 a2 =[ sigma ]=> n2 ->
 x = (plus_natural n1 n2) ->
 a1 +' a2 =[ sigma ]=> x
| minus : forall a1 a2 n1 n2 x sigma,
 a1 =[ sigma ]=> n1 ->
 a2 =[ sigma ]=> n2 ->
 x = (minus_natural n1 n2) ->
 a1 -' a2 =[ sigma ]=> x
| mul : forall a1 a2 n1 n2 x sigma,
 a1 =[ sigma ]=> n1 ->
 a2 =[ sigma ]=> n2 ->
 x = (mul_natural n1 n2) ->
 a1 *' a2 =[ sigma ]=> x
| my_div : forall a1 a2 n1 n2 x sigma,
 a1 =[ sigma ]=> n1 ->
 a2 =[ sigma ]=> n2 ->
 x = (div_natural n1 n2) ->
 a1 /' a2 =[ sigma ]=> x
| my_mod : forall a1 a2 n1 n2 x sigma,
 a1 =[ sigma ]=> n1 ->
 a2 =[ sigma ]=> n2 ->
 x = (mod_natural n1 n2) ->
 a1 %' a2 =[ sigma ]=> x
where "A =[ S ]=> N" := (aeval A S N).

Example ex1 : 3 +' 7 =[ env0 ]=>10.
Proof.
eapply add.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.
Example ex2 : 3 /' 0 =[ env0 ]=> eroare_nat .
Proof.
eapply my_div.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.
Inductive BExp :=
| beroare : BExp
| btrue : BExp
| bfalse : BExp
| bvar : string -> BExp
| blessthan : AExp -> AExp -> BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp
| bor : BExp -> BExp -> BExp.

Notation "A <=' B" := (blessthan A B) (at level 70).
Notation " !' A" := (bnot A) (at level 51,left associativity).
Notation "A &&' B" := (band A B) (at level 52,left associativity).
Notation "A ||' B" := (bor A B) (at level 53,left associativity).

Check beroare.
Check bfalse.
Check !' bfalse.
Check bvar "A".
Check 1 <=' 2.
Check bvar "a" ||' bvar "b".
Check NaturalV.

Definition mai_mic_egal (A1 A2 : NaturalV) : BooleanV :=
match A1,A2 with
| _ , eroare_nat => eroare_bool
| eroare_nat , _ => eroare_bool
| numar a , numar b => boolean ( leb a b ) end.
Compute mai_mic_egal 3 4.
Compute mai_mic_egal 9 4.
Compute mai_mic_egal eroare_nat 4.

Definition not_b (A : BooleanV) : BooleanV :=
match A with
| eroare_bool => eroare_bool
| boolean b => boolean (negb b)
end.

Compute not_b true.

Definition my_and (A1 A2 : BooleanV) : BooleanV :=
match A1,A2 with
| _ , eroare_bool => eroare_bool
| eroare_bool , _ => eroare_bool
| boolean b1, boolean b2 => boolean ( andb b1 b2 )
end.

Compute my_and true false.
Compute my_and true eroare_bool.

Definition my_or (A1 A2 : BooleanV) : BooleanV :=
match A1,A2 with
| _ , eroare_bool => eroare_bool
| eroare_bool , _ => eroare_bool
| boolean b1, boolean b2 => boolean ( orb b1 b2 )
end.

Compute my_or true false.
Compute my_or true eroare_bool.

Reserved Notation "A -{ S }-> N" (at level 70).
Inductive beval : BExp -> Env -> BooleanV -> Prop  :=
| eroare_b : forall sigma , beroare -{ sigma }-> eroare_bool
| true_b : forall sigma, btrue -{ sigma }-> true
| false_b : forall sigma , bfalse -{ sigma }-> false
| var_b : forall vr sigma , bvar vr -{ sigma }-> match (sigma vr) with | cons_bool x => x
                                                                  | _ => eroare_bool end

| lessthan_b : forall a1 a2 n1 n2 x sigma,
a1 =[ sigma ]=> n1 ->
a2 =[ sigma ]=> n2 ->
x = (mai_mic_egal n1 n2) ->
 a1 <=' a2  -{ sigma }-> x
| negatie : forall a n b sigma,
a -{ sigma }-> n ->
b = (not_b n) ->
( !' a ) -{ sigma }-> b
| si : forall a1 a2 n1 n2 x sigma,
a1 -{ sigma }-> n1 ->
a2 -{ sigma }-> n2 ->
x = (my_and n1 n2) ->
( a1 &&' a2 ) -{ sigma }-> x
| sau : forall a1 a2 n1 n2 x sigma,
a1 -{ sigma }-> n1 ->
a2 -{ sigma }-> n2 ->
x = (my_or n1 n2) ->
( a1 ||' a2 ) -{ sigma }-> x
where "A -{ S }-> N":=(beval A S N).

Example ex3 : btrue &&' btrue -{ env0 }-> true .
eapply si.
eapply true_b.
eapply true_b.
simpl.
reflexivity.
Qed.

Example ex4 : 2 <=' 5 -{ env0 }-> true .
eapply lessthan_b.
eapply const.
eapply const.
simpl.
reflexivity.
Qed.

Example ex5 : eroare_nat <=' 5 -{ env0 }-> eroare_bool .
eapply lessthan_b.
eapply const.
eapply const.
simpl.
reflexivity.

Inductive Stmt :=
|declare_stiva_nat : string -> Stmt
|declare_stiva_bool : string -> Stmt
|declare_stiva_char : string -> Stmt
|declare_struct :string -> Struct -> Stmt
|push_stiva_nat : string -> NaturalV->Stmt
|push_stiva_bool : string -> BooleanV->Stmt
|push_stiva_char : string -> CharV->Stmt
|pop_stiva_nat : string->Stmt
|pop_stiva_bool : string->Stmt
|pop_stiva_char : string->Stmt
|concat_stive_nat : string->string->Stmt
|concat_stive_bool : string->string->Stmt
|stmt_strcat : string->string ->Stmt
|copy_stive_nat : string->string->Stmt
|copy_stive_bool : string->string->Stmt
|stmt_strcpy : string->string ->Stmt
|update_struct_value : string -> string -> Rvalue -> Stmt
|declare_nat : string  -> Stmt
|declare_bool : string  -> Stmt
|declare_char : string  -> Stmt
|assign_nat : string -> AExp -> Stmt
|assign_bool : string -> BExp -> Stmt
|assign_char : string -> CharV -> Stmt
|secventa : Stmt -> Stmt -> Stmt
|ifthen : BExp -> Stmt -> Stmt
|ifthenelse :BExp -> Stmt ->Stmt-> Stmt
| while : BExp -> Stmt -> Stmt
| my_for : Stmt -> BExp -> Stmt -> Stmt -> Stmt
| switch : BExp -> bool -> Stmt ->bool -> Stmt -> Stmt
| continue : Stmt
| break : Stmt.
Notation "'DSNAT' X " := (declare_stiva_nat X) (at level 50).
Notation "'DSBOOL' X " := (declare_stiva_bool X) (at level 50).
Notation "'DSCHAR' X " := (declare_stiva_char X) (at level 50).
Notation " 'DSTRUCT' X S " :=(declare_struct X S) (at level 50).
Notation "X :n= A" := (assign_nat X A) (at level 50).
Notation "X :b= A" := (assign_bool X A) (at level 50).
Notation "X :c= A" := (assign_char X A) (at level 50).
Notation "'DNAT' X " := (declare_nat X) (at level 50).
Notation "'DBOOL' X " := (declare_bool X ) (at level 50).
Notation "'DCHAR' X " := (declare_char X ) (at level 50).
Notation " S1 ;; S2 " := (secventa S1 S2) (at level 60,right associativity).
Notation " 'strcat'' ( S1 , S2 ) " := (stmt_strcat S1 S2) (at level 50 ).
Notation " 'strcpy'' ( S1 , S2 ) " := (stmt_strcpy S1 S2) (at level 50 ).

Check DNAT "X" .
Check "var" :c= caracter "a".
Check ifthen (0 <=' 3) ( "alex" :n= (3 +' 4) ).
Check switch ( bfalse ||' btrue ) true ( "i" :n= 2 ) false ( "i" :n= 3).
Definition prgrm :=
DSNAT "stiva"  ;;
push_stiva_nat "stiva" 3 ;;
pop_stiva_nat "stiva" ;;
DSCHAR "stiva1"  ;;
push_stiva_char "stiva1" (caracter "r") ;;
DSCHAR "stiva2" ;;
push_stiva_char "stiva2" (caracter "p") ;;
strcat' ( "stiva1" , "stiva2" ) ;;
strcpy' ( "stiva1" , "stiva2" ) ;;
DNAT "x" ;;
DNAT "suma" ;;
(my_for ( "i" :n= 1 ) ( "i" <=' "x" ) ( "i":n=("i" +' 1) ) ( "sum":n=("sum" +' 1) )) ;;
DCHAR "v" ;;
("v" :c= (caracter "a")) .

Definition program_switch :=
declare_struct "o" struct_vid ;;
DNAT "C" ;;
switch ( "C" <=' 4 )
    (true) ("C" :n= ("C" +' 1) )
    (false) ("C" :n=("C" -' 1) ).

Definition program_break :=
DNAT "a"  ;;
DBOOL "b" ;;
while ( 0 <=' "a" )
   (ifthen ( bvar "b" &&' bfalse ) break ;;
   ("a" :n= ("a" -' 1)) ).

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

Inductive eval : Stmt -> Env -> Env ->Prop :=
| d_nat :forall x sigma sigma',
   sigma' = update sigma x (cons_nat 0) ->
  (DNAT x) ~{ sigma }~> sigma'
| d_bool :forall x sigma sigma',
   sigma' = update sigma x (cons_bool false) ->
  (DBOOL x) ~{ sigma }~> sigma'
| d_char :forall x sigma sigma' ,
   sigma' = (update sigma x (cons_char (caracter "0"))) ->
  (DCHAR x) ~{ sigma }~> sigma'
| a_nat :forall x a sigma sigma' a',
   a =[ sigma ]=> a' ->
   sigma' = update sigma x (cons_nat a') ->
  ( x :n= a) ~{ sigma }~> sigma'
| a_bool :forall x b b' sigma sigma',
   b -{ sigma }-> b' ->
   sigma' = update sigma x (cons_bool b') ->
  (x :b= b) ~{ sigma }~> sigma'
| a_char :forall x c sigma sigma' ,
   sigma' = (update sigma x (cons_char c)) ->
  (x :c= c) ~{ sigma }~> sigma'
| e_seq : forall s1 s2 sigma sigma1 sigma2,
s1 ~{ sigma }~> sigma1 ->
s2 ~{ sigma1 }~> sigma2 ->
( s1 ;; s2) ~{ sigma }~> sigma2
|e_ifthen_false : forall b s sigma,
b -{ sigma }->  false ->
(ifthen b s) ~{ sigma }~> sigma
|e_ifthen_true : forall b s sigma sigma',
b -{ sigma }->  true ->
s ~{ sigma }~> sigma' ->
(ifthen b s) ~{ sigma }~> sigma'
|e_ifthenelse_false : forall b s1 s2 sigma sigma',
b -{ sigma }->  false ->
s2 ~{ sigma }~> sigma' ->
(ifthenelse b s1 s2) ~{ sigma }~> sigma
|e_ifthenelse_true : forall b s1 s2 sigma sigma',
b -{ sigma }->  true ->
s1 ~{ sigma }~> sigma' ->
(ifthenelse 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'
| for_l :  forall i1 i2 sigma sigma' pas comenzi,
  (i1 ;; (while i2 (comenzi ;; pas ) ) ) ~{ sigma }~> sigma' ->
  (my_for i1 i2 pas comenzi) ~{ sigma }~> sigma'
| e_switch_case1 : forall B b1 b2 i1 i2 sigma sigma1,
B -{ sigma }-> boolean b1 ->
i1 ~{ sigma }~> sigma1 ->
(switch B b1 i1 b2 i2) ~{ sigma }~> sigma1
| e_switch_case2 : forall B b1 b2 i1 i2 sigma sigma1,
B -{ sigma }-> boolean b2 ->
i2 ~{ sigma }~> sigma1 ->
(switch B b1 i1 b2 i2) ~{ sigma }~> sigma1
(* continue si break din bucati *)
| e_break : forall sigma,
break ~{ sigma }~> sigma
| e_while_break_1 : forall  s b sigma sigma',
b -{ sigma }-> boolean true ->
s~{ sigma }~> sigma' ->
(while b s) ~{ sigma }~> sigma'
| e_while_continue_1 : forall s s2 b x p sigma sigma',
s = continue ;; s2 ->
x = p ;; (while b s) ->
p ~{ sigma }~> sigma' ->
(while b s) ~{ sigma' }~> sigma'
| e_while_continue_2 : forall s s2 b x p sigma sigma' sigma'',
s = s2 ;; continue ->
x = p ;; (while b s) ->
p ~{ sigma }~> sigma' ->
(while b s2) ~{ sigma' }~> sigma'' ->
(while b s) ~{ sigma'}~> sigma''

| ds_nat :forall x sigma sigma',
   sigma' = update sigma x (cons_stiva_nat (stiva_vida NaturalV)) ->
  (DSNAT x) ~{ sigma }~> sigma'
| ds_bool :forall x sigma sigma',
   sigma' = update sigma x (cons_stiva_bool (stiva_vida BooleanV)) ->
  (DSBOOL x) ~{ sigma }~> sigma'
| ds_char :forall x sigma sigma' ,
   sigma' = (update sigma x (cons_stiva_char (stiva_vida CharV))) ->
  (DSCHAR x) ~{ sigma }~> sigma'
| e_push_nat : forall sigma sigma' sigma'' stiva1 NUM numestiva,
(acelasi_tip (cons_stiva_nat (stiva_vida NaturalV)) (cons_stiva_nat (stiva1))) = true ->
sigma' = update sigma numestiva ( cons_stiva_nat stiva1 )  ->
sigma'' =( update sigma numestiva (cons_stiva_nat ( Stiva_Push NaturalV stiva1 NUM) ) )->
push_stiva_nat numestiva NUM ~{ sigma' }~> sigma''
| e_push_bool : forall sigma sigma' sigma'' stiva1 NUM numestiva,
(acelasi_tip (cons_stiva_bool (stiva_vida BooleanV)) (cons_stiva_bool (stiva1))) = true ->
sigma' = update sigma numestiva ( cons_stiva_bool stiva1 )  ->
sigma'' =( update sigma numestiva (cons_stiva_bool ( Stiva_Push BooleanV stiva1 NUM) ) )->
push_stiva_bool numestiva NUM ~{ sigma' }~> sigma''
| e_push_char : forall sigma sigma' sigma'' stiva1 NUM numestiva,
(acelasi_tip (cons_stiva_char (stiva_vida CharV)) (cons_stiva_char (stiva1))) = true ->
sigma' = update sigma numestiva ( cons_stiva_char stiva1 )  ->
sigma'' =( update sigma numestiva (cons_stiva_char ( Stiva_Push CharV stiva1 NUM) ) )->
push_stiva_char numestiva NUM ~{ sigma' }~> sigma''
| e_pop_nat : forall sigma sigma' sigma'' stiva1 numestiva,
(acelasi_tip (cons_stiva_nat (stiva_vida NaturalV)) (cons_stiva_nat (stiva1))) = true ->
sigma' = update sigma numestiva ( cons_stiva_nat stiva1 )  ->
sigma'' =( update sigma numestiva (cons_stiva_nat ( Stiva_Pop NaturalV stiva1) ) )->
pop_stiva_nat numestiva ~{ sigma' }~> sigma''
| e_pop_bool : forall sigma sigma' sigma'' stiva1 numestiva,
(acelasi_tip (cons_stiva_bool (stiva_vida BooleanV)) (cons_stiva_bool (stiva1))) = true ->
sigma' = update sigma numestiva ( cons_stiva_bool stiva1 )  ->
sigma'' =( update sigma numestiva (cons_stiva_bool ( Stiva_Pop BooleanV stiva1) ) )->
pop_stiva_bool numestiva ~{ sigma' }~> sigma''
| e_pop_char : forall sigma sigma' sigma'' stiva1 numestiva,
(acelasi_tip (cons_stiva_char (stiva_vida CharV)) (cons_stiva_char (stiva1))) = true ->
sigma' = update sigma numestiva ( cons_stiva_char stiva1 )  ->
sigma'' = update sigma numestiva (cons_stiva_char ( Stiva_Pop CharV stiva1 ) )->
pop_stiva_char numestiva ~{ sigma' }~> sigma''
| e_concat_nat : forall stiva1 stiva2 numestiva1 numestiva2 sigma sigma' sigma'' sigma''' ,
(acelasi_tip (cons_stiva_nat (stiva_vida NaturalV)) (cons_stiva_nat (stiva1))) = true ->
(acelasi_tip (cons_stiva_nat (stiva_vida NaturalV)) (cons_stiva_nat (stiva2))) = true ->
sigma' = update sigma numestiva1 ( cons_stiva_nat stiva1 )  ->
sigma'' = update sigma' numestiva2 ( cons_stiva_nat stiva2 )  ->
sigma''' = update sigma'' numestiva1 (cons_stiva_nat (concat_stive NaturalV stiva1 stiva2) ) ->
concat_stive_nat numestiva1 numestiva2 ~{ sigma }~> sigma'''
| e_concat_bool : forall stiva1 stiva2 numestiva1 numestiva2 sigma sigma' sigma'' sigma''' ,
(acelasi_tip (cons_stiva_bool (stiva_vida BooleanV)) (cons_stiva_bool (stiva1))) = true ->
(acelasi_tip (cons_stiva_bool (stiva_vida BooleanV)) (cons_stiva_bool (stiva2))) = true ->
sigma' = update sigma numestiva1 ( cons_stiva_bool stiva1 )  ->
sigma'' = update sigma' numestiva2 ( cons_stiva_bool stiva2 )  ->
sigma''' = update sigma'' numestiva1 (cons_stiva_bool (concat_stive BooleanV stiva1 stiva2) ) ->
concat_stive_nat numestiva1 numestiva2 ~{ sigma }~> sigma'''
| e_concat_char : forall stiva1 stiva2 numestiva1 numestiva2 sigma sigma' sigma'' sigma''' ,
(acelasi_tip (cons_stiva_char (stiva_vida CharV)) (cons_stiva_char (stiva1))) = true ->
(acelasi_tip (cons_stiva_char (stiva_vida CharV)) (cons_stiva_char (stiva2))) = true ->
sigma' = update sigma numestiva1 ( cons_stiva_char stiva1 )  ->
sigma'' = update sigma' numestiva2 ( cons_stiva_char stiva2 )  ->
sigma''' = update sigma'' numestiva1 (cons_stiva_char (strcat stiva1 stiva2) ) ->
strcat' (numestiva1 , numestiva2) ~{ sigma }~> sigma'''
| e_copy_nat : forall stiva1 stiva2 numestiva1 numestiva2 sigma sigma' sigma'' sigma''' ,
(acelasi_tip (cons_stiva_nat (stiva_vida NaturalV)) (cons_stiva_nat (stiva1))) = true ->
(acelasi_tip (cons_stiva_nat (stiva_vida NaturalV)) (cons_stiva_nat (stiva2))) = true ->
sigma' = update sigma numestiva1 ( cons_stiva_nat stiva1 )  ->
sigma'' = update sigma' numestiva2 ( cons_stiva_nat stiva2 )  ->
sigma''' = update sigma'' numestiva1 (cons_stiva_nat (Copie_Stiva NaturalV stiva1 stiva2) ) ->
copy_stive_nat numestiva1 numestiva2 ~{ sigma }~> sigma'''
| e_copy_bool : forall stiva1 stiva2 numestiva1 numestiva2 sigma sigma' sigma'' sigma''' ,
(acelasi_tip (cons_stiva_bool (stiva_vida BooleanV)) (cons_stiva_bool (stiva1))) = true ->
(acelasi_tip (cons_stiva_bool (stiva_vida BooleanV)) (cons_stiva_bool (stiva2))) = true ->
sigma' = update sigma numestiva1 ( cons_stiva_bool stiva1 )  ->
sigma'' = update sigma' numestiva2 ( cons_stiva_bool stiva2 )  ->
sigma''' = update sigma'' numestiva1 (cons_stiva_bool (Copie_Stiva BooleanV stiva1 stiva2) ) ->
copy_stive_nat numestiva1 numestiva2 ~{ sigma }~> sigma'''
| e_copy_char : forall stiva1 stiva2 numestiva1 numestiva2 sigma sigma' sigma'' sigma''' ,
(acelasi_tip (cons_stiva_char (stiva_vida CharV)) (cons_stiva_char (stiva1))) = true ->
(acelasi_tip (cons_stiva_char (stiva_vida CharV)) (cons_stiva_char (stiva2))) = true ->
sigma' = update sigma numestiva1 ( cons_stiva_char stiva1 )  ->
sigma'' = update sigma' numestiva2 ( cons_stiva_char stiva2 )  ->
sigma''' = update sigma'' numestiva1 (cons_stiva_char (strcpy stiva1 stiva2) ) ->
strcpy' (numestiva1 , numestiva2) ~{ sigma }~> sigma'''
| e_decl_struct :forall X S sigma sigma' ,
sigma' = update sigma X (cons_struct S) ->
declare_struct X S ~{ sigma }~> sigma'
| e_update_struct_value :forall nume S sigma sigma'' sigma' val new,
sigma' = update sigma nume (cons_struct S) ->
sigma'' = update sigma' (GetV S val) new ->
(update_struct_value nume val new) ~{ sigma }~> sigma''
where "S ~{ Sigma }~> Sigma'":=(eval S Sigma Sigma') .

Hint Constructors aeval : my_hints.
Hint Constructors beval : my_hints.
Hint Constructors eval : my_hints.
Hint Unfold update : my_hints.
Example prgm1 :=
 DNAT "i"  ;;
 DNAT "j"  ;;
DNAT "sum" ;;
assign_nat "i" 3 ;;
assign_nat "j" 4 ;;
assign_nat "sum" ("i" +' "j").
Qed.
Example eval_sum1 :
  exists state, prgm1 ~{ env0 }~> state /\ state "sum" =cons_nat 7.
Proof.
eexists.
split.
unfold prgm1.
eapply e_seq.
eapply d_nat.
reflexivity.
eapply e_seq.
eapply d_nat.
reflexivity.
eapply e_seq.
eapply d_nat.
eauto.
eapply e_seq.
eapply a_nat.
eapply const.
eauto.
eapply e_seq.
eapply a_nat.
eapply const.
eauto.
eapply a_nat.
eapply add.
eapply var.
eapply var.
simpl.
reflexivity.
reflexivity.
reflexivity.
Qed.

Example prgm2 :=
 DNAT "i"  ;;
 DNAT "j"  ;;
DNAT "sum" ;;
assign_nat "i" 4 ;;
assign_nat "j" 4 ;;
while ( "i" <=' "j" )
(  assign_nat "sum" ("sum" +' 20) ;;
   assign_nat "i" ("i" +' 1)   ).

Example eval_sum2 :
  exists state, prgm2 ~{ env0 }~> state /\ state "sum" =cons_nat 20.
Proof.
eexists.
split.
unfold prgm1.
eapply e_seq.
eapply d_nat.
reflexivity.
eapply e_seq.
eapply d_nat.
reflexivity.
eapply e_seq.
eapply d_nat.
reflexivity.
eapply e_seq.

eapply a_nat.
eapply const.
reflexivity.
eapply e_seq.
eapply a_nat.
eapply const.
reflexivity.
eapply e_whiletrue.
eapply lessthan_b.
eapply var.
eapply var.
simpl.
eauto.
eapply e_seq.
eapply e_seq.
eapply a_nat.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply a_nat.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply e_whilefalse.
eapply lessthan_b.
eapply var.
eapply var.
eauto.
eauto.
Qed.

Definition prgrm3 :=
DSNAT "stiva"  ;;
push_stiva_nat "stiva" 3 ;;
push_stiva_nat "stiva" 6 ;;
pop_stiva_nat "stiva" .

Example eval_sum3 :
  exists state, prgrm3 ~{ env0 }~> state /\ state "stiva" =cons_stiva_nat (stiva_nevida NaturalV 3 (stiva_vida NaturalV)) .
eexists.
split.
unfold prgrm3.
eapply e_seq.
eapply ds_nat.
eauto.
eapply e_seq.
eapply e_push_nat.
eauto.
eauto.
eauto.
eapply e_seq.
eapply e_push_nat.
eauto.
eauto.
eauto.
eauto.
eauto.
eapply e_pop_nat.
eauto.
eauto.
eauto.
eauto.
Qed.

Example prgm4 :=
 DNAT "i"  ;;
 DNAT "j"  ;;
DNAT "sum" ;;
assign_nat "i" 4 ;;
assign_nat "j" 4 ;;
while ( "i" <=' 20 )
(assign_nat "sum" ("sum" +' 20) ;;
   assign_nat "i" ("i" +' 1) ;;
   break   ).

Example eval_sum4 :
  exists state, prgm4 ~{ env0 }~> state /\ state "sum" =cons_nat 20.
Proof.
eexists.
split.
unfold prgm4.
eapply e_seq.
eapply d_nat.
eauto.
eapply e_seq.
eapply d_nat.
eauto.
eapply e_seq.
eapply d_nat.
eauto.
eapply e_seq.
eapply a_nat.
eauto.
eapply const.
eauto.
eapply e_seq.
eapply a_nat.
eauto.
eapply const.
eauto.
eapply e_while_break_1.
eapply lessthan_b.
eapply var.
eapply const.
reflexivity.
eapply e_seq.
eapply a_nat.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply e_seq.
eapply a_nat.
eapply add.
eapply var.
eapply const.
simpl.
reflexivity.
reflexivity.
eapply e_break.
reflexivity.
Qed.


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  - definition of universal property of product
  - some lemmas about interplay of product morphism with composition

*)

Require Import Theory.Category.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＰＲＯＤＵＣＴ  ＯＦ  ＯＢＪＥＣＴＳ
  ----------------------------------------------------------------------------*)
(** * Product of object **)

(** ** Definition of universal property of product **)

Structure Product {𝒞 : Category} (A B : 𝒞) : Type := mkProduct
{ AxB            :> 𝒞
; Pmor           : ∀ {C : 𝒞}, [ C ⇒ A ⟶ C ⇒ B ⟶ C ⇒ AxB ] where "⟨ f , g ⟩" := (Pmor f g)
; π₁             : AxB ⇒ A
; π₂             : AxB ⇒ B
; π₁_compose     : ∀ {C : 𝒞} {f : C ⇒ A} {g : C ⇒ B}, π₁ ∘ ⟨ f , g ⟩ ≈ f
; π₂_compose     : ∀ {C : 𝒞} {f : C ⇒ A} {g : C ⇒ B}, π₂ ∘ ⟨ f , g ⟩ ≈ g
; Pmor_universal : ∀ {C : 𝒞} {f : C ⇒ A} {g : C ⇒ B} {i : C ⇒ AxB},
                     π₁ ∘ i ≈ f → π₂ ∘ i ≈ g → i ≈ ⟨ f , g ⟩ }.

Arguments mkProduct {_ _ _ _ _ _ _} _ _ _.
Arguments AxB       {_ _ _} _.
Arguments Pmor      {_ _ _} {_ _}.
Arguments π₁        {_ _ _ _}.
Arguments π₂        {_ _ _ _}.

Notation "⟨ f , g ⟩" := (Pmor f g).
Notation "P '⋅π₁'" := (π₁ (p := P)) (at level 0, only parsing).
Notation "P '⋅π₂'" := (π₂ (p := P)) (at level 0, only parsing).
Notation "'π₁[' A , B ]" := (π₁ (A := A) (B := B)) (only parsing).
Notation "'π₂[' A , B ]" := (π₂ (A := A) (B := B)) (only parsing).

(*------------------------------------------------------------------------------
  -- ＨＡＳ  ＢＩＮＡＲＹ  ＰＲＯＤＵＣＴ
  ----------------------------------------------------------------------------*)
(** ** Category has binary product **)

Class BinaryProduct (𝒞 : Category) :=
  product : ∀ (A B : 𝒞), Product A B.

Infix "×" := product (at level 20).

Notation "'BinaryProduct.make' ⦃ 'Category' ≔ 𝒞 ; '_×_' ≔ pr ; '⟨_,_⟩' ≔ prm ; 'π₁' ≔ pr1 ; 'π₂' ≔ pr2 ⦄" :=
  (λ (A B : 𝒞) ∙ @mkProduct _ A B (pr A B) (λ C ∙ Π₂.make (prm C)) pr1 pr2 _ _ _) (only parsing).

(*------------------------------------------------------------------------------
  -- ＰＲＯＤＵＣＴ  ＬＡＷＳ
  ----------------------------------------------------------------------------*)

(** ** Laws on product **)

Program Definition prod_on_arrow
        `{BinaryProduct 𝒞} {A A' B B'} : [ A ⇒ A' ⟶ B ⇒ B' ⟶ A × B ⇒ A' × B' ] :=
  λ f g ↦₂ ⟨ f ∘ π₁ , g ∘ π₂ ⟩.
Next Obligation.
  intros f₁ f₂ eq_f₁f₂ g₁ g₂ eq_g₁g₂.
  now rewrite eq_f₁f₂, eq_g₁g₂.
Qed.

Infix "-×-" := prod_on_arrow (at level 35).

Lemma product_postcompose `{BinaryProduct 𝒞} {A B C C' : 𝒞} {f : B ⇒ C} {g : B ⇒ C'} {p : A ⇒ B} :
   ⟨ f , g ⟩ ∘ p ≈ ⟨ f ∘ p , g ∘ p ⟩    :> A ⇒ C × C'.
Proof.
  apply Pmor_universal.
  - rewrite <- compose_assoc. now rewrite π₁_compose.
  - rewrite <- compose_assoc. now rewrite π₂_compose.
Qed.

Lemma product_precompose `{BinaryProduct 𝒞} {A B C D E : 𝒞}
      {f : B ⇒ D} {g : C ⇒ E} {h : A ⇒ B} {k : A ⇒ C} : f-×-g ∘ ⟨ h , k ⟩ ≈ ⟨ f ∘ h , g ∘ k ⟩    :> A ⇒ D × E.
Proof.
  apply Pmor_universal.
  - rewrite <- compose_assoc. simpl. rewrite π₁_compose. rewrite compose_assoc. now rewrite π₁_compose.
  - rewrite <- compose_assoc. simpl. rewrite π₂_compose. rewrite compose_assoc. now rewrite π₂_compose.
Qed.

Notation "∘-×" := product_postcompose (only parsing).
Notation "×-∘" := product_precompose  (only parsing).


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require real.Real.
Require real.Square.

(* Why3 assumption *)
Definition dot (x1:R) (x2:R) (y1:R) (y2:R): R :=
  ((x1 * y1)%R + (x2 * y2)%R)%R.

(* Why3 assumption *)
Definition norm2 (x1:R) (x2:R): R :=
  ((Reals.RIneq.Rsqr x1) + (Reals.RIneq.Rsqr x2))%R.

Axiom norm2_pos : forall (x1:R) (x2:R), (0%R <= (norm2 x1 x2))%R.

(* Why3 assumption *)
Definition p (x1:R) (x2:R) (y1:R) (y2:R) (t:R): R := (((norm2 x1
  x2) + ((2%R * t)%R * (dot x1 x2 y1
  y2))%R)%R + ((Reals.RIneq.Rsqr t) * (norm2 y1 y2))%R)%R.

Axiom p_expr : forall (x1:R) (x2:R) (y1:R) (y2:R) (t:R), ((p x1 x2 y1 y2
  t) = (norm2 (x1 + (t * y1)%R)%R (x2 + (t * y2)%R)%R)).

Axiom p_pos : forall (x1:R) (x2:R) (y1:R) (y2:R) (t:R), (0%R <= (p x1 x2 y1
  y2 t))%R.

Axiom mul_div_simpl : forall (x:R) (y:R), (~ (y = 0%R)) ->
  (((x / y)%R * y)%R = x).

Axiom p_val_part : forall (x1:R) (x2:R) (y1:R) (y2:R), (0%R < (norm2 y1
  y2))%R -> ((p x1 x2 y1 y2 (-((dot x1 x2 y1 y2) / (norm2 y1
  y2))%R)%R) = ((norm2 x1 x2) - ((Reals.RIneq.Rsqr (dot x1 x2 y1
  y2)) / (norm2 y1 y2))%R)%R).

Axiom p_val_part_pos : forall (x1:R) (x2:R) (y1:R) (y2:R), (0%R < (norm2 y1
  y2))%R -> (0%R <= ((norm2 x1 x2) - ((Reals.RIneq.Rsqr (dot x1 x2 y1
  y2)) / (norm2 y1 y2))%R)%R)%R.

Axiom p_val_part_pos_aux : forall (x1:R) (x2:R) (y1:R) (y2:R),
  (0%R < (norm2 y1 y2))%R -> (0%R <= ((norm2 y1 y2) * (p x1 x2 y1 y2
  ((-(dot x1 x2 y1 y2))%R / (norm2 y1 y2))%R))%R)%R.

Axiom CauchySchwarz_aux_non_null : forall (x1:R) (x2:R) (y1:R) (y2:R),
  (0%R < (norm2 y1 y2))%R -> ((Reals.RIneq.Rsqr (dot x1 x2 y1
  y2)) <= ((norm2 x1 x2) * (norm2 y1 y2))%R)%R.

Axiom norm_null : forall (y1:R) (y2:R), ((norm2 y1 y2) = 0%R) ->
  ((y1 = 0%R) \/ (y2 = 0%R)).

Axiom CauchySchwarz_aux_null : forall (x1:R) (x2:R) (y1:R) (y2:R), ((norm2 y1
  y2) = 0%R) -> ((Reals.RIneq.Rsqr (dot x1 x2 y1 y2)) <= ((norm2 x1
  x2) * (norm2 y1 y2))%R)%R.

Axiom CauchySchwarz_aux : forall (x1:R) (x2:R) (y1:R) (y2:R),
  ((Reals.RIneq.Rsqr (dot x1 x2 y1 y2)) <= ((norm2 x1 x2) * (norm2 y1
  y2))%R)%R.

(* Why3 assumption *)
Definition norm (x1:R) (x2:R): R := (Reals.R_sqrt.sqrt (norm2 x1 x2)).

Axiom norm_pos : forall (x1:R) (x2:R), (0%R <= (norm x1 x2))%R.

Axiom sqr_le_sqrt : forall (x:R) (y:R), ((0%R <= x)%R /\
  ((0%R <= (Reals.RIneq.Rsqr x))%R /\ ((Reals.RIneq.Rsqr x) <= y)%R)) ->
  (x <= (Reals.R_sqrt.sqrt y))%R.

Import R_sqrt.

(* Why3 goal *)
Theorem CauchySchwarz : forall (x1:R) (x2:R) (y1:R) (y2:R), ((dot x1 x2 y1
  y2) <= ((norm x1 x2) * (norm y1 y2))%R)%R.
(* Why3 intros x1 x2 y1 y2. *)
intros x1 x2 y1 y2.
unfold norm.
rewrite <- sqrt_mult.
assert (Hdot: (0 <= dot x1 x2 y1 y2)%R \/ (0 > dot x1 x2 y1 y2)%R).
generalize (Rtotal_order 0 (dot x1 x2 y1 y2))%R; intuition.

destruct Hdot.
apply sqr_le_sqrt.
intuition.
apply CauchySchwarz_aux.

apply Rle_trans with 0%R.
intuition.

apply sqrt_pos.
apply norm2_pos.
apply norm2_pos.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Le.
Require Import Lt.

Open Local Scope nat_scope.

Implicit Types k l p q r : nat.

Section Between.
  Variables P Q : nat -> Prop.

  Inductive between k : nat -> Prop :=
    | bet_emp : between k k
    | bet_S : forall l, between k l -> P l -> between k (S l).

  Hint Constructors between: arith v62.

  Lemma bet_eq : forall k l, l = k -> between k l.
  Proof.
    induction 1; auto with arith.
  Qed.

  Hint Resolve bet_eq: arith v62.

  Lemma between_le : forall k l, between k l -> k <= l.
  Proof.
    induction 1; auto with arith.
  Qed.
  Hint Immediate between_le: arith v62.

  Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
  Proof.
    intros k l H; induction H as [|l H].
    intros; absurd (S k <= k); auto with arith.
    destruct H; auto with arith.
  Qed.
  Hint Resolve between_Sk_l: arith v62.

  Lemma between_restr :
    forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m.
  Proof.
    induction 1; auto with arith.
  Qed.

  Inductive exists_between k : nat -> Prop :=
    | exists_S : forall l, exists_between k l -> exists_between k (S l)
    | exists_le : forall l, k <= l -> Q l -> exists_between k (S l).

  Hint Constructors exists_between: arith v62.

  Lemma exists_le_S : forall k l, exists_between k l -> S k <= l.
  Proof.
    induction 1; auto with arith.
  Qed.

  Lemma exists_lt : forall k l, exists_between k l -> k < l.
  Proof exists_le_S.
  Hint Immediate exists_le_S exists_lt: arith v62.

  Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l.
  Proof.
    intros; apply le_S_n; auto with arith.
  Qed.
  Hint Immediate exists_S_le: arith v62.

  Definition in_int p q r := p <= r /\ r < q.

  Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
  Proof.
    red in |- *; auto with arith.
  Qed.
  Hint Resolve in_int_intro: arith v62.

  Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
  Proof.
    induction 1; intros.
    apply le_lt_trans with r; auto with arith.
  Qed.

  Lemma in_int_p_Sq :
    forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat.
  Proof.
    induction 1; intros.
    elim (le_lt_or_eq r q); auto with arith.
  Qed.

  Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r.
  Proof.
    induction 1; auto with arith.
  Qed.
  Hint Resolve in_int_S: arith v62.

  Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
  Proof.
    induction 1; auto with arith.
  Qed.
  Hint Immediate in_int_Sp_q: arith v62.

  Lemma between_in_int :
    forall k l, between k l -> forall r, in_int k l r -> P r.
  Proof.
    induction 1; intros.
    absurd (k < k); auto with arith.
    apply in_int_lt with r; auto with arith.
    elim (in_int_p_Sq k l r); intros; auto with arith.
    rewrite H2; trivial with arith.
  Qed.

  Lemma in_int_between :
    forall k l, k <= l -> (forall r, in_int k l r -> P r) -> between k l.
  Proof.
    induction 1; auto with arith.
  Qed.

  Lemma exists_in_int :
    forall k l, exists_between k l ->  exists2 m : nat, in_int k l m & Q m.
  Proof.
    induction 1.
    case IHexists_between; intros p inp Qp; exists p; auto with arith.
    exists l; auto with arith.
  Qed.

  Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l.
  Proof.
    destruct 1; intros.
    elim H0; auto with arith.
  Qed.

  Lemma between_or_exists :
    forall k l,
      k <= l ->
      (forall n:nat, in_int k l n -> P n \/ Q n) ->
      between k l \/ exists_between k l.
  Proof.
    induction 1; intros; auto with arith.
    elim IHle; intro; auto with arith.
    elim (H0 m); auto with arith.
  Qed.

  Lemma between_not_exists :
    forall k l,
      between k l ->
      (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
  Proof.
    induction 1; red in |- *; intros.
    absurd (k < k); auto with arith.
    absurd (Q l); auto with arith.
    elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
    replace l with l'; auto with arith.
    elim inl'; intros.
    elim (le_lt_or_eq l' l); auto with arith; intros.
    absurd (exists_between k l); auto with arith.
    apply in_int_exists with l'; auto with arith.
  Qed.

  Inductive P_nth (init:nat) : nat -> nat -> Prop :=
    | nth_O : P_nth init init 0
    | nth_S :
      forall k l (n:nat),
	P_nth init k n -> between (S k) l -> Q l -> P_nth init l (S n).

  Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l.
  Proof.
    induction 1; intros; auto with arith.
    apply le_trans with (S k); auto with arith.
  Qed.

  Definition eventually (n:nat) :=  exists2 k : nat, k <= n & Q k.

  Lemma event_O : eventually 0 -> Q 0.
  Proof.
    induction 1; intros.
    replace 0 with x; auto with arith.
  Qed.

End Between.

Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le
  in_int_S in_int_intro: arith v62.
Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.