From Coq Require Import ssreflect ssrfun ssrbool.

Require Import Setoid.
From Coq Require Import Ensembles.
From Coq.Logic Require Import FunctionalExtensionality.
From Coq.Logic Require Import PropExtensionality ClassicalFacts.

From stdpp Require Import base list sets propset.

From MatchingLogic Require Import
  Syntax
  Semantics
  DerivedOperators_Syntax
  DerivedOperators_Semantics
  monotonic
  Utils.Lattice
  Utils.stdpp_ext
  IndexManipulation
.

Import MatchingLogic.Syntax.Notations.
Import MatchingLogic.Substitution.Notations.
Import MatchingLogic.DerivedOperators_Syntax.Notations.

Section with_signature.
  Context {Σ : Signature}.
  Open Scope ml_scope.

  Lemma eval_mu_lfp_fixpoint M ρ ϕ :
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    let Sfix := @eval Σ M ρ (patt_mu ϕ) in
    F Sfix = Sfix.
  Proof.
    simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    remember (@eval _ M ρ (patt_mu ϕ)) as Sfix.
    pose (OS := PropsetOrderedSet (Domain M)).
    pose (L := PowersetLattice (Domain M)).
    intros Hwfp.

    assert (HFmono: MonotonicFunction F).
    { rewrite HeqF. rewrite /Fassoc. apply is_monotonic. apply Hwfp.
      rewrite HeqX. apply set_svar_fresh_is_fresh.
    }

    assert (Ffix : Lattice.isFixpoint F (Lattice.LeastFixpointOf F)).
    { apply Lattice.LeastFixpoint_fixpoint. apply HFmono.
    }

    unfold isFixpoint in Ffix.
    rewrite eval_mu_simpl in HeqSfix.
    simpl in HeqSfix.
    unfold Fassoc in HeqF.
    rewrite HeqX in HeqF.
    rewrite -HeqF in HeqSfix.
    rewrite -HeqSfix in Ffix.
    apply Ffix.
  Qed.

  Lemma eval_mu_lfp_least M ρ ϕ S:
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    let Sfix := @eval Σ M ρ (patt_mu ϕ) in
    (F S) ⊆ S ->
    Sfix ⊆ S.
  Proof.
    simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    remember (@eval _ M ρ (patt_mu ϕ)) as Sfix.
    pose (OS := PropsetOrderedSet (Domain M)).
    pose (L := PowersetLattice (Domain M)).
    intros Hwfp.

    assert (HFmono: MonotonicFunction F).
    { rewrite HeqF. rewrite /Fassoc. apply is_monotonic. apply Hwfp.
      rewrite HeqX. apply set_svar_fresh_is_fresh.
    }

    assert (Hlfp: LeastFixpointOf F = Sfix).
    { subst. rewrite eval_mu_simpl. simpl. unfold Fassoc. reflexivity. }

    intros Hincl.

    pose proof (Hleast := LeastFixpoint_LesserThanPrefixpoint _ _ _ F S).
    simpl in Hleast. specialize (Hleast Hincl).
    rewrite Hlfp in Hleast. apply Hleast.
  Qed.

  Lemma eval_mu_if_lfp M ρ ϕ Sfix :
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    (F Sfix) ⊆ Sfix ->
    (∀ S, (F S) ⊆ S -> Sfix ⊆ S) ->
    Sfix = @eval Σ M ρ (patt_mu ϕ).
  Proof.
    intros Hwfp. simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    intros Hprefix Hleast.
    rewrite eval_mu_simpl. simpl.
    unfold Fassoc in HeqF. rewrite HeqX in HeqF. rewrite -HeqF.
    apply LeastFixpoint_unique. { apply Hprefix. } apply Hleast.
  Qed.

  Lemma eval_mu_lfp_iff M ρ ϕ Sfix :
    well_formed_positive (patt_mu ϕ) ->
    let X := fresh_svar ϕ in
    let F := Fassoc ρ (ϕ^{svar: 0 ↦ X}) X in
    (
    (F Sfix) ⊆ Sfix /\
    (∀ S, (F S) ⊆ S -> Sfix ⊆ S)
    ) <-> Sfix = @eval Σ M ρ (patt_mu ϕ).
  Proof.
    intros Hwfp. simpl.
    remember (fresh_svar ϕ) as X.
    remember (Fassoc ρ (ϕ^{svar: 0 ↦ X}) X) as F.
    remember (@eval Σ M ρ (patt_mu ϕ)) as Sfix'.
    split.
    - intros [H1 H2]. subst.
      auto using eval_mu_if_lfp.
    - intros H. split.
      + subst.
        match goal with
        | |- ?L ⊆ ?R => assert (H: L = R)
        end.
        apply eval_mu_lfp_fixpoint. apply Hwfp.
        rewrite H. apply reflexivity.
      + intros S. subst. apply eval_mu_lfp_least. apply Hwfp.
  Qed.

  (* mu X. base \/ step X *)
  (* [Nats] = mu X. 0 \/ succ X *)
  (* [Nats] = \{ x | \ex x0,x1,..x_n . x0 \in 0 /\ x(i+1) \in succ xi }*)
  (*  0, 1, 2,... x*)
  Section inductive_generation.
    Context (base step : Pattern).

    Let patt_ind_gen_body := (patt_or (nest_mu base) (patt_app (nest_mu step) (patt_bound_svar 0))).
    Let patt_ind_gen_simple_body := (patt_or base (patt_app step (patt_free_svar (fresh_svar patt_ind_gen_body)))).

    Definition patt_ind_gen := patt_mu patt_ind_gen_body.

    Hypothesis (Hwfpbase : well_formed_positive base).
    Hypothesis (Hwfpstep : well_formed_positive step).

    Lemma patt_ind_gen_wfp:
      well_formed_positive patt_ind_gen.
    Proof.
      unfold patt_ind_gen. simpl.
      rewrite !andb_true_r.
      rewrite !well_formed_positive_nest_mu_aux.
      rewrite Hwfpbase.
      rewrite Hwfpstep.
      rewrite !andb_true_r.

      cbn. fold no_negative_occurrence_db_b.

      rewrite !no_negative_occurrence_db_nest_mu_aux. simpl.
      auto.
    Qed.

    Lemma svar_open_patt_ind_gen_body_simpl M ρ X:
      svar_is_fresh_in X patt_ind_gen_body ->
      @eval Σ M ρ (patt_ind_gen_body^{svar: 0 ↦ X})
      = @eval Σ M ρ (patt_or base (patt_app step (patt_free_svar X))).
    Proof.
      intros Hfr.
      unfold svar_is_fresh_in in Hfr. simpl in Hfr.
      rewrite !simpl_free_svars in Hfr.
      apply sets.not_elem_of_union in Hfr.
      destruct Hfr as [Hfr1 Hfr2].

      rewrite /patt_ind_gen_body.
      unfold svar_open.
      mlSimpl. simpl.
      rewrite 2!eval_or_simpl.
      unfold nest_mu. rewrite 2!nest_mu_same.
      reflexivity.
    Qed.

    Section with_eval.
      Context (M : @Model Σ).
      Context (ρ : @Valuation Σ M).

      Let F := let X := fresh_svar patt_ind_gen_body in
               @Fassoc Σ M ρ (patt_ind_gen_body^{svar: 0 ↦ X}) X.
      (*
      Lemma svar_open_patt_ind_gen_body_assoc S:
        let X := fresh_svar patt_ind_gen_body in
        eval ρₑ (update_svar_val X S ρₛ) (svar_open 0 X patt_ind_gen_body)
        = F S.
      Proof. reflexivity.
             (*
        cbv zeta.
        rewrite svar_open_patt_ind_gen_body_simpl.
        { apply set_svar_fresh_is_fresh. }
        subst F. unfold Fassoc.
        rewrite svar_open_patt_ind_gen_body_simpl.
        { apply set_svar_fresh_is_fresh.  }
        reflexivity.*)
      Qed.
       *)

      (* I can imagine this lemma to be proven automatically. *)
      Lemma F_interp: F = λ A, (eval ρ base)
                                 ∪ (app_ext (eval ρ step) A).
      Proof.
        unfold F. unfold Fassoc. apply functional_extensionality.
        intros A. rewrite svar_open_patt_ind_gen_body_simpl.
        { apply set_svar_fresh_is_fresh. }

        rewrite eval_or_simpl.
        rewrite eval_app_simpl.
        rewrite eval_free_svar_simpl.
        rewrite update_svar_val_same.
        rewrite eval_free_svar_independent.
        {
          eapply svar_is_fresh_in_richer.
          2: { apply set_svar_fresh_is_fresh. }
          solve_free_svars_inclusion 5.
        }
        rewrite eval_free_svar_independent.
        {
          eapply svar_is_fresh_in_richer.
          2: { apply set_svar_fresh_is_fresh. }
          solve_free_svars_inclusion 5.
        }
        reflexivity.
      Qed.

      Definition is_witnessing_sequence_old (m : Domain M) (l : list (Domain M)) :=
        (last l = Some m) /\
        (match l with
         | [] => False
         | m₀::ms => (m₀ ∈ @eval Σ M ρ base)
                     /\  (@Forall _
                                  (λ (x : (Domain M) * (Domain M)),
                                   let (old, new) := x in
                                   new ∈
                                  app_ext
                                    (@eval Σ M ρ step)
                                    {[ old ]}
                                 )
                                 (zip (m₀::ms) ms)
                         )

         end).

      Definition is_witnessing_sequence (m : Domain M) (l : list (Domain M)) :=
        (∃ lst, last l = Some lst /\ lst ∈ @eval Σ M ρ base)
          /\
          hd_error l = Some m
          /\
          ((@Forall _ (uncurry (λ new old,
                              new ∈
                     app_ext
                       (@eval Σ M ρ step)
                       {[old]}
                    ))
                    (zip l (tail l))
          )).

      (* If we have a witnessing sequence x₁ x₂ ... xₙ xₙ₊₁ ... xlast
         and xₙ matches `base`, then xₙ xₙ₊₁ is a witnessing sequence, too.
       *)
      Lemma witnessing_sequence_middle (m : Domain M) (l : list (Domain M)) (n : nat) (m' : Domain M) :
        is_witnessing_sequence m l ->
        l !! n = Some m' ->
        m' ∈ @eval Σ M ρ base ->
        is_witnessing_sequence m' (drop n l).
      Proof.
        intros [[lst [Hlst Hbase] ] [Hhd Hfa] ] Hm' Hbase'.
        split.
        { exists lst. split.
          rewrite -> last_drop with (x := lst).
          { reflexivity. }
          { apply Hlst. }
          { apply lookup_lt_is_Some_1.
            rewrite Hm'. exists m'. reflexivity.
          }
          apply Hbase.
        }
        split.
        { apply hd_drop_lookup. apply Hm'. }
        { rewrite tail_drop_comm.
          rewrite -zip_with_drop.
          apply Forall_drop.
          apply Hfa.
        }
      Qed.

      Lemma witnessing_sequence_tail (m : Domain M) (l : list (Domain M)) (m' : Domain M) :
        is_witnessing_sequence m l ->
        head (tail l) = Some m' ->
        is_witnessing_sequence m' (tail l).
      Proof.
        intros Hw Hhead.
        unfold is_witnessing_sequence in Hw.
        destruct Hw as [[lst [Hlst1 Hlst2] ] Hw].
        unfold is_witnessing_sequence.
        split.
        { exists lst.
          split. 2: apply Hlst2.
          eapply last_tail. 2: apply Hhead. apply Hlst1.
        }
        split.
        { apply Hhead. }
        rewrite -tail_zip.
        apply Forall_tail.
        destruct Hw as [Hw1 Hw2].
        apply Hw2.
      Qed.

      Lemma is_witnessing_sequence_iff_is_witnessing_sequence_old_reverse (m : Domain M) (l : list (Domain M)) :
        is_witnessing_sequence m l <-> is_witnessing_sequence_old m (reverse l).
      Proof.
        assert (Feq: (uncurry
                        (flip
                           (λ new old : Domain M,
                                        new ∈
                                        app_ext
                                          (eval ρ step)
                                          {[old]})
                     ))
                     =  (λ x : Domain M * Domain M,
                               let (old, new) := x in
                               new ∈
                               app_ext
                                 (eval ρ step)
                                 {[old]})).

        { apply functional_extensionality. intros [x₁ x₂].
          reflexivity.
        }

        split.
        - intros [[m' [Hlast Hbase] ] [Hhd Hfa] ].
          destruct l as [|x l].
          { simpl in Hhd. inversion Hhd. }
          simpl in Hhd. inversion Hhd. subst. clear Hhd.
          split.
          { rewrite reverse_cons. rewrite last_app_singleton.
            reflexivity.
          }

          (* reverse (m::l) <> nil *)
          destruct (reverse (m::l)) eqn:Heq.
          { assert ( length (reverse (m::l)) = @length (Domain M) []).
            { rewrite Heq. reflexivity. }
            rewrite reverse_length in H.
            simpl in H. inversion H.
          }

          assert (Hm'd: m' = d).
          {
            rewrite reverse_cons in Heq.
            pose proof (H := last_reverse_head _ l m).
            rewrite Hlast in H.
            unfold reverse in Heq.
            rewrite Heq in H.
            simpl in H.
            inversion H. subst.
            reflexivity.
          }
          subst.
          split.
          { apply Hbase. }
          clear Hbase.

          pose proof (Heq' := f_equal reverse Heq).
          rewrite reverse_involutive in Heq'.
          assert (Heq'' : l0 = tail (d::l0)).
          { reflexivity. }
          rewrite -> Heq'' at 2. clear Heq''.
          rewrite -Heq.
          clear Heq' Heq l0.
          apply Forall_zip_flip_reverse in Hfa.
          clear Hlast.

          rewrite Feq in Hfa.
          apply Hfa.
        - intros H.
          destruct H as [Hlast H2].
          destruct l as [|x l].
          { simpl in Hlast. inversion Hlast. }

          destruct (reverse (x::l)) as [|y ys] eqn:Heq.
          { inversion H2. }
          destruct H2 as [Hbase Hfa].

          rewrite -(reverse_involutive (y::ys)) in Heq.
          apply (@inj _ _ (=) _ reverse) in Heq.
          2: typeclasses eauto.

          split.
          { exists y.
            split.
            rewrite Heq.
            rewrite last_reverse.
            reflexivity.
            apply Hbase.
          }

          split.
          {
            rewrite Heq.
            rewrite head_reverse.
            apply Hlast.
          }

          assert (Hfeq': (λ new old : Domain M, new ∈ app_ext (eval ρ step) {[old]}) = flip (flip (λ new old : Domain M, new ∈ app_ext (eval ρ step) {[old]}))).
          { apply functional_extensionality. intros x0.
            apply functional_extensionality. intros x1.
            reflexivity.
          }
          rewrite Hfeq'.
          rewrite Heq.
          rewrite -Forall_zip_flip_reverse.
          rewrite Feq.
          apply Hfa.
      Qed.

      Lemma witnessing_sequence_extend (m m' : Domain M) (l : list (Domain M)) :
        (is_witnessing_sequence m l
         /\ (∃ step', step' ∈ eval ρ step /\ m' ∈ app_interp _ step' m)
        ) <-> (is_witnessing_sequence m' (m'::l) /\ l ≠ []).
      Proof.
        split.
        - intros [[[lst [Hlst Hbase] ] [Hhd Hwit] ] [step' [Hstep' Hm'] ] ].
          split.
          2: { destruct l. simpl in Hhd. inversion Hhd. discriminate. }
          move: m Hhd m' step' Hm' Hstep'.
          induction l; intros m Hhd m' step' Hm' Hstep'.
          + simpl in Hhd. inversion Hhd.
          + simpl in Hhd. inversion Hhd. subst a. clear Hhd.
            unfold is_witnessing_sequence.
            destruct l.
            { simpl in Hlst. inversion Hlst. subst m. clear Hlst.
              split.
              { exists lst. simpl. split. reflexivity. apply Hbase. }
              simpl. split. reflexivity. apply Forall_cons.
              split. exists step'. exists lst. split.
              apply Hstep'. split. constructor. apply Hm'.
              apply Forall_nil. exact I.
            }
            split.
            { exists lst. split. simpl. simpl in Hlst. apply Hlst. apply Hbase. }
            split.
            { reflexivity. }
            simpl in Hwit. simpl.
            apply Forall_cons.
            simpl in IHl. simpl in Hlst.
            specialize (IHl Hlst).
            inversion Hwit. subst. clear Hwit.
            specialize (IHl H2). clear Hlst H2.
            split.
            { exists step'. exists m. split. apply Hstep'. split. constructor. apply Hm'. }
            apply Forall_cons.
            split.
            { apply H1. }
            specialize (IHl d erefl).
            destruct H1 as [step'' [d'' [Hstep'' [Hd'' Hstep''d''] ] ] ].
            inversion Hd''. subst d''. clear Hd''.
            specialize (IHl m step'' Hstep''d'' Hstep'').
            unfold is_witnessing_sequence in IHl.
            simpl in IHl.
            destruct IHl as [_ [_ Hforall] ].
            inversion Hforall. subst. apply H2.
        -
      Abort.

      Lemma witnessing_sequence_old_extend
            (m x m' : Domain M) (l : list (Domain M)):
        (is_witnessing_sequence_old m (x::l) /\
        ∃ step', (step' ∈ eval ρ step /\
        m' ∈ app_interp _ step' m)) <->
        (last (x::l) = Some m /\ is_witnessing_sequence_old m' ((x::l) ++ [m'])).
      Proof.
        split.
        -
          intros [Hwit [step' [Hstep' Hm'] ] ].
          destruct Hwit as [Hwit1 [Hwit2 Hwit3] ].
          split.
          { apply Hwit1. }
          split.
          { apply last_snoc. }
          simpl.
          split.
          { apply Hwit2. }

          destruct l.
          { simpl. apply Forall_cons. split. 2: { apply Forall_nil. exact I. }
            exists step'. exists x. split.
            { apply Hstep'. }
            split.
            { constructor. }
            simpl in Hwit1. inversion Hwit1. subst. apply Hm'.
          }
          simpl.
          apply Forall_cons.
          simpl in Hwit3. inversion Hwit3. subst. clear Hwit3.
          rename H1 into Hd. rename H2 into Hwit.
          split.
          { apply Hd. } clear Hd.

          move: d Hwit1 Hwit.
          induction l.
          + intros D Hm _.
            simpl. simpl in Hm. inversion Hm. subst.
            clear Hm.
            apply Forall_cons.
            split.
            2: { apply Forall_nil. exact I. }
            exists step'. exists m. split.
            { apply Hstep'. }
            split.
            { constructor. }
            apply Hm'.
          + intros d Hlast Hwit. simpl.
            inversion Hwit. subst.
            apply Forall_cons.
            split.
            { apply H1. }
            apply IHl. simpl in Hlast. simpl. apply Hlast.
            apply H2.
        - intros [Hlast H].
          unfold is_witnessing_sequence in H.
          destruct H as [_ H].
          remember (length l) as len.
          assert (Hlen: length l <= len).
          { lia. }
          clear Heqlen. simpl in H.
          destruct H as [Hbase Hall].
          unfold is_witnessing_sequence.
          apply and_assoc.
          split.
          { apply Hlast. }
          apply and_assoc.
          split.
          { apply Hbase. }
          clear Hbase.

          move: x l Hlast Hall Hlen.
          induction len.
          + intros x l Hlast Hall Hlen.
            destruct l.
            2: { simpl in Hlen. lia.  }
            simpl. simpl in Hall.
            split.
            { apply Forall_nil. exact I. }
            inversion Hall. subst. clear Hall. clear H2.
            destruct H1 as [step' [m'' [Hstep' [Hm'm'' Hstep'm''] ] ] ].
            inversion Hm'm''. subst. clear Hm'm''.
            exists step'. split. apply Hstep'.
            simpl in Hlast. inversion Hlast. subst.
            apply Hstep'm''.
          + intros x l Hlast Hall Hlen.
            destruct l as [|x' l'].
            { simpl in Hlast. inversion Hlast. clear Hlast. subst.
              simpl in Hall.
              inversion Hall. subst. clear Hall.
              clear H2.
              simpl.
              split.
              { apply Forall_nil. exact I. }
              destruct H1 as [step' Hstep'].
              exists step'.
              destruct Hstep' as [m'' [Hstep' [Hmm'' Hm''] ] ].
              split.
              { apply Hstep'. }
              inversion Hmm''. subst.
              apply Hm''.
            }
            simpl in Hall. simpl in IHlen. simpl in Hlast.
            inversion Hall. subst. clear Hall.
            specialize (IHlen x' l' Hlast H2).
            simpl.
            rewrite Forall_cons.
            apply and_assoc.
            split.
            { apply H1. }
            apply IHlen.
            simpl in Hlen. lia.
      Qed.

      Definition witnessed_elements_old : propset (Domain M) :=
        PropSet (λ m, ∃ l, is_witnessing_sequence_old m l).

      Lemma witnessed_elements_old_prefixpoint : (F witnessed_elements_old) ⊆ witnessed_elements_old.
      Proof.
        rewrite elem_of_subseteq. intros x Hx.
        unfold F in Hx. unfold Fassoc in Hx. unfold svar_open in Hx. simpl in Hx.
        rewrite eval_or_simpl in Hx.
        fold ((nest_mu base)^{svar: 0 ↦ (fresh_svar patt_ind_gen_body)}) in Hx.
        fold ((nest_mu step)^{svar: 0 ↦ (fresh_svar patt_ind_gen_body)}) in Hx.
        destruct Hx.
        - unfold Ensembles.In in H.
          unfold witnessed_elements_old.
          exists [x]. unfold is_witnessing_sequence_old.
          simpl.
          split.
          { reflexivity. }
          split.
          2: { constructor. }
          rewrite eval_free_svar_independent in H.
          {
            eapply svar_is_fresh_in_richer. 2: { subst. auto. }
            unfold svar_open.
            solve_free_svars_inclusion 5.
          }
          simpl. unfold svar_open in H.
          rewrite nest_mu_same in H. auto.
        - unfold Ensembles.In in H.
          rewrite eval_app_simpl in H.
          rewrite eval_free_svar_simpl in H.
          rewrite update_svar_val_same in H.
          unfold app_ext in H.
          destruct H as [step' [m [H1 [H2 Happ] ] ] ].
          unfold witnessed_elements_old in H2.
          destruct H2 as [l Hl].

          unfold witnessed_elements_old.
          exists (l ++ [x]).

          (* `l` is not empty *)
          destruct l as [|m₀ l'] eqn:Heql.
          { unfold is_witnessing_sequence in Hl. destruct Hl. simpl in H. inversion H. }

          unfold svar_open in H1. rewrite nest_mu_same in H1.
          rewrite eval_free_svar_independent in H1.
          {
            eapply svar_is_fresh_in_richer.
            2: { apply set_svar_fresh_is_fresh. }
            solve_free_svars_inclusion 2.
          }

          epose proof (P := @witnessing_sequence_old_extend _ _ _ _).
          destruct P as [P _].
          specialize (P (conj Hl (@ex_intro _ _ step' (conj H1 Happ)))).
          apply P.
      Qed.

      Lemma interp_included_in_witnessed_elements_old:
        (@eval Σ M ρ patt_ind_gen) ⊆ witnessed_elements_old.
      Proof.
        apply eval_mu_lfp_least.
        { apply patt_ind_gen_wfp. }
        apply witnessed_elements_old_prefixpoint.
      Qed.

      Lemma eval_patt_ind_gen_fix :
        let Sfix := eval ρ patt_ind_gen in
        F Sfix = Sfix.
      Proof.
        apply eval_mu_lfp_fixpoint.
        apply patt_ind_gen_wfp.
      Qed.

      Definition witnessed_elements_old_of_max_len len : propset (Domain M) :=
        PropSet (λ m, ∃ l, is_witnessing_sequence_old m l /\ length l <= len).

      Lemma witnessed_elements_old_of_max_len_included_in_interp len:
        (witnessed_elements_old_of_max_len (S len)) ⊆ (@eval Σ M ρ patt_ind_gen).
      Proof.
        induction len.
        - unfold Included. intros m.
          rewrite -eval_patt_ind_gen_fix.
          unfold Ensembles.In.
          intros H.
          unfold witnessed_elements_old_of_max_len.
          rewrite F_interp.
          destruct H as [l [Hwit Hlen] ].
          unfold is_witnessing_sequence in Hwit.
          destruct Hwit as [Hlast Hm].
          destruct l.
          { simpl in Hlast. inversion Hlast. }
          destruct l.
          2: { simpl in Hlen. lia. }
          simpl in Hlast. inversion Hlast. clear Hlast. subst.
          destruct Hm as [Hm _].
          left. unfold Ensembles.In. apply Hm.
        - unfold Included. intros m.
          rewrite -eval_patt_ind_gen_fix.
          unfold Ensembles.In. intros H.
          destruct H as [l [Hwit Hlen] ].
          unfold Included in IHlen. unfold Ensembles.In in IHlen.
          rewrite F_interp.
          pose proof (Hwit' := Hwit).
          unfold is_witnessing_sequence in Hwit.
          destruct Hwit as [Hlast Hl].
          destruct l.
          { contradiction. }

          simpl in Hlen.
          destruct Hl as [Hd Hl].
          destruct l.
          + simpl in Hlast. inversion Hlast. clear Hlast. subst.
            left. unfold Ensembles.In. apply Hd.
          + right. unfold Ensembles.In.
            pose proof (P := witnessing_sequence_old_extend).
            destruct l as [|x' l'].
            { simpl in Hlast. inversion Hlast. subst.
              specialize (P d d m []).
              destruct P as [_ P]. simpl in P.
              simpl in Hl.
              inversion Hl. subst. clear Hl.
              assert (Hsomed: Some d = Some d).
              { reflexivity. }
              specialize (P (conj Hsomed Hwit')).
              destruct P as [Hwitd [step' Hstep'] ].
              exists step'. exists d.
              destruct Hstep' as [Hstep' Hm].
              split.
              { apply Hstep'. }
              split.
              { apply IHlen. unfold witnessed_elements_old_of_max_len.
                exists [d].
                split.
                2: { simpl. lia. }
                unfold is_witnessing_sequence. simpl.
                split.
                { reflexivity. }
                split.
                { apply Hd. }
                apply Forall_nil.
                exact I.
              }
              apply Hm.
            }
            simpl in P.
            simpl in Hlast.
            simpl in Hl.
            inversion Hl. subst. clear Hl.
            inversion H2. subst. clear H2.
            pose (mp := (rev (d0 :: x' :: l')) !! 1).
            simpl in mp.
            epose proof (Htot := (list_lookup_lookup_total_lt (rev (d0 :: x' :: l')) 1 _)).
            Unshelve. 2: { constructor. exact d0. }
            2: { simpl. rewrite app_length. rewrite app_length. simpl.  lia.  }

            remember (@lookup_total nat (@Domain Σ M) (list (@Domain Σ M))
                 (@list_lookup_total (@Domain Σ M) {| inhabitant := d0 |}) (S O)
                 (@rev (@Domain Σ M) (@cons (@Domain Σ M) d0 (@cons (@Domain Σ M) x' l')))) as mprev.

            specialize (IHlen mprev).
            unfold witnessed_elements_old_of_max_len in IHlen.
            specialize (P mprev d m  (rev (tl (rev (d0::x'::l'))))).

            assert (Heq1: d::d0::x'::l' = d::(rev (tail (rev (d0::x'::l')))) ++ [m]).
            {
              apply f_equal.
              simpl.
              assert (Hx'r: [x'] = rev [x']).
              { reflexivity. }
              rewrite Hx'r.
              rewrite -rev_app_distr.
              assert (Hd0r: [d0] = rev [d0]).
              { reflexivity. }
              rewrite Hd0r.
              rewrite -rev_app_distr.
              rewrite rev_tail_rev_app_last.
              simpl.
              apply Hlast.
              reflexivity.
            }
            destruct P as [_ P].

            destruct (rev (tail (rev (d0 :: x' :: l')))) eqn:Heqrev.
            {
              apply length_zero_iff_nil in Heqrev.
              rewrite rev_length in Heqrev.
              apply length_tail_zero in Heqrev.
              rewrite rev_length in Heqrev.
              simpl in Heqrev. lia.
            }

            simpl in Heq1. inversion Heq1. subst d0. clear Heq1.
            simpl in P.
            rewrite -H2 in P.

            assert (Hm : (match l with [] => Some d1 | _ :: _ => last l end ) = Some mprev).
            {
              clear P Heqrev H1 H3 H4 mp.
              destruct l.
              { simpl in H2. inversion H2. subst. reflexivity. }
              simpl.
              simpl in H2.
              inversion H2. subst x' l'. clear H2.
              simpl in Htot.
              destruct (l ++ [m]) eqn:Hcontra.
              { pose proof (Hcontra' := @app_length _ l [m]).
                rewrite Hcontra in Hcontra'.
                simpl in Hcontra'. lia.
              }
              rewrite -Hcontra in Htot.
              rewrite rev_app_distr in Htot. simpl in Htot.

              destruct l.
              { simpl in Htot. apply Htot. }
              simpl in Htot.
              rewrite -Htot.
              rewrite hd_error_lookup.
              rewrite hd_error_app. rewrite hd_error_app.
              simpl.
              apply last_rev_head.
            }
            specialize (P (@conj _ _ Hm Hwit')). clear Hm Hwit'.
            destruct P as [Hwitmprev [step' [Hstep' Hm] ] ].
            exists step'. exists mprev.
            split.
            { apply Hstep'. }
            split.
            2: { apply Hm. }
            apply IHlen.
            exists (d::d1::l).
            split.
            { apply Hwitmprev. }
            simpl. simpl in Hlen.
            assert (Hlen': S (length l') <= len).
            { lia. }
            assert (length (l') = length (l)).
            { apply (@list_len_slice _ _ _ _ _ H2). }
            rewrite -H. lia.
      Qed.

      Lemma witnessed_elements_old_included_in_interp:
        witnessed_elements_old ⊆ (@eval Σ M ρ patt_ind_gen).
      Proof.
        intros x H.
        unfold Ensembles.In in H. unfold witnessed_elements_old in H.
        destruct H as [wit Hwit].
        assert (H': x ∈ (witnessed_elements_old_of_max_len (length wit))).
        { unfold Ensembles.In. exists wit. split. apply Hwit. lia. }
        destruct wit as [|y l'] eqn:Hl.
        { unfold is_witnessing_sequence in Hwit. destruct Hwit. contradiction. }
        eapply witnessed_elements_old_of_max_len_included_in_interp.
        simpl in H'.
        apply H'.
      Qed.

      Definition witnessed_elements : propset (Domain M) :=
        PropSet (λ m, ∃ l, is_witnessing_sequence m l).

      Lemma witnessed_elements_old_eq_witnessed_elements :
        witnessed_elements_old = witnessed_elements.
      Proof.
        rewrite -> set_eq_subseteq.
        repeat rewrite -> elem_of_subseteq.
        split;
          unfold witnessed_elements_old; unfold witnessed_elements; intros m; intros [l H].
        + exists (reverse l).
          apply is_witnessing_sequence_iff_is_witnessing_sequence_old_reverse.
          rewrite reverse_involutive.
          exact H.
        + exists (reverse l).
          apply is_witnessing_sequence_iff_is_witnessing_sequence_old_reverse.
          apply H.
      Qed.

      Lemma patt_ind_gen_simpl:
        @eval Σ M ρ patt_ind_gen = witnessed_elements.
      Proof.
        rewrite -witnessed_elements_old_eq_witnessed_elements.
        rewrite -> set_eq_subseteq.
        split.
        + apply interp_included_in_witnessed_elements_old.
        + apply witnessed_elements_old_included_in_interp.
      Qed.

      Section injective.
        Hypothesis (Domain_eq_dec : EqDecision (Domain M)).
        Hypothesis (Hstep_total_function : @is_total_function _ M step witnessed_elements witnessed_elements ρ).
        Hypothesis (Hstep_injective : @total_function_is_injective _ M step witnessed_elements ρ).

        Hypothesis (Hbase_step_no_confusion
                    : (eval ρ base)
                        ∩ (app_ext (eval ρ step) witnessed_elements) = ∅).

        Lemma witnessed_elements_unique_seq :
          ∀ m l₁ l₂, is_witnessing_sequence m l₁ -> is_witnessing_sequence m l₂ -> l₁ = l₂.
        Proof.
          intros m l₁ l₂.
          wlog: l₁ l₂ / (length l₂ <= length l₁).
          { intros H Hw₁ Hw₂.
            destruct (decide (length l₁ <= length l₂)).
            - symmetry. apply H; auto.
            - apply H. lia. auto. auto.
          }
          intros Hlen12 Hw₁ Hw₂.

          assert (Hmwit: m ∈ witnessed_elements).
          { exists l₁. apply Hw₁. }

          assert (Hlcom:  (common_length l₁ l₂ = length l₂)).
          {
            destruct Hw₁ as [[lst₁ [Hlst₁ Hbase₁] ] [Hhd₁ Hfa₁] ].
            destruct l₁ as [|m₁ l₁].
            { simpl in Hlst₁. inversion Hlst₁. }
            simpl in Hhd₁. inversion Hhd₁. subst. clear Hhd₁.

            destruct Hw₂ as [[lst₂ [Hlst₂ Hbase₂] ] [Hhd₂ Hfa₂] ].
            destruct l₂ as [|m₂ l₂].
            { simpl in Hlst₂. inversion Hlst₂. }
            simpl in Hhd₂. inversion Hhd₂. subst. clear Hhd₂.

            simpl.
            destruct (decide (m=m)).
            2: { contradiction. }
            clear e.
            apply f_equal.

            simpl in Hlen12. rename Hlen12 into Hlen12'.
            assert (Hlen12: length l₂ <= length l₁).
            { lia. }
            clear Hlen12'.

            remember (length l₁) as len₁.
            rewrite Heqlen₁ in Hlen12.
            assert (Hlen₁ : length l₁ <= len₁).
            { lia. }
            clear Heqlen₁.

            move: m l₁ l₂ Hlen12 Hlen₁ Hlst₁ Hlst₂ Hfa₁ Hfa₂ Hmwit.
            induction len₁; intros m l₁ l₂ Hlen12 Hlen₁ Hlst₁ Hlst₂ Hfa₁ Hfa₂ Hmwit.
            - destruct l₁.
              2: { simpl in Hlen₁. lia. }
              destruct l₂.
              + reflexivity.
              + assert (length (d::l₂) = 0).
                { simpl in Hlen12. lia. }
                rewrite H. reflexivity.
            - destruct l₂ as [|b l₂].
              { rewrite common_length_l_nil. reflexivity. }

              destruct l₁ as [|a l'₁] eqn:Heq.
              { simpl in Hlen12. lia. }

              simpl in Hfa₁. inversion Hfa₁. subst. clear Hfa₁.
              rename H1 into Hma. rename H2 into Hfa₁.
              simpl in Hfa₂. inversion Hfa₂. subst. clear Hfa₂.
              rename H1 into Hmb. rename H2 into Hfa₂.

              assert (Hwita: a ∈ witnessed_elements).
              { exists (a::l'₁).
                split.
                { exists lst₁. split.
                  { simpl in Hlst₁. simpl. apply Hlst₁. }
                  apply Hbase₁.
                }
                split.
                { reflexivity. }
                simpl. apply Hfa₁.
              }

              assert (Hwitb: b ∈ witnessed_elements).
              { exists (b::l₂).
                split.
                { exists lst₂. split.
                  { simpl in Hlst₂. simpl. apply Hlst₂. }
                  apply Hbase₂.
                }
                split.
                { reflexivity. }
                simpl. apply Hfa₂.
              }

              simpl in Hma. simpl in Hmb.

              assert (Ham: app_ext (eval ρ step) {[a]} = {[m]}).
              {
                unfold is_total_function in Hstep_total_function.
                pose proof (Hstep_total_function _ Hwita).
                destruct H as [a' [_ Ha'] ].
                rewrite Ha' in Hma.
                inversion Hma. subst.
                apply Ha'.
              }

              assert (Hbm: app_ext (eval ρ step) {[b]} = {[m]}).
              {
                unfold is_total_function in Hstep_total_function.
                pose proof (Hstep_total_function _ Hwitb).
                destruct H as [b' [_ Hb'] ].
                rewrite Hb' in Hmb.
                inversion Hmb. subst.
                apply Hb'.
              }

              assert (Haeqb: a = b).
              { apply Hstep_injective.
                apply Hwita. apply Hwitb.
                unfold rel_of.
                rewrite Ham.
                rewrite Hbm.
                reflexivity.
              }
              subst.
              clear Ham Hbm Hwita Hma.

              simpl.
              destruct (decide (b=b)).
              2: { contradiction. }
              apply f_equal.

              apply IHlen₁ with (m := b).
              { simpl in Hlen12.  lia. }
              { simpl in Hlen₁. lia. }
              simpl in Hlst₁. simpl. apply Hlst₁.
              simpl in Hlst₂. simpl. apply Hlst₂.

              simpl. apply Hfa₁.
              simpl. apply Hfa₂.
              apply Hwitb.
          }

          assert (Hlast12: l₁ !! (length l₂ - 1) = l₂ !! (length l₂ - 1)).
          {
            eapply equal_up_to_common_length.
            erewrite Hlcom.
            assert (length l₂ > 0).
            {
              destruct l₂.
              { unfold is_witnessing_sequence in Hw₂.
                simpl in Hw₂. destruct Hw₂ as [_ [Contra _] ].
                inversion Contra.
              }
              simpl. lia.
            }
            lia.
          }

          (*assert (Hbasem': eval ρ base lst).*)

          assert (~ (length l₁ > length l₂)).
          {
            intros Hcontra.
            assert (Hlt : length l₂ - 1 < length l₁).
            { lia. }
            pose proof (Hexm := list_ex_elem l₁ (length l₂ - 1) Hlt). clear Hlt.
            destruct Hexm as [m' Hm'].
            pose proof (Hwsm := witnessing_sequence_middle _ _ _ _ Hw₁ Hm').
            pose proof (Hw₂' := Hw₂).
            unfold is_witnessing_sequence in Hw₂'.
            destruct Hw₂' as [[lst [Hlst1 Hlst2] ] _].
            rewrite list_last_length in Hlst1.
            assert (Hlsteqm' : m' = lst).
            {
              assert (Some m' = Some lst).
              { rewrite -Hm'. rewrite -Hlst1. apply Hlast12.  }
              inversion H. reflexivity.
            }
            subst lst.
            specialize (Hwsm Hlst2).
            clear Hm' Hlst1.

            destruct (drop (length l₂ - 1) l₁) eqn:Heq.
            {
              destruct Hwsm as [_ [Contra _] ].
              inversion Contra.
            }
            (* if `l` is empty, then length l₁ = length l₂ -> Contradiction *)
            destruct l.
            {
              assert (Hlendrop: length (drop (length l₂ - 1) l₁) = 1).
              { rewrite Heq. reflexivity. }
              rewrite drop_length in Hlendrop.
              assert (length l₂ <> 0).
              { intros Hcontra'.
                apply nil_length_inv in Hcontra'.
                subst l₂.
                destruct Hw₂ as [_ [HContra'' _] ].
                inversion HContra''.
              }
              lia.
            }
            (* `d0` is a member of `witnessed_elements` *)
            epose proof (Hwd0 := witnessing_sequence_tail _ _ _ Hwsm).
            simpl in Hwd0.
            assert (Htmp: Some d0 = Some d0).
            { reflexivity. }
            specialize (Hwd0 Htmp). clear Htmp.

            assert (Hd0we : d0 ∈ witnessed_elements).
            { exists (d0::l). apply Hwd0. }

            assert (Heqm'd : m' = d).
            { unfold is_witnessing_sequence in Hwsm.
              destruct Hwsm as [_ [H _] ].
              simpl in H. inversion H.
              reflexivity.
            }
            subst m'.

            (* `m'=d` matches `app_ext (eval ρ step) d0` *)
            assert (d ∈ app_ext
                      (eval ρ step)
                      {[d0]}).
            {
              unfold is_witnessing_sequence in Hwsm.
              simpl in Hwsm.
              destruct Hwsm as [_ [_ Hwsm] ].
              inversion Hwsm. subst.
              simpl in H1.
              apply H1.
            }
            rewrite -> set_eq_subseteq in Hbase_step_no_confusion.
            destruct Hbase_step_no_confusion as [H1 _].
            rewrite -> elem_of_subseteq in H1.
            specialize (H1 d).
            apply not_elem_of_empty in H1.
            { exact H1. }
            clear H1.
            split.
            - apply Hlst2.
            - unfold Ensembles.In.
              unfold app_ext.
              destruct H as [le' [re' [H1 [H2 H3] ] ] ].
              exists le'. exists d0.
              split.
              { apply H1. }
              split.
              { apply Hd0we. }
              inversion H2. subst. apply H3.
          }
          assert (Hlength12: length l₁ = length l₂).
          { lia. }
          clear Hlen12 H.

          apply (common_length_impl_eq _ _ Hlength12 Hlcom).
        Qed.

      End injective.

    End with_eval.

  End inductive_generation.

End with_signature.


(** * TAL-0 Typed Assembly Language *)

(** Based on paper by Greg Morrisett , TAL-0 is the design of a RISC-style typed assembly language which focuses on control-flow safety. This post provides a mechanized metatheory, particularly a machine checked proof of soundness of the TAL-0 type system as proposed by the author in section 4.2.10 of the book Advanced Topics in Types and Programming Languages.  *)

(** The TAL-0 language runs on an abstract machine which is represented by 3 components :

1. A heap H which is a finite, partial map from labels to heap values

2. a register file R which is a total map from registers to values, and

3. a current instruction sequence I.
 *)

Require Import Bool Arith Vector LibTactics.
Require Import Maps.

Definition registers := total_map nat.
Definition empty_regs : registers := t_empty 0.

Inductive val : Type :=
| ANum : nat -> val
| AReg : nat -> val
| ALab : nat -> val.

(** We denote addresses of instructions stored in the heap as labels. Unlike a typical machine where labels are resolved to some machine address, which are integers, we maintain a distinction between labels and arbit integers, as this complies with our goal to state and prove the control-flow safety i.e. we can only branch to a valid label, and not to any arbit integer. This will ensure that the machine never gets stuck while trying to do some invalid operation. *)
(*define relations for aeval , ieval*)
Fixpoint aeval (a : val) (R : registers) : nat :=
  match a with
  | ANum n => n
  | AReg d => R (Id d)
  | ALab l => l
  end.

Inductive instr : Type :=
| IMov : forall d : nat,
    val -> instr
| IAdd : forall d s : nat,
    instr
| ISub : forall d v : nat,
    instr
| IIf : forall d : nat,
    val -> instr.

Inductive instr_seq : Type :=
| ISeq : instr -> instr_seq -> instr_seq
| IJmp : val -> instr_seq.

(** Simple Notations are chosen for the sake of clarity while writing programs.*)
Notation "'R(' d ')' ':=' a" :=
  (IMov d (ANum a)) (at level 60).
Notation "'R(' d ')' '+:=' 'R(' s ')'" :=
  (IAdd d s) (at level 60).
Notation "'R(' s ')' '-:=' v" :=
  (ISub s v) (at level 60).
Notation "i1 ;; i2" :=
  (ISeq i1 i2) (at level 80, right associativity).
Notation "'JIF' 'R(' d ')' v" :=
  (IIf d (ANum v)) (at level 70).
Notation "'JMP' v" :=
  (IJmp (ALab v)) (at level 80).
Notation "'JMP' 'R(' r ')'" :=
  (IJmp (AReg r)) (at level 80).

Check JIF R(1) 2.
Check R(1) := 10.
Check R(2) +:= R(1).
Check R(2) -:= 1.
Check R(2) +:= R(1) ;; R(2) -:= 1 ;; JMP 2.
Check JMP 2.
Check JMP R(2).

Definition heaps := partial_map instr_seq.
Definition empty_heap : heaps := empty.

(* Machine State *)
Inductive st : Type :=
| St : heaps -> registers -> instr_seq -> st.

(** Evaluation of instructions is supposed to change the Machine State and thus some of its components H, R or I. These changes are posed as relations between initial and final state of the machine. *)
Inductive ieval : st -> st -> Prop :=
| R_IMov : forall H R I d a,
    ieval (St H R (R(d) := a ;; I)) (St H (t_update R (Id d) a) I)
| R_IAdd : forall H R I d s,
    ieval (St H R (R(d) +:= R(s) ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) I)
| R_ISub : forall H R I d v,
    ieval (St H R (R(d) -:= v ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) I)
| R_IJmp_Succ : forall H R I' a l,
    l = (aeval a R) -> H (Id l) = Some I' -> ieval (St H R (JMP l)) (St H R I')
| R_IJmpR_Succ : forall H R I' r,
    H (Id (R (Id r))) = Some I' -> ieval (St H R (JMP R(r))) (St H R I')
| R_IJmp_Fail : forall H R I a,
    H (Id (aeval a R)) = None -> ieval (St H R I) (St H R I)
| R_IIf_EQ : forall H R I I2 r v,
    aeval (AReg r) R = 0 -> (H (Id v)) = Some I2 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I2)
| R_IIf_NEQ : forall H R I r v,
    aeval (AReg r) R <> 0 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I)
| R_ISeq : forall st st' st'',
    ieval st st' -> ieval st' st'' -> ieval st st''.

(** Example of a program fragment that multiplies 2 numbers stored in registers 1 and 2 and stores their product in register 3, before finally looping in its final state register 4. *)
Definition init_heap := update (update (update empty_heap (Id 1) (R(3) := 0 ;; JMP 2)) (Id 2) (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2) ) (Id 3) (JMP R(4)).

Definition init_regs : registers :=  (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 7) 3) (Id 1) 1) (Id 2) 2).
Definition final_regs : registers := (t_update (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 4) 1) (Id 1) 0) (Id 2) 2) (Id 3) 2).

Eval compute in init_heap (Id (init_regs (Id 6))).

(* jump to a label proof *)
Example ieval_example1 : ieval (St init_heap init_regs
                                   (R(3) := 0 ;; JMP 2))
                               (St init_heap (t_update init_regs (Id 3) 0)
                                   (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2)).
Proof.
  apply R_ISeq with (St init_heap (t_update init_regs (Id 3) 0) (IJmp (ALab 2))).
  apply R_IMov.
  apply R_IJmp_Succ with (a := ALab 2).
  simpl.
  reflexivity.
  unfold init_heap.
  rewrite update_neq.
  rewrite update_eq.
  reflexivity.
  rewrite <- beq_id_false_iff; trivial.
Qed.

(** The types consist of
1. int -> represents arbit integer stored in a register

2. reg -> a type constructor. Takes as input, the type of the register, to which this register is pointing.

3. code -> takes as input a typing context Γ, and gives type (code Γ) which is the type of an instruction sequence that expects type of the Register file to be Γ before it begins execution

4. arrow -> represents type of a single instruction (excluding JMP), which expects register file of type Γ1 before execution, and changes it to Γ2 after it has executed.

5. T -> It is the super type. It is used to represent the type of a register in R, which contains the label of the instruction currently executing. Because in such a case, we have the equation : Γ (r) = code Γ, which in the absence of subtyping or polymorphic types can't be solved. Hence T is assigned the type for such a register as it subsumes all types including itself. When we jump through a register of type T, we forget the type assigned to it, and reassign T to it.
Morrisett's paper uses the polymorphic type for due to some more benefits it affords. However we have used T type for its simplicity.
 *)

Inductive ty : Type :=
| int : ty
| reg : ty -> ty
| code : partial_map ty -> ty
| arrow : partial_map ty -> partial_map ty -> ty
| True : ty.

Definition context := partial_map ty.

(* register file types *)
Definition empty_Gamma : context := empty.

(* heap types *)
Definition empty_Psi : context := empty.

(** The Typing Rules *)
(** Ψ is a partial map containing types of instruction sequences. As all instruction sequences end in a JMP statement, all valid values in Ψ are Some (code Γ) where Γ is the initial type state of register expected by that instruction sequence. Now, typing rules may require presence of either both Ψ and Γ, or only Ψ or neither. Hence, we introduce a combined context structure, that handles all the 3 cases. *)
Inductive cmbnd_ctx :=
| EmptyCtx : cmbnd_ctx
| PsiCtx : context -> cmbnd_ctx
| PsiGammaCtx : context -> context -> cmbnd_ctx.

(** Typing rules for arithmetic expressions *)
Inductive ahas_type : cmbnd_ctx -> val -> ty -> Prop :=
| S_Int : forall Ψ n,
    ahas_type (PsiCtx Ψ) (ANum n) int
| S_Lab : forall Ψ Γ l v R,
    Ψ (Id l) = Some (code Γ) -> l = aeval (ALab v) R -> ahas_type (PsiCtx Ψ) (ALab v) (code Γ)
| S_Reg : forall Ψ Γ r,
    Γ (Id r) = Some (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int)
| S_RegV : forall Ψ Γ r,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg (code Γ))
| S_RegT : forall Ψ Γ r,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True
| S_Val : forall Ψ Γ a tau,
    ahas_type (PsiCtx Ψ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) a tau.

Hint Constructors ahas_type.

(** Typing rules for instructions *)
Inductive ihas_type : cmbnd_ctx -> instr -> ty -> Prop :=
| S_Mov : forall Ψ Γ R d a tau,
    ahas_type (PsiGammaCtx Ψ Γ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg tau) -> (update Γ (Id d) (reg tau)) = Γ -> ihas_type (PsiCtx Ψ) (R(d) := aeval a R) (arrow Γ Γ)
| S_Add : forall Ψ Γ d s,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg int) -> update Γ (Id d) (reg int) = Γ -> ihas_type (PsiCtx Ψ) (R(d) +:= R(s)) (arrow Γ Γ)
| S_Sub : forall Ψ Γ s a v,
    ahas_type (PsiGammaCtx Ψ Γ) a int -> ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> a = ANum v -> ihas_type (PsiCtx Ψ) (R(s) -:= v) (arrow Γ Γ)
| S_If :  forall Ψ Γ r v,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> ihas_type (PsiCtx Ψ) (JIF R(r) v) (arrow Γ Γ).
Hint Constructors ihas_type.

Inductive iseq_has_type : cmbnd_ctx -> instr_seq -> ty -> Prop :=
| S_Jmp :  forall Ψ Γ v,
    ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> iseq_has_type (PsiCtx Ψ) (JMP v) (code Γ)
| S_JmpT :  forall Ψ Γ v,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg v) True -> iseq_has_type (PsiCtx Ψ) (JMP R(v)) (code Γ)
| S_Seq :  forall Ψ i1 i2 Γ Γ2,
    ihas_type (PsiCtx Ψ) i1 (arrow Γ Γ2) -> iseq_has_type (PsiCtx Ψ) i2 (code Γ2) -> iseq_has_type (PsiCtx Ψ) (ISeq i1 i2) (code Γ).                                           Hint Constructors iseq_has_type.

Definition init_Gamma : context := update (update (update (update empty_Gamma (Id 1) (reg int)) (Id 2) (reg int)) (Id 3) (reg int)) (Id 4) True.
Check init_Gamma.
Hint Unfold init_Gamma.

Definition init_Psi : context := update (update (update empty_Psi (Id 1) (code init_Gamma))(Id 3) (code init_Gamma)) (Id 2) (code init_Gamma).
Hint Unfold init_Psi.

Ltac match_map := repeat (try rewrite update_neq; try rewrite update_eq; try reflexivity).
Ltac inequality := (rewrite <- beq_id_false_iff; trivial).
Ltac crush_map := match_map ; inequality; try reflexivity.

Ltac rewrite_hyp :=
  match goal with
  | [ H : ?n = _ |- context[?n] ] => rewrite H
  end.

Ltac crush_generic :=
  repeat match goal with
         | [ H : ?T |- ?T    ] => exact T
         | [ |- ?T = ?T ] => reflexivity
         | [ |- True         ] => constructor
         | [ |- _ /\ _       ] => constructor
         | [ |- _ /\ _ -> _  ] => intro
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ |- nat -> _     ] => intro
         | _ => rewrite_hyp || eauto || jauto
         end.

Ltac crush :=
  repeat (crush_generic; match goal with
                         | [ |- update _ _ _ _ = _ ] => crush_map
                         | [ |- init_Gamma _ = _ ] => unfold init_Gamma
                         | [ |- init_Psi _ = _ ] => unfold init_Psi
                         | [ |- ieval _ _ ] => constructor; auto
                         | [ |- ihas_type _ _ _] => constructor; auto
                         | [ |- ?T -> False  ]  => assert T
                         | _ => try subst; trivial
                         end).

Example heap_2_type : forall I (R : registers), (init_heap (Id 2)) = Some I -> iseq_has_type (PsiCtx init_Psi) I (code init_Gamma).
Proof.
  intros.
  unfold init_heap in H.
  rewrite update_neq in H.
  rewrite update_eq in H.
  symmetry in H.
  inversion H.
  apply S_Seq with (Γ2 := init_Gamma).
  crush.
  constructor; auto.
  apply S_Lab with (l := 3) (R := R).
  crush.
  trivial.
  apply S_Seq with (Γ2 := init_Gamma).
  constructor; auto.
  crush.
  apply update_same.
  crush.
  apply S_Seq with (Γ2 := init_Gamma).
  unfold init_Psi.
  apply S_Sub with (a := ANum 1).
  unfold init_Psi.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  apply S_Lab with (l := 2) (R := R).
  crush.
  trivial.
  trivial.
  rewrite <- beq_id_false_iff.
  trivial.
Qed.

(** Typing rule for register file *)
Inductive Rhas_type : cmbnd_ctx -> registers -> context -> Prop :=
| S_Regfile : forall Ψ Γ R r tau a,
    (Γ (Id r)) = Some tau -> aeval a R = R (Id r) -> ahas_type (PsiGammaCtx Ψ Γ) a tau -> Rhas_type (PsiCtx Ψ) R Γ.

Hint Constructors Rhas_type.

(** Typing rule for Heap *)
Inductive Hhas_type : cmbnd_ctx -> heaps -> context -> Prop :=
| S_Heap : forall Ψ H,
    (forall l tau, exists is, Ψ (Id l) = Some tau /\ H (Id l) = Some is /\ iseq_has_type (PsiCtx Ψ) is tau) -> Hhas_type EmptyCtx H Ψ.

Hint Constructors Hhas_type.

(** Typing rule for a valid Machine State *)
Inductive M_ok : cmbnd_ctx -> heaps -> registers -> instr_seq -> Prop :=
| S_Mach : forall H R Is Ψ Γ,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> iseq_has_type (PsiCtx Ψ) Is (code Γ) -> M_ok EmptyCtx H R Is.

Hint Constructors M_ok.

(** We will require some Canonical Values Lemmas in our proof of Soundness *)
Lemma Canonical_Values_Int : forall H Ψ Γ v tau,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) v tau -> tau = int -> exists n, v = ANum n.
Proof.
  intros.
  subst.
  inversion H1.
  inversion H6.
  exists n.
  crush.
Qed.

Lemma Canonical_Values_Reg :forall H Ψ Γ r R,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> exists (n : nat), R (Id r) = n.
Proof.
  intros.
  exists (R (Id r)).
  crush.
Qed.

Lemma Canonical_Values_label1 : forall H Ψ Γ v,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) ->  Ψ (Id v) = Some (code Γ) -> exists is, H (Id v) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  inversion H7.
  simpl in H5.
  specialize H4 with ( l := v) (tau := code Γ).
  destruct H4 as [i G].
  exists i.
  crush.
Qed.

Lemma Canonical_Values_label2 : forall H Ψ Γ R r,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True -> exists is, H (Id (R (Id r))) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  apply G.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  crush.
Qed.

(** Finally the proof of Soundness *)
Theorem Soundness : forall H R Is,
    M_ok EmptyCtx H R Is -> exists H' R' Is', ieval (St H R Is) (St H' R' Is') /\ M_ok EmptyCtx H' R' Is'.
Proof.
  intros.
  inversion H0 ; induction Is; inverts H4.
  induction i; inversion H12;
    try match goal with
        | [H : Γ = Γ2 |- _ ] => symmetry in H
        end;
    try subst.

  (* ISeq IMov I *)
  exists H (t_update R (Id d) (aeval a R1)) Is.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (r := d) (tau := reg tau) (a := AReg d).
  rewrite <- H16.
  rewrite update_eq.
  crush.
  crush.
  crush.
  crush.

  (* ISeq IAdd I *)
  exists H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  rewrite <- H16; apply update_eq.
  crush.
  crush.
  crush.

  (* ISeq ISub I *)
  exists H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  inversion H15.
  crush.
  crush.
  inversion H15.
  crush.
  inversion H7.
  trivial.
  crush.
  crush.

  (* ISeq IIf I *)
  inversion H12.
  inversion H9.
  inversion H18.
  subst.
  simpl in H22.

  remember (R (Id d)) as rd; destruct rd.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H9 H22 as CVL1.
  destruct CVL1 as [Is' G].
  exists H R Is'.
  crush.

  exists H R Is.

  split.
  apply R_IIf_NEQ.
  simpl.
  symmetry in Heqrd; rewrite Heqrd.
  apply beq_nat_false_iff.
  trivial.
  crush.

  (*IJmp*)
  inversion H11; inversion H12.
  simpl in H17.
  subst.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H11 H16 as CVL1.
  destruct CVL1 as [Is G].

  exists H R Is.
  crush.
  apply R_IJmp_Succ with (a := ALab v0).
  crush.
  crush.

  (*IJmpT*)
  pose proof Canonical_Values_label2 H Ψ Γ R v0 H2 H11 as CVL3.
  destruct CVL3 as [Is G].

  exists H R Is.
  crush.
Qed.


Require Import Coq.Lists.List.
Require Import Shallow.Imp Shallow.Embeddings.

Inductive aexp : Type :=
  | ANum (n : Z)
  | AId (X : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp).

Module OptF.

Definition add {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 => Some (v1 + v2)
      | _, _ => None
    end.

Definition sub {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 => Some (v1 - v2)
      | _, _ => None
    end.

Definition mul {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 => Some (v1 * v2)
      | _, _ => None
    end.

Definition div {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 =>
          if Z.eq_dec v2 0 then None else Some (v1 / v2)
      | _, _ => None
    end.

End OptF.

Module Denote_Aexp.

Fixpoint aeval (a : aexp) : state -> option Z :=
  match a with
    | ANum n => fun _ => Some n
    | AId X => fun st => Some (st X)
    | APlus a1 a2 => OptF.add (aeval a1) (aeval a2)
    | AMinus a1 a2 => OptF.sub (aeval a1) (aeval a2)
    | AMult a1 a2 => OptF.mul (aeval a1) (aeval a2)
    | ADiv a1 a2 => OptF.div (aeval a1) (aeval a2)
  end.

End Denote_Aexp.

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Record bexp_denote : Type := {
  true_set : state -> Prop;
  false_set : state -> Prop;
  error_set : state -> Prop; }.

Definition opt_test (R: Z -> Z -> Prop) (X Y: state -> option Z): bexp_denote :=
  {|
    true_set := fun st =>
      match X st, Y st with
        | Some n1, Some n2 => R n1 n2
        | _, _ => False
      end;
    false_set := fun st =>
      match X st, Y st with
        | Some n1, Some n2 => ~R n1 n2
        | _, _ => False
      end;
    error_set := fun st =>
      match X st, Y st with
        | Some n1, Some n2 => False
        | _, _ => True
      end;
  |}.

Module Sets.

Definition union {A : Type} (X Y : A -> Prop) : A -> Prop :=
  fun a => X a \/ Y a.

Definition omega_union {A} (X : nat -> A -> Prop) : A -> Prop :=
  fun a => exists n, X n a.

End Sets.

Module Denote_Bexp.
Import Denote_Aexp.

Fixpoint beval (b : bexp) : bexp_denote :=
  match b with
  | BTrue =>
      {| true_set := Sets.full;
         false_set := Sets.empty;
         error_set := Sets.empty; |}
  | BFalse =>
      {| true_set := Sets.empty;
         false_set := Sets.full;
         error_set := Sets.empty; |}
  | BEq a1 a2 =>
      opt_test Z.eq (aeval a1) (aeval a2)
  | BLe a1 a2 =>
      opt_test Z.le (aeval a1) (aeval a2)
  | BNot b =>
      {| true_set := false_set (beval b);
         false_set := true_set (beval b);
         error_set := error_set (beval b); |}
  | BAnd b1 b2 =>
      {| true_set := Sets.intersect (true_set (beval b1)) (true_set (beval b2));
         false_set := Sets.union (false_set (beval b1))
                                 (Sets.intersect (true_set (beval b1))
                                                 (false_set (beval b2)));
         error_set := Sets.union (error_set (beval b1))
                                 (Sets.intersect (true_set (beval b1))
                                                 (error_set (beval b2))); |}
  end.

End Denote_Bexp.

Inductive com : Type :=
  | CSkip
  | CAss (X : var) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CFor (c1 c2 : com)
  | CBreak
  | CCont.

Record com_denote : Type := {
  com_normal : state -> state -> Prop;
  com_break : state -> state -> Prop;
  com_cont : state -> state -> Prop;
  com_error : state -> Prop }.

Module Denote_Com.
Import Denote_Aexp.
Import Denote_Bexp.

Definition skip_sem : com_denote := {|
  com_normal := fun st1 st2 => st1 = st2;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st => False; |}.

Definition asgn_sem (X : var) (DA : state -> option Z) : com_denote := {|
  com_normal := fun st1 st2 => (Some (st2 X) = DA st1) /\ (forall Y, Y <> X -> st2 Y = st1 Y);
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st => DA st = None; |}.

Definition seq_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    exists st3, com_normal DC1 st1 st3 /\ com_normal DC2 st3 st2;
  com_break := fun st1 st2 =>
    (com_break DC1 st1 st2) \/
    (exists st3, com_normal DC1 st1 st3 /\ com_break DC2 st3 st2);
  com_cont := fun st1 st2 =>
    (com_cont DC1 st1 st2) \/
    (exists st3, com_normal DC1 st1 st3 /\ com_cont DC2 st3 st2);
  com_error := fun st =>
    (com_error DC1 st) \/ (exists st', com_normal DC1 st st' /\ com_error DC2 st'); |}.

Definition if_sem (DB : bexp_denote) (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    (true_set DB st1 /\ com_normal DC1 st1 st2) \/
    (false_set DB st1 /\ com_normal DC2 st1 st2);
  com_break := fun st1 st2 =>
    (true_set DB st1 /\ com_break DC1 st1 st2) \/
    (false_set DB st1 /\ com_break DC2 st1 st2);
  com_cont := fun st1 st2 =>
    (true_set DB st1 /\ com_cont DC1 st1 st2) \/
    (false_set DB st1 /\ com_cont DC2 st1 st2);
  com_error := fun st =>
    (error_set DB st) \/
    (true_set DB st /\ com_error DC1 st) \/
    (false_set DB st /\ com_error DC2 st) |}.

Fixpoint iter_loop_body (DC1 DC2 : com_denote) (n : nat) : com_denote :=
  match n with
  | O => {|
      com_normal := fun st1 st2 =>
        (com_break DC1 st1 st2) \/
        (exists st3, com_normal DC1 st1 st3 /\ com_break DC2 st3 st2);
      com_break := fun st1 st2 => False;
      com_cont := fun st1 st2 => False;
      com_error := fun st =>
        (com_error DC1 st) \/
        (exists st', com_normal DC1 st st' /\ com_error DC2 st') |}
  | S n' => {|
      com_normal := fun st1 st2 => exists st3,
        ((com_normal (seq_sem DC1 DC2) st1 st3) \/ (com_cont (seq_sem DC1 DC2) st1 st3)) /\
        (com_normal (iter_loop_body DC1 DC2 n') st3 st2);
      com_break := fun st1 st2 => False;
      com_cont := fun st1 st2 => False;
      com_error := fun st => exists st',
        ((com_normal (seq_sem DC1 DC2) st st') \/ (com_cont (seq_sem DC1 DC2) st st')) /\
        (com_error (iter_loop_body DC1 DC2 n') st') |}
  end.

Definition for_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    exists n, com_normal (iter_loop_body DC1 DC2 n) st1 st2;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st =>
    exists n, com_error (iter_loop_body DC1 DC2 n) st |}.

Definition break_sem : com_denote := {|
  com_normal := fun st1 st2 => False;
  com_break := fun st1 st2 => st1 = st2;
  com_cont := fun st1 st2 => False;
  com_error := fun st => False |}.

Definition cont_sem : com_denote := {|
  com_normal := fun st1 st2 => False;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => st1 = st2;
  com_error := fun st => False |}.

Fixpoint ceval (c : com) : com_denote :=
  match c with
  | CSkip => skip_sem
  | CAss X a => asgn_sem X (aeval a)
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1) (ceval c2)
  | CFor c1 c2 => for_sem (ceval c1) (ceval c2)
  | CBreak => break_sem
  | CCont => cont_sem
  end.

End Denote_Com.

Module Assertion_Shallow.
Import Denote_Aexp.
Import Denote_Bexp.

Definition Assertion : Type := state -> Prop.

Definition Assertion_denote : state -> Assertion -> Prop :=
  fun st P => P st.

Definition andp : Assertion -> Assertion -> Assertion :=
  fun P Q st => P st /\ Q st.

Definition orp : Assertion -> Assertion -> Assertion :=
  fun P Q st => P st \/ Q st.

Definition negp : Assertion -> Assertion :=
  fun P st => ~ P st.

Definition falsep : Assertion :=
  fun st => False.

Definition inj : bexp -> Assertion :=
  fun b st => true_set (beval b) st.

Definition safea : aexp -> Assertion :=
  fun a st => ~ (aeval a) st = None.

Definition safeb : bexp -> Assertion :=
  fun b st => ~ error_set (beval b) st.

Definition derives : Assertion -> Assertion -> Prop :=
  fun P Q => forall st, P st -> Q st.

Definition state_update (st : state) (X : var) (v : option Z) : state :=
  match v with
  | Some n => fun Y => if (Nat.eq_dec X Y) then n else st Y
  | None => fun Y => 0
  end.

Definition subst_assertion (P : Assertion) (X : var) (v : state -> option Z) : Assertion :=
  fun st => P (state_update st X (v st)).

End Assertion_Shallow.

Module Denote_Embeddings.
Import Denote_Com.
Import Assertion_Shallow.

Definition com_term : com_denote -> state -> state -> Prop :=
  fun DC st1 st2 =>
    (com_normal DC st1 st2) \/ (com_break DC st1 st2) \/ (com_cont DC st1 st2).

Definition partial_valid (P : Assertion) (c : com) (Q R1 R2 : Assertion) : Prop :=
  forall st1 st2, Assertion_denote st1 P ->
    (~ com_error (ceval c) st1) /\
    ((com_normal (ceval c) st1 st2) -> Assertion_denote st2 Q) /\
    ((com_break (ceval c) st1 st2) -> Assertion_denote st2 R1) /\
    ((com_cont (ceval c) st1 st2) -> Assertion_denote st2 R2).

Definition total_valid (P : Assertion) (c : com) (Q R1 R2 : Assertion) : Prop :=
  (forall st1, Assertion_denote st1 P -> exists st2, com_term (ceval c) st1 st2) /\
  (partial_valid P c Q R1 R2).

End Denote_Embeddings.

Module rules_sound.
Import Denote_Com.
Import Denote_Embeddings.
Import Assertion_Shallow.

Definition WP (c : com) (Q R1 R2 : Assertion) : state -> Prop :=
  fun st =>
    (~ (com_error (ceval c) st)) /\
    (forall st',
      (com_normal (ceval c) st st' -> Assertion_denote st' Q) /\
      (com_break (ceval c) st st' -> Assertion_denote st' R1) /\
      (com_cont (ceval c) st st' -> Assertion_denote st' R2)).

Theorem seq_inv_sound_bigstep : forall P c1 c2 Q R1 R2,
  partial_valid P (CSeq c1 c2) Q R1 R2 ->
    (exists Q', partial_valid P c1 Q' R1 R2 /\ partial_valid Q' c2 Q R1 R2).
Proof.
  intros.
  exists (WP c2 Q R1 R2).
  remember (WP c2 Q R1 R2) as Q'.
  split.
  + (* partial_valid P c1 Q' R1 R2 *)
    unfold partial_valid in *.
    intros.
    split; try split; try split; intros.
    - specialize (H st1 st2 H0).
      destruct H as [HE [HN [HB HC]]].
      simpl in HE.
      unfold not in *; intros; apply HE; tauto.
    - subst Q'; unfold WP, Assertion_denote in *.
      split.
      { specialize (H st1 st2 H0).
        destruct H as [HE [HN [HB HC]]].
        unfold not in *.
        intros; apply HE.
        simpl; right; exists st2; tauto. }
      intros st3.
      specialize (H st1 st3 H0).
      destruct H as [HE [HN [HB HC]]].
      split; try split; intros;
        [apply HN | apply HB | apply HC]; simpl;
        [ | right | right]; exists st2; tauto.
    - specialize (H st1 st2 H0).
      destruct H as [HE [HN [HB HC]]].
      apply HB; simpl; tauto.
    - specialize (H st1 st2 H0).
      destruct H as [HE [HN [HB HC]]].
      apply HC; simpl; tauto.
  + unfold partial_valid; subst Q'; unfold WP, Assertion_denote.
    intros.
    destruct H0 as [HE ?].
    specialize (H0 st2); tauto.
Qed.

Theorem if_seq_sound_bigstep : forall P b c1 c2 c3 Q R1 R2,
  partial_valid P (CIf b (CSeq c1 c3) (CSeq c2 c3)) Q R1 R2 ->
  partial_valid P (CSeq (CIf b c1 c2) c3) Q R1 R2.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  specialize (H st1 st2 H0).
  destruct H as [HE [HN [HB HC]]].
  split; [| split;[| split]].
  + unfold not in *; intros; apply HE.
    simpl in H; simpl.
    destruct H; try tauto.
    destruct H as [st3 [? ?]].
    right; destruct H; [left | right]; split; try tauto;
      right; exists st3; try tauto.
  + intros; apply HN.
    simpl in H; simpl.
    destruct H as [st3 [[? | ?] ?]]; [left | right];
      split; try tauto; exists st3; tauto.
  + intros; apply HB.
    simpl in H; simpl.
    destruct H; try tauto.
    destruct H as [st3 [[? | ?] ?]]; [left | right];
      split; try tauto; right; exists st3; tauto.
  + intros; apply HC.
    simpl in H; simpl.
    destruct H; try tauto.
    destruct H as [st3 [[? | ?] ?]]; [left | right];
      split; try tauto; right; exists st3; tauto.
Qed.

Fixpoint nocontinue (c : com) : Prop :=
  match c with
  | CSkip         => True
  | CAss _ _      => True
  | CSeq c1 c2    => (nocontinue c1) /\ (nocontinue c2)
  | CIf b c1 c2   => (nocontinue c1) /\ (nocontinue c2)
  | CFor c1 c2    => True
  | CBreak        => True
  | CCont         => False
  end.

Lemma nocontinue_nocontexit : forall (c : com) st1,
  nocontinue c ->
  ~(exists st2, com_cont (ceval c) st1 st2).
Proof.
  intros; revert st1.
  induction c; unfold not; intros; destruct H0 as [st2 ?].
  + inversion H0.
  + inversion H0.
  + simpl in H; destruct H as [Hc1 Hc2].
    unfold not in *.
    simpl in H0; destruct H0.
    - specialize (IHc1 Hc1 st1).
      apply IHc1; exists st2; tauto.
    - destruct H as [st3 ?].
      specialize (IHc2 Hc2 st3).
      apply IHc2; exists st2; tauto.
  + simpl in H0; simpl in H; destruct H as [Hc1 Hc2]; destruct H0.
    - specialize (IHc1 Hc1 st1).
      unfold not in IHc1; apply IHc1.
      exists st2; tauto.
    - specialize (IHc2 Hc2 st1).
      unfold not in IHc2; apply IHc2.
      exists st2; tauto.
  + simpl in H0; tauto.
  + simpl in H0; tauto.
  + simpl in H; tauto.
Qed.

Theorem nocontinue_sound_bigstep : forall P c Q R1 R2 R2',
  nocontinue c ->
  partial_valid P c Q R1 R2 ->
  partial_valid P c Q R1 R2'.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  specialize (H0 st1 st2 H1).
  split; [tauto | split; [tauto | split; try tauto]].
  clear H0; intros.
  pose proof (nocontinue_nocontexit c st1 H).
  exfalso; unfold not in H2; apply H2.
  exists st2; tauto.
Qed.

Lemma loop_nocontinue_error : forall c1 c2 st1,
  com_error (ceval (CFor c1 c2)) st1 ->
  com_error (ceval (CFor (CSeq c1 c2) CSkip)) st1.
Proof.
  intros.
  simpl in *.
  destruct H as [n ?]; exists n.
  revert st1 H; induction n; intros.
  + simpl in *.
    destruct H; try tauto.
  + simpl in *.
    destruct H as [st2 [? ?]].
    exists st2; split.
    2:{ pose proof (IHn st2 H0); tauto. }
    destruct H.
    - destruct H as [st3 [? ?]].
      left. exists st2; split; try tauto.
      exists st3; tauto.
    - destruct H as [? | [st3 [? ?]]]; try tauto.
      right. left. right. exists st3; tauto.
Qed.

Lemma loop_nocontinue_normal : forall c1 c2 st1 st2,
  com_normal (ceval (CFor c1 c2)) st1 st2 ->
  com_normal (ceval (CFor (CSeq c1 c2) CSkip)) st1 st2.
Proof.
  intros.
  simpl in *.
  destruct H as [n ?]; exists n.
  revert st1 st2 H; induction n; intros.
  + simpl in *.
    destruct H; try tauto.
  + simpl in *.
    destruct H as [st3 [? ?]].
    exists st3; split.
    2:{ pose proof (IHn st3 st2 H0); tauto. }
    destruct H.
    - destruct H as [st4 ?].
      left. exists st3; split; try tauto; exists st4; tauto.
    - destruct H as [? | [st4 ?]]; try tauto.
      right. left. right. exists st4; tauto.
Qed.

Theorem loop_nocontinue_sound_bigstep : forall P c1 c2 Q R1 R2,
  nocontinue c1 ->
  nocontinue c2 ->
  partial_valid P (CFor (CSeq c1 c2) CSkip) Q R1 R2 ->
  partial_valid P (CFor c1 c2) Q R1 R2.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  specialize (H1 st1 st2 H2).
  destruct H1 as [HE [HN [HB HC]]].
  split; try split; try split.
  + unfold not in *; intros; apply HE.
    pose proof (loop_nocontinue_error c1 c2 st1); tauto.
  + intros; apply HN.
    pose proof (loop_nocontinue_normal c1 c2 st1 st2); tauto.
  + intros.
    simpl in H1. tauto.
  + intros.
    simpl in H1. tauto.
Qed.

End rules_sound.

Module basic_rules.
Import Denote_Aexp.
Import Denote_Bexp.
Import Denote_Com.
Import Denote_Embeddings.
Import Assertion_Shallow.

Theorem hoare_seq_sound : forall P Q R R1 R2 c1 c2,
  partial_valid P c1 Q R1 R2 ->
  partial_valid Q c2 R R1 R2 ->
  partial_valid P (CSeq c1 c2) R R1 R2.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  split; try split; try split.
  + unfold not; intros.
    simpl in H2.
    destruct H2.
    - specialize (H st1 st2 H1); tauto.
    - destruct H2 as  [st3 [? ?]].
      specialize (H st1 st3 H1).
      assert (Assertion_denote st3 Q). { tauto. }
      specialize (H0 st3 st2 H4); tauto.
  + intros.
    simpl in H2.
    destruct H2 as [st3 [? ?]].
    specialize (H st1 st3 H1).
    assert (Assertion_denote st3 Q). { tauto. }
    specialize (H0 st3 st2 H4). tauto.
  + intros.
    simpl in H2.
    destruct H2.
    - specialize (H st1 st2 H1); tauto.
    - destruct H2 as [st3 [? ?]].
      specialize (H st1 st3 H1).
      assert (Assertion_denote st3 Q). { tauto. }
      specialize (H0 st3 st2 H4). tauto.
  + intros.
    simpl in H2.
    destruct H2.
    - specialize (H st1 st2 H1); tauto.
    - destruct H2 as [st3 [? ?]].
      specialize (H st1 st3 H1).
      assert (Assertion_denote st3 Q). { tauto. }
      specialize (H0 st3 st2 H4). tauto.
Qed.

Theorem hoare_skip_sound : forall P,
  partial_valid P CSkip P falsep falsep.
Proof.
  intros.
  unfold partial_valid.
  intros.
  split; try split; try split.
  + unfold not; intros. inversion H0.
  + intros. simpl in H0; subst; tauto.
  + intros. inversion H0.
  + intros. inversion H0.
Qed.

Lemma true_notfalse : forall b st,
  true_set (beval b) st ->
  false_set (beval b) st -> False.
Proof.
  induction b; intros.
  + inversion H0.
  + inversion H.
  + simpl in *.
    destruct (aeval a1 st), (aeval a2 st); tauto.
  + simpl in *.
    destruct (aeval a1 st), (aeval a2 st); tauto.
  + simpl in *. apply (IHb st); tauto.
  + simpl in *.
    unfold Sets.intersect, Sets.union in *.
    specialize (IHb1 st); specialize (IHb2 st); tauto.
Qed.

Theorem hoare_if_sound : forall P Q R1 R2 b c1 c2,
  partial_valid (andp P (inj b)) c1 Q R1 R2 ->
  partial_valid (andp P (negp (inj b))) c2 Q R1 R2 ->
  partial_valid (andp P (safeb b)) (CIf b c1 c2) Q R1 R2.
Proof.
  unfold partial_valid in *.
  intros.
  unfold safeb, andp, inj, negp, Assertion_denote in *.
  split; try split; try split.
  + simpl. unfold not; intros.
    destruct H2 as [? | [? | ?]].
    - tauto.
    - specialize (H st1 st2); tauto.
    - specialize (H0 st1 st2).
      destruct H2.
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
  + simpl; intros.
    destruct H2.
    - specialize (H st1 st2). tauto.
    - specialize (H0 st1 st2).
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
  + simpl; intros.
    destruct H2.
    - specialize (H st1 st2). tauto.
    - specialize (H0 st1 st2).
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
    + simpl; intros.
    destruct H2.
    - specialize (H st1 st2). tauto.
    - specialize (H0 st1 st2).
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
Qed.

Theorem hoare_break_sound : forall P,
  partial_valid P CBreak falsep P falsep.
Proof.
  unfold partial_valid.
  intros.
  split; try split; try split.
  + unfold not; intros. inversion H0.
  + intros. inversion H0.
  + intros. inversion H0. subst. tauto.
  + intros. inversion H0.
Qed.

Theorem hoare_cont_sound : forall P,
  partial_valid P CCont falsep falsep P.
Proof.
  unfold partial_valid.
  intros.
  split; try split; try split.
  + unfold not; intros. inversion H0.
  + intros. inversion H0.
  + intros. inversion H0.
  + intros. inversion H0. subst. tauto.
Qed.

Theorem hoare_consequence_sound : forall P P' Q Q' R1 R1' R2 R2' c,
  derives P P' ->
  partial_valid P' c Q' R1' R2' ->
  derives Q' Q ->
  derives R1' R1 ->
  derives R2' R2 ->
  partial_valid P c Q R1 R2.
Proof.
  unfold derives, partial_valid, Assertion_denote in *.
  intros.
  specialize (H st1).
  specialize (H0 st1 st2).
  specialize (H1 st2).
  specialize (H2 st2).
  specialize (H3 st2).
  split; try split; try split; tauto.
Qed.

Theorem hoare_for_sound : forall I P c1 c2,
  partial_valid I (CSeq c1 c2) I P I ->
  partial_valid I (CFor c1 c2) (orp I P) falsep falsep.
Proof.
  unfold partial_valid, orp, falsep, Assertion_denote.
  intros.
  split; try split; try split; try tauto.
  + unfold not; intros.
    simpl in H1.
    destruct H1 as [n ?].
    revert st1 H1 H0; induction n; intros.
    - simpl in H1.
      specialize (H st1 st2 H0); destruct H.
      simpl in H. tauto.
    - simpl in H1.
      destruct H1 as [st3 [? ?]].
      specialize (IHn st3); apply IHn; try tauto.
      clear IHn H2.
      destruct H1 as [? | [? | ?]].
      * destruct H1 as [st4 [? ?]].
        specialize (H st1 st3 H0).
        assert (com_normal (ceval (CSeq c1 c2)) st1 st3).
        { simpl. exists st4; tauto. }
        tauto.
      * specialize (H st1 st3 H0).
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. tauto. }
        tauto.
      * specialize (H st1 st3 H0).
        destruct H1 as [st4 [? ?]].
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. right. exists st4; tauto. }
        tauto.
  + intros.
    simpl in H1.
    destruct H1 as [n ?].
    revert st1 st2 H0 H1; induction n; intros.
    - simpl in H1.
      destruct H1.
      * specialize (H st1 st2).
        assert (com_break (ceval (CSeq c1 c2)) st1 st2).
        { simpl. tauto. }
        tauto.
      * specialize (H st1 st2).
        assert (com_break (ceval (CSeq c1 c2)) st1 st2).
        { simpl. tauto. }
        tauto.
    - simpl in H1.
      destruct H1 as [st3 [? ?]].
      specialize (IHn st3 st2); apply IHn; try tauto.
      clear IHn H2.
      destruct H1 as [? | [? | ?]].
      * specialize (H st1 st3); tauto.
      * specialize (H st1 st3).
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. tauto. }
        tauto.
      * specialize (H st1 st3).
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. tauto. }
        tauto.
Qed.

Theorem hoare_asgn_sound : forall P (X : var) (E : aexp),
  partial_valid (andp (safea E) (subst_assertion P X (aeval E))) (CAss X E) P falsep falsep.
Proof.
  unfold partial_valid.
  intros.
  unfold Assertion_denote, andp, safea, subst_assertion in *.
  split; try split; try split.
  + unfold not; intros.
    simpl in *; tauto.
  + intros; simpl in *.
    destruct H, H0.
    remember (state_update st1 X (aeval E st1)) as st2'.
    assert (forall X, st2 X = st2' X).
    { intros.
      subst st2'.
      destruct (aeval E st1); try tauto.
      unfold state_update.
      destruct (Nat.eq_dec X X0).
      - subst. inversion H0. tauto.
      - specialize (H2 X0); auto. }
    assert (st2 = state_update st1 X (aeval E st1)).
    { eapply FunctionalExtensionality.functional_extensionality_dep.
      subst. tauto. }
    subst; tauto.
  + intros; simpl in *; tauto.
  + intros; simpl in *; tauto.
Qed.

End basic_rules.


Definition tautology : forall P : Prop, P -> P
  := fun P p => p.

Definition Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P
  := fun P Q H p => let (nQ, p_q) := H in nQ (p_q p).

Definition Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q
  := fun P Q p_or_q n_p =>
  match p_or_q with
  | or_introl p => False_ind Q (n_p p)
  | or_intror q => q
  end.

Definition tautology_on_Set : forall A : Set, A -> A
  := fun A p => p.

Definition Modus_tollens_on_Set : forall A B : Set, (B -> Empty_set) * (A -> B) -> (A -> Empty_set)
  := fun A B H a => let (b_emp, a_b) := H in b_emp (a_b a).

Definition Disjunctive_syllogism_on_Set : forall A B : Set, (A + B) -> (A -> Empty_set) -> B
  := fun A B in_a_b a_emp =>
  match in_a_b with
  | inl a => Empty_set_rec (fun _ : Empty_set => B) (a_emp a)
  | inr b => b
  end.


(***********************************************************)
(*      This file contains the abstract term structure for *)
(*      the Fourier-Motzkin procedure                      *)
(***********************************************************)

Require Import ZArith.

Open Scope Z_scope.

Structure Fmodule: Type := {
   T: Type;
   injT: Z -> T;         (* injection of Z *)
   scalT: Z -> T -> T;   (* scalar multiplication *)
   opT: T -> T;          (* opposite *)
   plusT: T -> T -> T;   (* addition *)
   minusT: T -> T -> T;  (* subtraction *)
   leT: T -> T -> Prop;  (* comparison *)
   ltT: T -> T -> Prop   (* strict comparison *)
}.

Section Init.

Variable FT : Fmodule.

(* Unusal notation *)
Declare Scope F_scope.
Notation "x + y" := (plusT FT x y) : F_scope.
Notation "x - y" := (minusT FT x y) : F_scope.
Notation "x * y" := (scalT FT x y) : F_scope.
Notation "x <= y" := (leT FT x y) : F_scope.
Notation "x < y" := (ltT FT x y) : F_scope.

Let injT1: Z -> (T FT) := (injT FT).
Coercion injT1 : Z >-> T.
Open Scope F_scope.

(* Sets of axioms of the T type (not minimal!) *)
Structure Faxiom: Prop := {
 (* Arithmetic part *)
 injT_plus: forall z1 z2 : Z, (z1 + z2)%Z = z1 + z2 :> T _;
 scalT_plus_l: forall z1 z2 t, (z1 + z2) * t = z1 * t + z2 * t;
 scalT_mul: forall z1 z2 t, z1 * z2 * t = z1 * (z2 * t);
 injT_0_r: forall t, t + 0%Z = t :> T _;
 plusT_C: forall t1 t2, t1 + t2 = t2 + t1;
 plusT_A: forall t1 t2 t3, t1 + t2 + t3 = t1 + (t2 + t3);
 plusT_0: forall t1, t1 + (-1) * t1 = 0%Z;
 scalT_1: forall t, 1%Z * t = t;
 opT_def: forall t, opT _ t = (-1) * t;
 minusT_def: forall t1 t2, t1 - t2 = t1 + (-1) * t2;
 (* Inequality part *)
 leT_refl: forall x, x <= x;
 leT_compat: forall x y z t, x <= y -> z <= t -> x + z <= y + t;
 ltT_01: 0 < 1;
 ltT_compat: forall x y z t, x < y -> z <= t -> x + z < y + t;
 ltT_W: forall x y, x < y -> x <= y;
 leT_neg: forall x, (x < 0)%Z -> ~ 0 <= x;
 ltT_neg: forall x, (x <= 0)%Z -> ~ 0 < x
}.
Variable FA : Faxiom.

Let injT_plus := (injT_plus FA).
Let scalT_plus_l := (scalT_plus_l FA).
Let scalT_mul := (scalT_mul FA).
Let injT_0_r := (injT_0_r FA).
Let plusT_C := (plusT_C FA).
Let plusT_A := (plusT_A FA).
Let plusT_0 := (plusT_0 FA).
Let scalT_1 := (scalT_1 FA).
Let opT_def := (opT_def FA).
Let minusT_def := (minusT_def FA).
Let leT_refl := (leT_refl FA).
Let leT_compat := (leT_compat FA).
Let ltT_01 := (ltT_01 FA).
Let ltT_compat := (ltT_compat FA).
Let ltT_W := (ltT_W FA).
Let leT_neg := (leT_neg FA).

(************************************************************)
(*       Derived facts about the arithmetic fragment        *)
(************************************************************)

Lemma injT_0_l: forall t, 0%Z + t = t.
Proof.
intros t; rewrite plusT_C; auto; apply injT_0_r; auto.
Qed.

Lemma plusT_cancel: forall t t1 t2: T _, t + t1 = t + t2 -> t1 = t2.
intros t t1 t2 H.
Proof.
rewrite <- (injT_0_r t1); rewrite <- (plusT_0 t);
  rewrite <- plusT_A; rewrite (plusT_C t1);
  rewrite H; rewrite (plusT_C t); rewrite plusT_A;
  rewrite plusT_0; rewrite injT_0_r; trivial.
Qed.

Lemma scalT_0: forall t, 0%Z * t = 0%Z.
Proof.
intros t; rewrite <- (plusT_0 t).
pattern t at 2; rewrite <- (scalT_1 t).
rewrite <- scalT_plus_l; auto.
Qed.

Lemma scalT_m1: forall t, (-1) * ((-1) * t) = t.
Proof.
intros t; rewrite <- scalT_mul; rewrite scalT_1; auto.
Qed.

Lemma scalT_inj0: forall z, z * 0%Z = 0%Z.
Proof.
assert (Hp: forall p, (Zpos p) * 0 = 0).
intros p; induction p as [p Hrec | p Hrec |].
rewrite Zpos_xI; rewrite Zmult_comm;
  rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; rewrite Hrec.
rewrite injT_0_r; rewrite plusT_C; rewrite injT_0_r.
rewrite scalT_1; auto.
rewrite Zpos_xO; rewrite Zmult_comm;
  rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; rewrite Hrec.
rewrite injT_0_r; auto.
rewrite scalT_1; auto.
intros z; destruct z as [| p | p]; auto.
apply scalT_0; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
rewrite scalT_mul; rewrite Hp.
apply plusT_cancel with (0:T _).
rewrite plusT_0; rewrite injT_0_r; auto.
Qed.

Lemma scalT_plus_r: forall z t1 t2, z * (t1 + t2)= z * t1 + z * t2.
Proof.
assert (Hp0: forall t1 t2, (-1) * (t1 + t2)= (-1) * t1 + (-1) * t2).
intros p1 p2.
apply plusT_cancel with (p1 + p2).
rewrite plusT_0.
rewrite (plusT_C p1); rewrite plusT_A; rewrite (plusT_C p2).
repeat rewrite <- plusT_A; rewrite plusT_0; rewrite injT_0_l.
rewrite plusT_C; rewrite plusT_0; auto.
assert (Hp: forall p t1 t2,
 (Zpos p) * (t1 + t2)= (Zpos p) * t1 + (Zpos p) * t2).
intros p; induction p as [p Hrec | p Hrec|]; intros t1 t2.
rewrite Zpos_xI; repeat rewrite scalT_plus_l.
repeat rewrite (Zmult_comm 2); rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; repeat rewrite scalT_1.
rewrite Hrec.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite Zpos_xO.
repeat rewrite (Zmult_comm 2); rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; repeat rewrite scalT_1.
rewrite Hrec.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
repeat rewrite scalT_1; auto.
intros z; destruct z as [|p | p]; intros t1 t2; auto.
  repeat rewrite scalT_0; rewrite injT_0_r; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
repeat rewrite scalT_mul; rewrite Hp; rewrite Hp0; auto.
Qed.

Lemma injT_mul: forall z1 z2, (z1 * z2)%Z = z1 * z2 :> T _.
Proof.
assert (Hp: forall p z2, (Zpos p * z2)%Z = (Zpos p) * z2 :> T _).
intros p; induction p as [p Hrec | p Hrec|]; intros z2.
rewrite Zpos_xI.
replace ((2 * Zpos p + 1) * z2)%Z with (Zpos p * (2 * z2) + z2)%Z;
  try ring.
rewrite scalT_plus_l; rewrite injT_plus; rewrite Hrec.
rewrite Zmult_comm; rewrite <- Zplus_diag_eq_mult_2.
rewrite injT_plus; rewrite scalT_plus_r.
rewrite (Zmult_comm 2);
  rewrite <- Zplus_diag_eq_mult_2.
rewrite scalT_plus_l; rewrite scalT_1; auto.
rewrite Zpos_xO; rewrite (Zmult_comm 2); rewrite <- Zmult_assoc.
rewrite Hrec; rewrite scalT_mul.
replace (2 * z2)%Z with (z2 + z2)%Z; try ring.
change 2%Z with (1 + 1)%Z.
rewrite scalT_plus_l; rewrite injT_plus; rewrite scalT_1; auto.
rewrite scalT_1; rewrite Zmult_1_l; auto.
intros z1 z2; destruct z1 as [| p | p]; auto.
rewrite scalT_0; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
rewrite <-Zmult_assoc. repeat rewrite scalT_mul; auto.
rewrite <- Hp.
apply plusT_cancel with (injT1 (Zpos p * z2)).
rewrite <- injT_plus; rewrite plusT_0.
apply f_equal with (f := injT1); ring.
Qed.

(*************************.***********************************)
(*       Derived facts about the comparison                 *)
(************************************************************)

Lemma ltT_cancel_l: forall x y z, x + y < x + z -> y < z.
Proof.
intros x y z H.
replace y with ((x + y) + (-1) * x).
replace z with ((x + z) + (-1) * x).
apply ltT_compat; auto.
rewrite (plusT_C x); rewrite plusT_A; rewrite plusT_0;
  rewrite injT_0_r; auto.
rewrite (plusT_C x); rewrite plusT_A; rewrite plusT_0;
  rewrite injT_0_r; auto.
Qed.

Lemma leT_cancel_l: forall x y z, x + y <= x + z -> y <= z.
Proof.
intros x y z H.
replace y with ((-1) * x + (x + y)).
replace z with ((-1) * x + (x + z)).
apply leT_compat; auto.
rewrite <- plusT_A; rewrite (fun z => plusT_C z x); rewrite plusT_0;
  rewrite injT_0_l; auto.
rewrite <- plusT_A; rewrite (fun z => plusT_C z x); rewrite plusT_0;
  rewrite injT_0_l; auto.
Qed.

Lemma leT_trans: forall x y z, x <= y -> y <= z -> x <= z.
Proof.
intros x y z H1 H2.
apply leT_cancel_l with y.
rewrite (plusT_C y).
apply leT_compat; auto.
Qed.

Lemma leT_opp: forall x y, x <= y -> (-1) * y <= (-1) * x.
Proof.
intros x y H.
apply leT_cancel_l with x.
rewrite plusT_0.
apply leT_cancel_l with y.
rewrite injT_0_r.
rewrite (plusT_C x); rewrite <- plusT_A; rewrite plusT_0;
  rewrite injT_0_l; auto.
Qed.

Lemma plusTss_pos: forall x y, 0 < x -> 0 < y -> 0 < x + y.
Proof.
intros x y Hx Hy.
rewrite <- (injT_0_r 0).
apply ltT_compat; auto; apply ltT_W; auto.
Qed.

Lemma plusT1s_pos: forall x y, 0 <= x -> 0 < y -> 0 < x + y.
Proof.
intros x y Hx Hy.
rewrite plusT_C; rewrite <- (injT_0_r 0).
apply ltT_compat; auto.
Qed.

Lemma plusTs1_pos: forall x y, 0 < x -> 0 <= y -> 0 < x + y.
Proof.
intros x y Hx Hy.
rewrite <- (injT_0_r 0).
apply ltT_compat; auto.
Qed.

Lemma plusT_pos: forall x y, 0 <= x -> 0 <= y -> 0 <= x + y.
Proof.
intros x y Hx Hy.
rewrite <- (injT_0_r 0).
apply leT_compat; auto.
Qed.

Lemma eqT_pos: forall x y, (0:T _) = x -> (0:T _) = y -> (0:T _) = x + y.
Proof.
intros x y Hx Hy; rewrite <- Hx; rewrite <- Hy; rewrite injT_0_r; auto.
Qed.

Lemma injT_pos: forall x, (0 <= x)%Z -> 0 <= x.
Proof.
apply natlike_ind.
apply leT_refl.
intros x Hx H1x.
unfold Z.succ; rewrite injT_plus.
apply plusT_pos; auto.
Qed.

Lemma injT_spos: forall x, (0 < x)%Z -> 0 < x.
Proof.
intros x; destruct x as [|p|p]; intros HH;
  try (discriminate HH).
change 0 with (0+0)%Z.
replace (Zpos p) with (1 + (Zpos p - 1))%Z.
repeat rewrite injT_plus.
apply ltT_compat.
apply ltT_01.
apply injT_pos; case p; intros; intros HH1; discriminate HH1.
ring.
Qed.

Lemma scalT_pos: forall x y, (0 <= x)%Z -> 0 <= y -> 0 <= x * y.
Proof.
intros x y Hx Hy.
generalize x Hx; apply natlike_ind; auto; clear x Hx.
rewrite scalT_0; apply leT_refl.
intros x Hx Hp.
unfold Z.succ; rewrite scalT_plus_l.
apply plusT_pos; auto; rewrite scalT_1; auto.
Qed.

Lemma scalT_spos: forall x y, (0 < x)%Z -> 0 < y -> 0 < x * y.
Proof.
intros x y Hx Hy.
destruct x as [|p|p]; try discriminate Hx.
change 0 with (0+0)%Z.
replace (Zpos p) with (1 + (Zpos p - 1))%Z.
repeat rewrite injT_plus.
rewrite scalT_plus_l; rewrite scalT_1.
apply ltT_compat; auto.
apply scalT_pos; auto.
case p; intros; intros HH1; discriminate HH1.
ring.
Qed.

Lemma scalT_eq: forall x y, 0 = y -> (0:T _) = x * y.
Proof.
intros x y Hy; rewrite <- Hy; rewrite scalT_inj0; auto.
Qed.

End Init.

(* Unusal notation *)
Declare Scope F_scope.
Notation "x + y" := (plusT _ x y) : F_scope.
Notation "x - y" := (minusT _ x y) : F_scope.
Notation "x * y" := (scalT _ x y) : F_scope.
Notation "x <= y" := (leT _ x y) : F_scope.
Notation "x < y" := (ltT _ x y) : F_scope.