(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Import QArith_base.
Require Import tactics2.
Require Import list_util.
Require Import Eqdep_dec.

Require Import Node.
Require Import Msg.
Require Import Crypto.
Require Import EventOrdering.
Require Import Process.
Require Import PairState.

Section Parallel.

Context { pn     : @Node }.
Context { pm     : @Msg }.
Context { pk     : @Key }.

(* transition form SX to sx *)
Definition parallel_upd {SX SY I O : Type}
           (X : Update SX I (list O))
           (Y : Update SY I (list O)) : Update (pstate SX SY) I (list O) :=
  fun state i =>
    match state with
    | pstate_two sx sy =>
      let (sx', outx) := X sx i in
      let (sy', outy) := Y sy i in
      (opt_states2pstate sx' sy', outx ++ outy)
    | pstate_left sx =>
      let (sx', outx) := X sx i in
      (option_map (fun x => pstate_left x) sx', outx)
    | pstate_right sy =>
      let (sy', outy) := Y sy i in
      (option_map (fun x => pstate_right x) sy', outy)
    end.

Definition parallel {SX SY I O : Type}
           (X : StateMachine SX I (list O))
           (Y : StateMachine SY I (list O))
  : StateMachine (pstate SX SY) I (list O) :=
  mkSM (parallel_upd (sm_update X) (sm_update Y))
       (pstate_two (sm_state X) (sm_state Y)).

Definition nparallel {SX SY I O : Type}
           (X : NStateMachine SX I (list O))
           (Y : NStateMachine SY I (list O))
  : NStateMachine (pstate SX SY) I (list O) :=
  fun slf => parallel (X slf) (Y slf).

Notation "a [||] b" := (nparallel a b) (at level 100).

Lemma state_sm_on_event_parallel_some_pstate_two_implies :
  forall {SX SY O}
         (X  : StateMachine SX msg (list O))
         (Y  : StateMachine SY msg (list O))
         (eo : EventOrdering)
         (e  : Event)
         (l  : SX)
         (r  : SY),
    state_sm_on_event (parallel X Y) e = Some (pstate_two l r)
    -> state_sm_on_event X e = Some l
       /\ state_sm_on_event Y e = Some r.
Proof.
  intros SX SY O X Y eo.
  induction e as [e ind] using predHappenedBeforeInd; introv h.
  rewrite state_sm_on_event_unroll in h.
  destruct (dec_isFirst e) as [d1|d1]; simpl in *.

  - dest_cases w; symmetry in Heqw; simpl in *.
    dest_cases y; symmetry in Heqy; simpl in *.
    destruct w0; simpl in *; ginv.

    + destruct y0; simpl in *; ginv.

      rewrite (state_sm_on_event_unroll X).
      rewrite (state_sm_on_event_unroll Y).
      destruct (dec_isFirst e); tcsp; GC.
      allrw; simpl; tcsp.

    + destruct y0; simpl in *; ginv.

  - remember (state_sm_on_event (parallel X Y) (local_pred e)) as sop; symmetry in Heqsop.
    destruct sop; simpl in *; ginv.
    destruct p; simpl in *; ginv.

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      dest_cases y; symmetry in Heqy; simpl in *; ginv.
      destruct w0; simpl in *; ginv.

      * destruct y0; simpl in *; ginv.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp; GC.
        apply ind in Heqsop; auto;[|apply local_pred_is_direct_pred; auto].
        repnd; repeat (allrw; simpl; tcsp).

      * destruct y0; simpl in *; ginv.

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      destruct w0; simpl in *; ginv.

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      destruct w0; simpl in *; ginv.
Qed.

Lemma state_sm_on_event_parallel_some_pstate_left_implies :
  forall {SX SY O}
         (X  : StateMachine SX msg (list O))
         (Y  : StateMachine SY msg (list O))
         (eo : EventOrdering)
         (e  : Event)
         (l  : SX),
    state_sm_on_event (parallel X Y) e = Some (pstate_left l)
    -> state_sm_on_event X e = Some l
       /\ state_sm_on_event Y e = None.
Proof.
  intros SX SY O X Y eo.
  induction e as [e ind] using predHappenedBeforeInd; introv h.
  rewrite state_sm_on_event_unroll in h.
  destruct (dec_isFirst e) as [d1|d1]; simpl in *.

  - dest_cases w; symmetry in Heqw; simpl in *.
    dest_cases y; symmetry in Heqy; simpl in *.
    destruct w0; simpl in *; ginv.

    + destruct y0; simpl in *; ginv.

      rewrite (state_sm_on_event_unroll X).
      rewrite (state_sm_on_event_unroll Y).
      destruct (dec_isFirst e); tcsp; GC.
      allrw; simpl; tcsp.

    + destruct y0; simpl in *; ginv.

  - remember (state_sm_on_event (parallel X Y) (local_pred e)) as sop; symmetry in Heqsop.
    destruct sop; simpl in *; ginv.
    destruct p; simpl in *; ginv.

    + apply state_sm_on_event_parallel_some_pstate_two_implies in Heqsop.
      exrepnd.
      dest_cases w; symmetry in Heqw; simpl in *; ginv.
      dest_cases y; symmetry in Heqy; simpl in *; ginv.
      destruct w0; simpl in *; ginv.

      * destruct y0; simpl in *; ginv.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp; GC.
        repnd; repeat (allrw; simpl; tcsp).

      * destruct y0; simpl in *; ginv.

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      destruct w0; simpl in *; ginv.

      * apply ind in Heqsop; auto;[|apply local_pred_is_direct_pred; auto].
        repnd.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp.
        repeat(allrw; simpl in *; tcsp).

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      destruct w0; simpl in *; ginv.
Qed.

Lemma state_sm_on_event_parallel_some_pstate_right_implies :
  forall {SX SY O}
         (X  : StateMachine SX msg (list O))
         (Y  : StateMachine SY msg (list O))
         (eo : EventOrdering)
         (e  : Event)
         (r  : SY),
    state_sm_on_event (parallel X Y) e = Some (pstate_right r)
    -> state_sm_on_event X e = None
       /\ state_sm_on_event Y e = Some r.
Proof.
  intros SX SY O X Y eo.
  induction e as [e ind] using predHappenedBeforeInd; introv h.
  rewrite state_sm_on_event_unroll in h.
  destruct (dec_isFirst e) as [d1|d1]; simpl in *.

  - dest_cases w; symmetry in Heqw; simpl in *.
    dest_cases y; symmetry in Heqy; simpl in *.
    destruct y0; simpl in *; ginv.

    + destruct w0; simpl in *; ginv.
      rewrite (state_sm_on_event_unroll X).
      rewrite (state_sm_on_event_unroll Y).
      destruct (dec_isFirst e); tcsp; GC.
      allrw; simpl; tcsp.

    + destruct w0; simpl in *; ginv.

  - remember (state_sm_on_event (parallel X Y) (local_pred e)) as sop; symmetry in Heqsop.
    destruct sop; simpl in *; ginv.
    destruct p; simpl in *; ginv.

    + apply state_sm_on_event_parallel_some_pstate_two_implies in Heqsop.
      exrepnd.
      dest_cases w; symmetry in Heqw; simpl in *; ginv.
      dest_cases y; symmetry in Heqy; simpl in *; ginv.
      destruct y0; simpl in *; ginv.

      * destruct w0; simpl in *; ginv.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp; GC.
        repnd; repeat (allrw; simpl; tcsp).

      * destruct w0; simpl in *; ginv.

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      destruct w0; simpl in *; ginv.

    + dest_cases w; symmetry in Heqw; simpl in *; ginv.
      destruct w0; simpl in *; ginv.

      * apply ind in Heqsop ; auto;[|apply local_pred_is_direct_pred; auto]; repnd.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp.
        repeat(allrw; simpl in *; tcsp).
Qed.

Lemma state_sm_on_event_parallel_none_implies :
  forall {SX SY O}
         (X  : StateMachine SX msg (list O))
         (Y  : StateMachine SY msg (list O))
         (eo : EventOrdering)
         (e  : Event),
    state_sm_on_event (parallel X Y) e = None
    -> state_sm_on_event X e = None
       /\ state_sm_on_event Y e = None.
Proof.
  intros SX SY O X Y eo.
  induction e as [e ind] using predHappenedBeforeInd; introv h.
  rewrite state_sm_on_event_unroll in h.
  destruct (dec_isFirst e) as [d1|d1]; simpl in *.

  - dest_cases w; symmetry in Heqw; simpl in *.
    dest_cases y; symmetry in Heqy; simpl in *.
    destruct y0; simpl in *; ginv.

    + destruct w0; simpl in *; ginv.

    + destruct w0; simpl in *; ginv.
      rewrite (state_sm_on_event_unroll X).
      rewrite (state_sm_on_event_unroll Y).
      destruct (dec_isFirst e); tcsp; GC.
      allrw; simpl; tcsp.

  - remember (state_sm_on_event (parallel X Y) (local_pred e)) as sop; symmetry in Heqsop.
    destruct sop; simpl in *; ginv.

    {
      destruct p; simpl in *; ginv.

      - apply state_sm_on_event_parallel_some_pstate_two_implies in Heqsop; repnd.

        dest_cases w; symmetry in Heqw; simpl in *; ginv.
        dest_cases y; symmetry in Heqy; simpl in *; ginv.
        destruct y0; simpl in *; ginv.

        + destruct w0; simpl in *; ginv.

        + destruct w0; simpl in *; ginv.
          rewrite (state_sm_on_event_unroll X).
          rewrite (state_sm_on_event_unroll Y).
          destruct (dec_isFirst e); tcsp; GC.
          repnd; repeat (allrw; simpl; tcsp).

      - dest_cases w; symmetry in Heqw; simpl in *; ginv.
        destruct w0; simpl in *; ginv.
        apply state_sm_on_event_parallel_some_pstate_left_implies in Heqsop; repnd.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp; GC.
        repeat (allrw; simpl; dands; auto).

      - dest_cases w; symmetry in Heqw; simpl in *; ginv.
        destruct w0; simpl in *; ginv.
        apply state_sm_on_event_parallel_some_pstate_right_implies in Heqsop; repnd.
        rewrite (state_sm_on_event_unroll X).
        rewrite (state_sm_on_event_unroll Y).
        destruct (dec_isFirst e); tcsp; GC.
        repeat (allrw; simpl; dands; auto).
    }

    {
      apply ind in Heqsop;[|apply local_pred_is_direct_pred; auto]; repnd.
      rewrite (state_sm_on_event_unroll X).
      rewrite (state_sm_on_event_unroll Y).
      destruct (dec_isFirst e); tcsp.
      repeat(allrw; simpl in *; tcsp).
    }
Qed.

Lemma parallel_output_iff :
  forall {SX SY O}
         (X  : StateMachine SX msg (list O))
         (Y  : StateMachine SY msg (list O))
         (eo : EventOrdering)
         (e  : Event)
         (x  : O),
    In x (loutput_sm_on_event (parallel X Y) e)
    <->
    (
      In x (loutput_sm_on_event X e)
      \/
      In x (loutput_sm_on_event Y e)
    ).
Proof.
  introv; split; intro h.

  {
    rewrite loutput_sm_on_event_unroll in h.
    destruct (dec_isFirst e) as [d|d]; simpl in *.

    {
      dest_cases w; symmetry in Heqw; simpl in *.
      dest_cases y; symmetry in Heqy; simpl in *.
      rewrite in_app_iff in h.
      repndors;[left|right].

      - rewrite loutput_sm_on_event_unroll.
        destruct (dec_isFirst e); tcsp; GC.
        allrw; simpl; auto.

      - rewrite loutput_sm_on_event_unroll.
        destruct (dec_isFirst e); tcsp; GC.
        allrw; simpl; auto.
    }

    {
      remember (state_sm_on_event (parallel X Y) (local_pred e)) as sop; symmetry in Heqsop.
      destruct sop; simpl in *; ginv; tcsp.

      destruct p; simpl in *; tcsp.

      + dest_cases w; symmetry in Heqw; simpl in *.
        dest_cases y; symmetry in Heqy; simpl in *.
        apply in_app_iff in h; repndors;[left|right].

        * rewrite loutput_sm_on_event_unroll.
          destruct (dec_isFirst e); tcsp; GC.
          apply state_sm_on_event_parallel_some_pstate_two_implies in Heqsop; repnd.
          repeat (allrw; simpl; tcsp).

        * rewrite loutput_sm_on_event_unroll.
          destruct (dec_isFirst e); tcsp; GC.
          apply state_sm_on_event_parallel_some_pstate_two_implies in Heqsop; repnd.
          repeat (allrw; simpl; tcsp).

      + dest_cases w; symmetry in Heqw; simpl in *.
        apply state_sm_on_event_parallel_some_pstate_left_implies in Heqsop; repnd.
        left.
        rewrite loutput_sm_on_event_unroll.
        destruct (dec_isFirst e); tcsp; GC.
        repeat (allrw; simpl; tcsp).

      + dest_cases w; symmetry in Heqw; simpl in *.
        apply state_sm_on_event_parallel_some_pstate_right_implies in Heqsop; repnd.
        right.
        rewrite loutput_sm_on_event_unroll.
        destruct (dec_isFirst e); tcsp; GC.
        repeat (allrw; simpl; tcsp).
    }
  }

  {
    rewrite loutput_sm_on_event_unroll.
    destruct (dec_isFirst e) as [d|d]; simpl in *.

    - dest_cases w; symmetry in Heqw; simpl in *.
      dest_cases y; symmetry in Heqy; simpl in *.
      apply in_app_iff.
      repndors.

      + rewrite loutput_sm_on_event_unroll in h.
        destruct (dec_isFirst e); simpl in *; tcsp; GC.
        rewrite Heqw in h; simpl in h; tcsp.

      + rewrite loutput_sm_on_event_unroll in h.
        destruct (dec_isFirst e); simpl in *; tcsp; GC.
        rewrite Heqy in h; simpl in h; tcsp.

    - remember (state_sm_on_event (parallel X Y) (local_pred e)) as sop.
      symmetry in Heqsop; destruct sop; simpl in *; tcsp.

      + destruct p; simpl in *.

        * dest_cases w; symmetry in Heqw; simpl in *.
          dest_cases y; symmetry in Heqy; simpl in *.
          apply state_sm_on_event_parallel_some_pstate_two_implies in Heqsop; repnd.
          apply in_app_iff.
          repndors.

          { rewrite loutput_sm_on_event_unroll in h.
            destruct (dec_isFirst e); simpl in *; tcsp; GC.
            rewrite Heqsop0 in h; simpl in h.
            rewrite Heqw in h; simpl in h; tcsp. }

          { rewrite loutput_sm_on_event_unroll in h.
            destruct (dec_isFirst e); simpl in *; tcsp; GC.
            rewrite Heqsop in h; simpl in h; tcsp.
            rewrite Heqy in h; simpl in h; tcsp. }

        * dest_cases w; symmetry in Heqw; simpl in *.
          apply state_sm_on_event_parallel_some_pstate_left_implies in Heqsop; repnd.
          repndors.

          { rewrite loutput_sm_on_event_unroll in h.
            destruct (dec_isFirst e); simpl in *; tcsp; GC.
            rewrite Heqsop0 in h; simpl in h.
            rewrite Heqw in h; simpl in h; tcsp. }

          { rewrite loutput_sm_on_event_unroll in h.
            destruct (dec_isFirst e); simpl in *; tcsp; GC.
            rewrite Heqsop in h; simpl in h; tcsp. }

        * dest_cases w; symmetry in Heqw; simpl in *.
          apply state_sm_on_event_parallel_some_pstate_right_implies in Heqsop; repnd.
          repndors.

          { rewrite loutput_sm_on_event_unroll in h.
            destruct (dec_isFirst e); simpl in *; tcsp; GC.
            rewrite Heqsop0 in h; simpl in h; tcsp. }

          { rewrite loutput_sm_on_event_unroll in h.
            destruct (dec_isFirst e); simpl in *; tcsp; GC.
            rewrite Heqsop in h; simpl in h; tcsp.
            rewrite Heqw in h; simpl in *; auto. }

      + apply state_sm_on_event_parallel_none_implies in Heqsop; repnd.
        rewrite (loutput_sm_on_event_unroll X) in h.
        rewrite (loutput_sm_on_event_unroll Y) in h.
        destruct (dec_isFirst e); tcsp; GC.
        rewrite Heqsop, Heqsop0 in h; simpl in h; tcsp.
  }
Qed.

End Parallel.

Open Scope proc.
Notation "a [||] b" := (nparallel a b) (at level 100) : proc.
Close Scope proc.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config uGraph.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICOnOne
     PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICNormal PCUICSR
     PCUICGeneration PCUICReflect PCUICEquality PCUICInversion PCUICValidity
     PCUICWeakeningConv PCUICWeakeningTyp PCUICReduction PCUICConversion
     PCUICPosition PCUICCumulativity PCUICSafeLemmata PCUICSN
     PCUICPretty PCUICArities PCUICConfluence PCUICSize
     PCUICContextConversion PCUICConversion PCUICWfUniverses.

From MetaCoq.SafeChecker Require Import PCUICWfEnv.

From Equations Require Import Equations.
Require Import ssreflect ssrbool.

Local Set Keyed Unification.
Set Equations Transparent.

Lemma Acc_no_loop X (R : X -> X -> Prop) t : Acc R t -> R t t -> False.
Proof.
  induction 1. intros. eapply H0; eauto.
Qed.

(* Show that taking head normal forms and then the subterm relation is well-founded *)

Inductive term_direct_subterm : term -> term -> Type :=
| term_direct_subterm_4_1 : forall (na : aname) (A B : term),
  term_direct_subterm B (tProd na A B)
| term_direct_subterm_4_2 : forall (na : aname) (A B : term),
  term_direct_subterm A (tProd na A B)
| term_direct_subterm_5_1 : forall (na : aname) (A t : term),
  term_direct_subterm t (tLambda na A t)
| term_direct_subterm_5_2 : forall (na : aname) (A t : term),
  term_direct_subterm A (tLambda na A t)
| term_direct_subterm_6_1 : forall (na : aname) (b B t : term),
  term_direct_subterm t (tLetIn na b B t)
| term_direct_subterm_6_2 : forall (na : aname) (b B t : term),
  term_direct_subterm B (tLetIn na b B t)
| term_direct_subterm_6_3 : forall (na : aname) (b B t : term),
  term_direct_subterm b (tLetIn na b B t)
| term_direct_subterm_7_1 : forall u v : term,
  term_direct_subterm v (tApp u v)
| term_direct_subterm_7_2 : forall u v : term,
  term_direct_subterm u (tApp u v)
| term_direct_subterm_11_1 : forall (ci : case_info)
     (p : predicate term) (c : term) (brs : list (branch term)),
   term_direct_subterm c (tCase ci p c brs)
| term_direct_subterm_11_2 : forall (ci : case_info)
  (p : predicate term) (c : term) (brs : list (branch term)),
  term_direct_subterm p.(preturn) (tCase ci p c brs)
| term_direct_subterm_12_1 : forall (p : projection) (c : term),
  term_direct_subterm c (tProj p c).
Derive Signature for term_direct_subterm.

Definition term_direct_subterm_context (t u : term) (p : term_direct_subterm t u) : context :=
  match p with
  | term_direct_subterm_4_1 na A B => [vass na A]
  | term_direct_subterm_5_1 na A t => [vass na A]
  | term_direct_subterm_6_1 na b B t => [vdef na b B]
  | term_direct_subterm_11_2 ci p c brs => inst_case_predicate_context p
  | _ => []
  end.

Require Equations.Type.WellFounded.
Definition term_subterm := Relation.trans_clos term_direct_subterm.

Fixpoint term_subterm_context {t u : term} (p : term_subterm t u) : context :=
  match p with
  | Relation.t_step y xy => term_direct_subterm_context _ _ xy
  | Relation.t_trans y z rxy ryz =>
    term_subterm_context rxy ++ term_subterm_context ryz
  end.

Definition term_subterm_wf : Equations.Type.WellFounded.well_founded term_subterm.
Proof.
  eapply WellFounded.wf_trans_clos.
  red. fix IH 1. intro x; constructor.
  destruct x; intros y sub; depelim sub; apply IH.
Defined.

(** At least one step of reduction *)
Definition redp Σ Γ t u := Relation.trans_clos (red1 Σ Γ) t u.

#[global]
Instance redp_trans Σ Γ : CRelationClasses.Transitive (redp Σ Γ).
Proof. econstructor 2; eauto. Qed.

#[global]
Instance redp_red Σ Γ : CRelationClasses.subrelation (redp Σ Γ) (red Σ Γ).
Proof.
  intros x y.
  induction 1; solve [econstructor; eauto].
Qed.

#[global]
Instance cored_transitive Σ Γ : RelationClasses.Transitive (cored Σ Γ).
Proof.
  intros x y z.
  induction 1 in z |- *. econstructor 2; eauto.
  intros uz. specialize (IHcored _ uz).
  econstructor 2. eapply IHcored. assumption.
Qed.

Lemma cored_redp Σ Γ t u : cored Σ Γ u t <-> ∥ redp Σ Γ t u ∥.
Proof.
  split.
  * induction 1; sq; try solve [econstructor; eauto].
    transitivity v; auto. now constructor.
  * intros []. induction X.
    + now constructor.
    + now transitivity y.
Qed.

(** Well-founded relation allowing to define functions using weak-head reduction
on (welltyped) terms and going under binders. *)
Section fix_sigma.
  Context {cf : checker_flags} {no : normalizing_flags}.
  Context {Σ : global_env_ext} {normalization:NormalizationIn Σ} {HΣ : ∥wf_ext Σ∥}.

  Lemma term_subterm_red1 {Γ s s' t} {ts : term_subterm s t} :
    red1 Σ (Γ ,,, term_subterm_context ts) s s' ->
    exists t', ∥ red1 Σ Γ t t' × ∑ ts' : term_subterm s' t', term_subterm_context ts' = term_subterm_context ts ∥.
  Proof using Type.
    induction ts in Γ, s' |- *.
    - induction r; simpl.
    all:intros red; eexists; split;
    try solve [split; [solve [eauto using red1]|unshelve eexists;[repeat constructor|simpl; eauto]]].
    split.
    eapply letin_red_body; eauto. unshelve eexists. repeat constructor. reflexivity.
    split.
    eapply letin_red_ty; eauto. unshelve eexists. repeat constructor. reflexivity.
    split. eapply letin_red_def; eauto. unshelve eexists. repeat constructor. reflexivity.
    split. eapply case_red_return; eauto. unshelve eexists. repeat constructor.
    eapply (term_direct_subterm_11_2 ci (set_preturn p s')). simpl. reflexivity.
    - simpl. intros.
    rewrite app_context_assoc in X.
    specialize (IHts1 _ _ X) as [t' [[yt' [ts Hts]]]].
    specialize (IHts2 _ _ yt') as [t'' [[zt' [ts'' Hts'']]]].
    exists t''. split; split; auto.
    unshelve eexists. econstructor 2; eauto. simpl.
    now rewrite Hts Hts''.
  Qed.

  Lemma term_subterm_redp {Γ s s' t} {ts : term_subterm s t} :
    redp Σ (Γ ,,, term_subterm_context ts) s s' ->
    exists t', ∥ redp Σ Γ t t' × ∑ ts' : term_subterm s' t', term_subterm_context ts' = term_subterm_context ts ∥.
  Proof using Type.
    intros r.
    generalize_eqs r. intros ->. revert t ts.
    induction r.
    - intros t ts ->.
      destruct (term_subterm_red1 r) as [t' [[red1 [ts' Hts']]]].
      exists t'; split; auto. split; auto. now constructor. exists ts'; auto.
    - intros t ts ->. specialize (IHr1 t ts eq_refl) as [t' [[yt' [ts' Hts]]]].
      specialize (IHr2 t' ts').
      forward IHr2. now rewrite Hts.
      destruct IHr2 as [t'' [[zt' [ts'' Hts'']]]].
      exists t''. split; split; auto.
      now transitivity t'.
      exists ts''.
      now rewrite Hts'' Hts.
  Qed.

  Definition hnf_subterm_rel : Relation_Definitions.relation (∑ Γ t, welltyped Σ Γ t) :=
    fun '(Γ2; t2; H) '(Γ1; t1; H2) =>
    ∥∑ t', red (fst Σ) Γ1 t1 t' × ∑ ts : term_subterm t2 t', Γ2 = (Γ1 ,,, term_subterm_context ts) ∥.

  Ltac sq' := try (destruct HΣ; clear HΣ);
    repeat match goal with
    | H : ∥ _ ∥ |- _ => destruct H; try clear H
    end; try eapply sq.

  Definition wf_hnf_subterm_rel : WellFounded hnf_subterm_rel.
  Proof.
    intros (Γ & s & H). sq'.
    induction (normalization_in Γ s H) as [s _ IH].
    induction (term_subterm_wf s) as [s _ IH_sub] in Γ, H, IH |- *.
    econstructor.
    intros (Γ' & t2 & ?) [(t' & r & ts & eqctx)].
    eapply Relation_Properties.clos_rt_rtn1 in r. inversion r.
    + subst. eapply IH_sub; auto.
      intros.
      inversion H0.
      * subst.
        destruct (term_subterm_red1 X0) as [t'' [[redt' [tst' Htst']]]].
        eapply IH. econstructor. eauto. red.
        sq. exists t''. split; eauto. exists tst'. now rewrite Htst'.
        Unshelve.
        eapply red_welltyped; sq. 3:eapply red1_red; tea. all:eauto.
      * subst. eapply cored_redp in H2 as [].
        pose proof (term_subterm_redp X1) as [t'' [[redt' [tst' Htst']]]].
        rewrite -Htst' in X0.
        destruct (term_subterm_red1 X0) as [t''' [[redt'' [tst'' Htst'']]]].
        eapply IH.
        eapply cored_redp. sq. transitivity t''; eauto.
        constructor; eauto.
        split.
        exists t'''. split; auto. exists tst''.
        now rewrite Htst'' Htst'.
        Unshelve.
        eapply red_welltyped in H; eauto. all:sq; eauto.
        eapply redp_red in redt'.
        now transitivity t''.
      + subst. eapply IH.
      * eapply red_neq_cored.
        eapply Relation_Properties.clos_rtn1_rt. exact r.
        intros ?. subst.
        eapply Relation_Properties.clos_rtn1_rt in X1.
        eapply cored_red_trans in X0; [| exact X1 ].
        eapply Acc_no_loop in X0. eauto.
        eapply @normalization; eauto.
      * split. exists t'. split; eauto.
    Unshelve.
    - eapply red_welltyped; sq.
      3:eapply Relation_Properties.clos_rtn1_rt in r; eassumption. all:eauto.
  Defined.

  Global Instance wf_hnf_subterm : WellFounded hnf_subterm_rel.
  Proof.
    refine (Wf.Acc_intro_generator 1000 _).
    exact wf_hnf_subterm_rel.
  Defined.
  Opaque wf_hnf_subterm.
  Opaque Acc_intro_generator.
  Opaque Wf.Acc_intro_generator.
  Ltac sq := try (destruct HΣ as [wfΣ]; clear HΣ);
    repeat match goal with
    | H : ∥ _ ∥ |- _ => destruct H
    end; try eapply sq.

End fix_sigma.

Section fix_sigma.
  Context {cf : checker_flags} {no : normalizing_flags}.

  Context (X_type : abstract_env_impl).

  Context (X : X_type.π2.π1).

  Context {normalization_in : forall Σ, wf_ext Σ -> Σ ∼_ext X -> NormalizationIn Σ}.

  (* Reducing at least one step or taking a subterm is well-founded *)
  Definition redp_subterm_rel : Relation_Definitions.relation (∑ Γ t, forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t) :=
    fun '(Γ2; t2; H) '(Γ1; t1; H2) => forall Σ (wfΣ : abstract_env_ext_rel X Σ),
    ∥ (redp Σ Γ1 t1 t2 * (Γ1 = Γ2)) + ∑ ts : term_subterm t2 t1, Γ2 = (Γ1 ,,, term_subterm_context ts) ∥.

  Definition wf_redp_subterm_rel : WellFounded redp_subterm_rel.
  Proof.
    intros (Γ & s & H). pose proof (abstract_env_ext_exists X) as [[Σ wfΣ]].
    pose (wf_extΣ := abstract_env_ext_wf _ wfΣ). sq.
    induction (normalization_in Σ wf_extΣ wfΣ Γ s (H _ wfΣ)) as [s _ IH].
    induction (term_subterm_wf s) as [s _ IH_sub] in Γ, H, IH |- *.
    econstructor.
    intros (Γ' & t2 & ?). intro R. specialize (R _ wfΣ).
    destruct R as [[[r eq]|[ts eqctx]]].
    + subst. eapply Relation_Properties.trans_clos_tn1 in r.
      eapply IH. clear -r.
      induction r; try solve [econstructor; auto].
      now eapply cored_trans with y.
    + subst.
      apply IH_sub. eauto.
      intros. eapply cored_redp in H0 as [].
      destruct (term_subterm_redp X0) as [t'' [[redt' [tst' Htst']]]].
      eapply IH. eapply cored_redp. sq. eassumption. red. intros.
      sq. right. exists tst'. now rewrite Htst'.
    Unshelve. intros. erewrite (abstract_env_ext_irr _ _ wfΣ); eauto.
              eapply redp_red in redt'; eapply red_welltyped; sq; eauto.
    Unshelve. eauto.
  Defined.

  Global Instance wf_redp_subterm : WellFounded redp_subterm_rel.
  Proof.
    refine (Wf.Acc_intro_generator 1000 _).
    exact wf_redp_subterm_rel.
  Defined.
  Opaque wf_redp_subterm.
  Opaque Acc_intro_generator.
  Opaque Wf.Acc_intro_generator.

End fix_sigma.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive expr :=
| Arg
| Self
| Var (i : nat)
| Deref (e : expr) (off : nat)
.

Inductive stmt :=
| Skip
| Seq (s1 : stmt) (s2 : stmt)
| Call (dst : nat) (f : expr) (a : expr)
| MkConstr (dst : nat) (tag : nat) (args : list expr)
| Switch (dst : nat) (cases : list stmt)
| MkClose (dst : nat) (f : function_name) (free : list expr)
| OpaqueOp (dst : nat) (op : opaque_oper_name) (args : list expr)
| Assign (dst : nat) (e : expr)
.

Definition env := list (stmt * nat).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    locals : list (nat * value)
}.

Definition set f l v :=
    Frame (arg f) (self f) ((l, v) :: locals f).

Definition local f l := lookup (locals f) l.

Inductive cont :=
| Kseq (code : stmt) (k : cont)
| Kswitch (k : cont)
| Kreturn (ret : nat) (k : cont)
| Kcall (dst : nat) (f : frame) (k : cont)
| Kstop (ret : nat).

Inductive state :=
| Run (s : stmt) (f : frame) (k : cont)
| Return (v : value) (k : cont)
| Stop (v : value).

Inductive eval : frame -> expr -> value -> Prop :=
| EArg : forall f,
        eval f Arg (arg f)
| ESelf : forall f,
        eval f Self (self f)

| EVar : forall f i v,
        local f i = Some v ->
        eval f (Var i) v

| EDerefConstr : forall f e off tag args v,
        eval f e (Constr tag args) ->
        nth_error args off = Some v ->
        eval f (Deref e off) v
| EDerefClose : forall f e off fname free v,
        eval f e (Close fname free) ->
        nth_error free off = Some v ->
        eval f (Deref e off) v
.

Inductive sstep (E : env) : state -> state -> Prop :=
| SSeq : forall s1 s2 f k,
        sstep E (Run (Seq s1 s2) f k)
                (Run s1 f (Kseq s2 k))

| SConstrDone : forall dst tag args f k vs,
        Forall2 (eval f) args vs ->
        sstep E (Run (MkConstr dst tag args) f k)
                (Run Skip (set f dst (Constr tag vs)) k)
| SCloseDone : forall dst fname free f k vs,
        Forall2 (eval f) free vs ->
        sstep E (Run (MkClose dst fname free) f k)
                (Run Skip (set f dst (Close fname vs)) k)
| SOpaqueOpDone : forall dst op args f k vs v,
        Forall2 (eval f) args vs ->
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp dst op args) f k)
                (Run Skip (set f dst v) k)

| SMakeCall : forall dst fe ae f k  fname free arg body ret,
        eval f fe (Close fname free) ->
        eval f ae arg ->
        nth_error E fname = Some (body, ret) ->
        sstep E (Run (Call dst fe ae) f k)
                (Run body (Frame arg (Close fname free) [])
                    (Kreturn ret (Kcall dst f k)))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall dst cases f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch dst cases) f k)
                (Run case f (Kswitch k))

| SAssign : forall dst src f k v,
        eval f src v ->
        sstep E (Run (Assign dst src) f k)
                (Run Skip (set f dst v) k)

| SContSeq : forall f s k,
        sstep E (Run Skip f (Kseq s k))
                (Run s f k)
| SContSwitch : forall f k,
        sstep E (Run Skip f (Kswitch k))
                (Run Skip f k)
| SContReturn : forall f ret k v,
        local f ret = Some v ->
        sstep E (Run Skip f (Kreturn ret k))
                (Return v k)
| SContCall : forall v dst f k,
        sstep E (Return v (Kcall dst f k))
                (Run Skip (set f dst v) k)
| SContStop : forall ret f v,
        local f ret = Some v ->
        sstep E (Run Skip f (Kstop ret))
                (Stop v)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body ret,
        nth_error (fst prog) fname = Some (body, ret) ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 (Kstop ret)).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*

Definition prog_type : Type := env * list metadata.

Inductive initial_state (prog : prog_type) : state -> Prop :=.

Inductive final_state (prog : prog_type) : state -> Prop :=
| FinalState : forall v, final_state prog (Stop v).

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env
                 (sstep)
                 (initial_state prog)
                 (final_state prog)
                 (initial_env prog).
*)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition stmt_rect_mut
        (P : stmt -> Type)
        (Pl : list stmt -> Type)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pl cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (i : stmt) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        match i as i_ return P i_ with
        | Skip => HSkip
        | Seq s1 s2 => HSeq s1 s2 (go s1) (go s2)
        | Call dst f a => HCall dst f a
        | MkConstr dst tag args => HConstr dst tag args
        | Switch dst cases => HSwitch dst cases (go_list cases)
        | MkClose dst fname free => HClose dst fname free
        | OpaqueOp dst op args => HOpaqueOp dst op args
        | Assign dst src => HAssign dst src
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition stmt_ind' (P : stmt -> Prop)
    (HSkip :    P Skip)
    (HSeq :     forall s1 s2, P s1 -> P s2 -> P (Seq s1 s2))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Forall P cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HAssign :  forall dst src, P (Assign dst src))
    (i : stmt) : P i :=
    ltac:(refine (@stmt_rect_mut P (Forall P)
        HSkip HSeq HCall HConstr HSwitch HClose HOpaqueOp HAssign _ _ i); eauto).


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

Require Export Plans_paralleles.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter secants : PL -> PL -> Prop.

Axiom
  def_secants :
    forall A B C D E F I J : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    I <> J ->
    incluse (droite I J) (plan A B C) ->
    incluse (droite I J) (plan D E F) ->
    ~ para_plan_plan (plan A B C) (plan D E F) ->
    secants (plan A B C) (plan D E F).

Axiom
  def_secants2 :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    secants (plan A B C) (plan D E F) ->
    ~ para_plan_plan (plan A B C) (plan D E F) /\
    (exists I : PO,
       (exists J : PO,
          I <> J /\
          incluse (droite I J) (plan A B C) /\
          incluse (droite I J) (plan D E F))).

Theorem position_relative_plans :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 para_plan_plan (plan A B C) (plan D E F) \/
 secants (plan A B C) (plan D E F).
intros.
lapply
 (plans_paralleles_ou_droite_incluse2 (A:=A) (B:=B) (C:=C) (D:=D) (E:=E)
    (F:=F)); intros; auto.
elim H1;
 [ intros H2; try clear H1
 | intros H2; elim H2;
    [ intros I H3; elim H3;
       [ intros J H4; elim H4;
          [ intros H5 H6; elim H6;
             [ intros H7 H8; try clear H6 H4 H3 H2 H1; try trivial ] ] ] ]
 | try trivial ].
left; try assumption.
elim (classic (para_plan_plan (plan A B C) (plan D E F))); intros.
left; try assumption.
right; try assumption.
apply def_secants with (I := I) (J := J); auto.
Qed.

Theorem toit :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 paralleles (droite D E) (droite A B) ->
 ~ para_plan_plan (plan A B C) (plan D E F) ->
 exists I : PO,
   (exists J : PO,
      (I <> J :>PO /\ paralleles (droite A B) (droite I J)) /\
      incluse (droite I J) (plan A B C) /\ incluse (droite I J) (plan D E F)).
intros.
deroule_triangle A B C.
deroule_triangle D E F.
elim
 position_relative_droite_plan
  with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros H9; try clear position_relative_droite_plan
 | unfold perce in |- *; intros H9; try clear position_relative_droite_plan;
    try exact H9
 | try trivial
 | trivial ].
2: elim H9; [ intros H10 H11; try clear H9; try exact H11 ].
absurd (para_plan_plan (plan A B C) (plan D E F)); auto.
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros k H10; elim H10;
    [ intros k' H11; try clear H10 para_plan_dr_vecteur; auto ]
 | auto
 | auto
 | auto ].
elim paralleles_vecteur with (A := D) (B := E) (C := A) (D := B);
 [ intros k0 H12; try clear paralleles_vecteur; auto | auto | auto | auto ].
apply couple_vecteurs_coplanaires with (a := k0) (b := 0) (c := k) (d := k');
 auto.
rewrite H12; RingPP.
elim def_contact2 with (A := A) (B := B) (C := C) (D := D) (E := F);
 [ intros I H12; try clear def_secants2 | trivial | trivial | trivial ].
elim H12; [ intros H9 H13; try clear H12; try exact H13 ].
exists I.
elim existence_representant_vecteur with (A := I) (B := A) (C := B);
 intros J H14; try clear existence_representant_vecteur.
exists J.
cut (I <> J).
intros H21.
cut (paralleles (droite A B) (droite I J)).
intros H16; try assumption.
split; [ split; [ try assumption | idtac ] | idtac ].
try exact H16.
split; [ try assumption | idtac ].
apply droite_incluse_plan2; auto.
apply paralleles_droite_plan_coplanaires_incluse with (D := I) (E := J); auto.
apply def_para_plan_dr with (D := A) (E := B); auto with geo.
cut (coplanaires D E F I).
intros H22.
apply droite_incluse_plan2; auto.
cut (paralleles (droite D E) (droite I J)); intros.
apply paralleles_droite_plan_coplanaires_incluse with (D := I) (E := J); auto.
apply def_para_plan_dr with (D := D) (E := E); auto with geo.
apply paralleles_trans with (5 := H16); auto.
auto with geo.
apply colineaires_paralleles with 1; auto.
rewrite H14; RingPP.
unfold not in |- *; intros; apply H5.
apply conversion_PP with (a := 1) (b := 1); auto with *.
cut (vec A B = vec I J); intros.
unfold vec in H15.
RingPP2 H15.
rewrite H12; RingPP.
rewrite H14; auto.
Qed.

Lemma plans_paralleles_droite :
 forall A B C D E F I J : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 I <> J ->
 para_plan_plan (plan A B C) (plan D E F) ->
 para_plan_dr (plan A B C) (droite I J) ->
 para_plan_dr (plan D E F) (droite I J).
intros.
deroule_triangle A B C.
deroule_triangle D E F.
elim para_plan_dr_vecteur with (A := A) (B := B) (C := C) (D := I) (E := J);
 [ intros k H10; elim H10; [ intros k' H11; try clear H10; try exact H11 ]
 | auto
 | auto
 | auto ].
elim
 plans_paralleles_vecteurs
  with (A := D) (B := E) (C := F) (D := A) (E := B) (F := C);
 auto.
intros H10 H12; try assumption.
elim H12;
 [ intros c H13; elim H13; [ intros d H14; try clear H13 H12; try exact H14 ] ].
elim H10;
 [ intros a H12; elim H12; [ intros b H13; try clear H12 H10; try exact H13 ] ].
cut
 (vec I J =
  add_PP (mult_PP k (add_PP (mult_PP a (vec D E)) (mult_PP b (vec D F))))
    (mult_PP k' (add_PP (mult_PP c (vec D E)) (mult_PP d (vec D F)))));
 intros.
apply vecteurs_para_plan_dr with (k := k * a + k' * c) (k' := k * b + k' * d);
 auto.
rewrite H10; RingPP.
rewrite H11; rewrite H14; rewrite H13; RingPP.
apply para_plan_sym; auto.
Qed.

Lemma plans_paralleles_secants_droites_paralleles :
 forall A B C D E F I J K : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 ~ alignes I J K ->
 para_plan_plan (plan A B C) (plan D E F) ->
 ~ para_plan_plan (plan A B C) (plan I J K) ->
 incluse (droite I J) (plan A B C) ->
 ex
   (fun G : PO =>
    ex
      (fun L : PO =>
       (G <> L /\ incluse (droite G L) (plan I J K)) /\
       incluse (droite G L) (plan D E F) /\
       paralleles (droite G L) (droite I J))).
intros.
deroule_triangle A B C.
deroule_triangle D E F.
deroule_triangle I J K.
cut (para_plan_dr (plan D E F) (droite I J)); intros.
elim
 position_relative_droite_plan
  with (A := D) (B := E) (C := F) (D := I) (E := K);
 [ intros H15; try clear position_relative_droite_plan
 | unfold perce in |- *; intros H15; try clear position_relative_droite_plan;
    try exact H15
 | try trivial
 | try trivial ].
2: elim H15; [ intros H16 H17; try clear H15; try exact H17 ].
cut (para_plan_plan (plan D E F) (plan I J K)); intros.
absurd (para_plan_plan (plan A B C) (plan I J K)); auto.
apply para_plan_trans with (D := D) (E := E) (F := F); auto.
apply def_para_plan_plan; auto.
elim def_contact2 with (3 := H17);
 [ intros G H15; elim H15; intros; try clear H15; auto | auto | auto ].
elim existence_representant_vecteur with (A := G) (B := I) (C := J);
 intros L H20; try clear existence_representant_vecteur.
exists G; exists L.
cut (G <> L); intros.
cut (paralleles (droite G L) (droite I J)); intros.
split; [ split; [ try assumption | idtac ] | idtac ].
cut (coplanaires I J K G); intros.
apply droite_incluse_plan2; auto with geo.
apply paralleles_droite_plan_coplanaires_incluse with (D := G) (E := L); auto.
apply vecteurs_para_plan_dr with (k := 1) (k' := 0); auto.
rewrite H20; RingPP.
auto with geo.
split; [ try assumption | auto ].
cut (para_plan_dr (plan D E F) (droite G L)); intros.
apply droite_incluse_plan2; auto with geo.
apply paralleles_droite_plan_coplanaires_incluse with (D := G) (E := L); auto.
apply paralleles_droites_plan_trans with (D := I) (E := J); auto with geo.
apply colineaires_paralleles with 1; auto with geo.
rewrite H20; RingPP.
unfold not in |- *; intros; apply H13.
apply conversion_PP with (a := 1) (b := 1); auto with *.
cut (vec I J = vec G L); intros.
unfold vec in H21.
RingPP2 H21.
rewrite H15; RingPP.
rewrite H20; auto.
apply plans_paralleles_droite with (4 := H2); auto.
apply paralleles_droite_incluse; auto.
Qed.
Parameter disjoints : PL -> PL -> Prop.
Parameter confondus : PL -> PL -> Prop.

Axiom
  def_disjoints :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    (forall I : PO, ~ (coplanaires A B C I /\ coplanaires D E F I)) ->
    disjoints (plan A B C) (plan D E F).

Axiom
  def_disjoints2 :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    disjoints (plan A B C) (plan D E F) ->
    forall I : PO, ~ (coplanaires A B C I /\ coplanaires D E F I).

Axiom
  def_confondus :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    (forall I : PO, coplanaires A B C I -> coplanaires D E F I) ->
    confondus (plan A B C) (plan D E F).

Axiom
  def_confondus2 :
    forall A B C D E F : PO,
    ~ alignes A B C ->
    ~ alignes D E F ->
    confondus (plan A B C) (plan D E F) ->
    forall I : PO, coplanaires A B C I -> coplanaires D E F I.

Lemma non_disjoints_exists :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 ~ disjoints (plan A B C) (plan D E F) ->
 exists I : PO, coplanaires A B C I /\ coplanaires D E F I.
intros A B C D E F H H0 H1; try assumption.
cut (~ (forall I : PO, ~ (coplanaires A B C I /\ coplanaires D E F I)));
 intros.
elim
 not_all_not_ex
  with
    (U := PO)
    (P := fun I : PO => coplanaires A B C I /\ coplanaires D E F I);
 [ intros I H3; try clear not_all_not_ex; try exact H3 | auto ].
exists I; auto.
red in |- *; (intros; apply H1).
apply def_disjoints; auto.
Qed.

Theorem position_relative_plans_paralleles :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 para_plan_plan (plan A B C) (plan D E F) ->
 disjoints (plan A B C) (plan D E F) \/ confondus (plan A B C) (plan D E F).
intros A B C D E F H H0 H3; try assumption.
intros.
assert (A <> B); auto with geo.
assert (D <> E); auto with geo.
elim (classic (disjoints (plan A B C) (plan D E F))); intros.
left; try assumption.
right; try assumption.
elim non_disjoints_exists with (3 := H4);
 [ intros I H5; try clear non_disjoints_exists; try exact H3 | auto | auto ].
elim H5; [ intros H6 H7; try clear H5; try exact H6 ].
apply def_confondus; auto.
intros J H5; try assumption.
elim
 plans_paralleles_vecteurs
  with (A := D) (B := E) (C := F) (D := A) (E := B) (F := C);
 auto.
intros.
elim H9; intros c H10; elim H10; intros d H11; try clear H10 H9;
 try exact H11.
elim H8; intros a H9; elim H9; intros b H10; try clear H9 H8; try exact H10.
hcoplanaires H5 x k'.
hcoplanaires H6 x0 k'0.
hcoplanaires H7 x1 k'1.
apply
 (vecteur_def_coplanaires
    (k:=x1 + -1 * (x0 * a + k'0 * c) + (x * a + k' * c))
    (k':=k'1 + -1 * (x0 * b + k'0 * d) + (x * b + k' * d))).
replace (vec D J) with
 (add_PP (add_PP (vec D I) (mult_PP (-1) (vec A I))) (vec A J)).
rewrite H7.
rewrite H6.
rewrite H5.
rewrite H10.
rewrite H11.
Ringvec.
Ringvec.
apply para_plan_sym; auto.
Qed.

Theorem position_relative_plans_general :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 (disjoints (plan A B C) (plan D E F) \/ confondus (plan A B C) (plan D E F)) \/
 secants (plan A B C) (plan D E F).
intros.
assert (A <> B); auto with geo.
assert (D <> E); auto with geo.
elim (classic (para_plan_plan (plan A B C) (plan D E F))); intros.
left; try assumption.
apply position_relative_plans_paralleles; auto.
right; try assumption.
elim
 position_relative_plans
  with (A := A) (B := B) (C := C) (D := D) (E := E) (F := F);
 [ intros H4; try clear position_relative_plans
 | intros H4; try clear position_relative_plans; auto
 | auto
 | auto ].
tauto.
Qed.

Theorem position_relative_plans_non_disjoints :
 forall A B C D E F : PO,
 ~ alignes A B C ->
 ~ alignes D E F ->
 ~ disjoints (plan A B C) (plan D E F) ->
 secants (plan A B C) (plan D E F) \/ confondus (plan A B C) (plan D E F).
intros.
elim
 position_relative_plans_general
  with (A := A) (B := B) (C := C) (D := D) (E := E) (F := F);
 [ intros H2; elim H2;
    [ intros H3; try clear H2 position_relative_plans_general
    | intros H3; try clear H2 position_relative_plans_general; try exact H3 ]
 | intros H2
 | auto
 | auto ].
elim H2; [ intros H4; try clear H2 | intros H4; try clear H2; try exact H4 ].
tauto.
right; try assumption.
elim H2; [ intros H4; try clear H2; try exact H4 | intros H4; try clear H2 ].
tauto.
right; try assumption.
left; try assumption.
Qed.


Require Import sem_common.

Open Scope code_scope.

Lemma semacc_new_fundation:
  forall s P a msgq mq a' msgq' mq' n wls i x2 x3 x4 qid b tcbls,
    s |= AEventData a msgq ** P ->
    RLH_ECBData_P msgq mq ->
    R_ECB_ETbl_P qid (a,b) tcbls ->
    a = (V$OS_EVENT_TYPE_SEM :: Vint32 i :: Vint32 n :: x2 :: x3 :: x4 :: nil) ->
    msgq = DSem n ->
    mq = (abssem n, wls) ->
    Int.ltu Int.zero n = true ->
    a' = (V$OS_EVENT_TYPE_SEM :: Vint32 i :: Vint32 (n-ᵢ$ 1)  :: x2 :: x3 :: x4 :: nil) ->
    msgq' = DSem (n-ᵢ$ 1) ->
    mq' = (abssem (n-ᵢ$ 1), wls) ->
    s |= AEventData a' msgq' **
         [| RLH_ECBData_P msgq' mq' |] **
         [| R_ECB_ETbl_P qid (a',b) tcbls |] ** P.
  intros.
  sep pauto.
  unfold AEventData in *.
  sep pauto.

  apply semacc_ltu_trans; auto.
  unfold RLH_ECBData_P in *.
  destruct H0.
  split.
  auto.
  unfold RH_ECB_P in *.
  destruct H2.
  split.
  intros.
  apply H2; auto.
  intros.
  apply H2 in H5.
  tryfalse.
Qed.

Lemma semacc_RH_TCBList_ECBList_P_hold:
  forall mqls tcbls ct a n wl,
    RH_TCBList_ECBList_P mqls tcbls ct ->
    get mqls a = Some (abssem n, wl) ->
    Int.ltu Int.zero n = true ->
    RH_TCBList_ECBList_P
      (set mqls a (abssem (Int.sub n Int.one), wl)) tcbls ct.
  intros.
  unfold RH_TCBList_ECBList_P in *.
  destruct H as [Hq [Hsem [Hmbox Hmutex]]] .
  intuition.

(***************** Q begin ************)

  unfold RH_TCBList_ECBList_Q_P in *.
  destruct Hq as [F1 F2].
  intuition.
  destruct (dec a eid) eqn:Feq.
  subst.
  match goal with
    | H: get (set _ _ _) _ = _ |- _ =>
        rewrite set_a_get_a in H; tryfalse; auto
  end.

  eapply F1.
  split;
    [ rewrite set_a_get_a' in H2; eauto
    | eauto].

  destruct (dec a eid) eqn:Feq.
  subst.
  match goal with
    | H: get _ _ = _ |- _ =>
        apply F2 in H; mytac; tryfalse'
  end.

  rewrite set_a_get_a';
    [ eapply F2; eauto
    | auto].
(**************** Q end ************)

  unfold RH_TCBList_ECBList_SEM_P in *.
  destruct Hsem as [F1 F2].
  intuition.
  destruct (dec a eid) eqn:Feq.
  subst.
  rewrite set_a_get_a in H2; eauto.
  inverts H2.
  eapply F1.
  split; eauto.

  eapply F1.
  split;
    [ rewrite set_a_get_a' in H2; eauto
    | eauto].

  destruct (dec a eid) eqn:Feq.
  subst.
  apply F2 in H; mytac.
  Ltac gel H :=
    match type of H with
      | ?A = ?B =>
        change ((fun y => y = B) A) in H
    end.
  gel H0.
  rewrite H in H0.
  inverts H0.
  rewrite set_a_get_a.
  do 2 eexists.
  eauto.

  rewrite set_a_get_a'.
  apply F2 in H; mytac.
  do 2 eexists.
  eauto.
  auto.

  unfold RH_TCBList_ECBList_MBOX_P in *.
  destruct Hmbox as [F1 F2].
  intuition.
  destruct (dec a eid) eqn:Feq.
  subst.
  match goal with
    | H: get (set _ _ _) _ = _ |- _ =>
        rewrite set_a_get_a in H; tryfalse; auto
  end.

  eapply F1.
  split;
    [ rewrite set_a_get_a' in H2; eauto
    | eauto].

  destruct (dec a eid) eqn:Feq.
  subst.
  match goal with
    | H: get _ _ = _ |- _ =>
        apply F2 in H; mytac; tryfalse'
  end.

  rewrite set_a_get_a';
    [ eapply F2; eauto
    | auto].

  unfold RH_TCBList_ECBList_MUTEX_P in *.
  destruct Hmutex as [F1 F2].
  swallow; intros.

  destruct (dec a eid) eqn:Feq.
  destruct H.
  subst.
  match goal with
    | H: get (set _ _ _) _ = _ |- _ =>
        rewrite set_a_get_a in H; tryfalse; auto
  end.

  eapply F1.
  destruct H.
  split;
    [ rewrite set_a_get_a' in e; eauto
    | eauto].

  destruct (dec a eid) eqn:Feq.
  subst.
  match goal with
    | H: get _ _ = _ |- _ =>
        apply F2 in H; mytac; tryfalse'
  end.

  rewrite set_a_get_a';
    [ eapply F2; eauto
    | auto].

  eapply Mutex_owner_set; eauto.
  intro; mytac.
  tryfalse.
  mytac.
Qed.


Set Implicit Arguments.

Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Axioms.

From PromisingLib Require Import Event.

Require Import FoldN.
Require Import Knowledge.
Require Import Opt2.

Require Import ITreeLang.

Require Import DeadStoreElim.

Global Program Instance le_PreOrder: PreOrder le.
Next Obligation.
Proof.
  eapply PreOrder_Reflexive. Unshelve.
  apply (@MLattice.le_PreOrder ThreeML).
Qed.
Next Obligation.
Proof.
  eapply PreOrder_Transitive. Unshelve.
  apply (@MLattice.le_PreOrder ThreeML).
Qed.

Global Program Instance le_PartialOrder: PartialOrder eq le.
Next Obligation.
Proof.
  unfold relation_equivalence, relation_conjunction.
  unfold predicate_equivalence, predicate_intersection.
  unfold pointwise_lifting, pointwise_extension.
  i. split; i.
  - clarify. split; refl.
  - des. unfold flip in H0. eapply antisymmetry; eauto.
    Unshelve. auto. eapply partial_order_antisym.
    eapply (@MLattice.le_PartialOrder ThreeML).
Qed.

Section ANALYSIS.

  Lemma ord_inv1:
    forall o, (Ordering.le o Ordering.strong_relaxed) \/
         (Ordering.le Ordering.acqrel o).
  Proof. i. destruct o; auto. Qed.

  Lemma update_load_ord1:
    forall ul o l t
      (ORD: Ordering.le o Ordering.strong_relaxed),
      update_load ul o l t = (if (Loc.eqb ul l) then none else t).
  Proof. i. unfold update_load. des_ifs. Qed.

  Lemma update_load_ord1f:
    forall ul o mp
      (ORD: Ordering.le o Ordering.strong_relaxed),
      (fun p0: Loc.t => update_load ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then none else (mp p0)).
  Proof. i. extensionality p0. apply update_load_ord1; auto. Qed.

  Lemma update_load_ord2:
    forall ul o l t
      (ORD: Ordering.le Ordering.acqrel o),
      update_load ul o l t = (if (Loc.eqb ul l) then none else (acq_flag t)).
  Proof. i. unfold update_load. destruct o; ss; clarify. Qed.

  Lemma update_load_ord2f:
    forall ul o mp
      (ORD: Ordering.le Ordering.acqrel o),
      (fun p0: Loc.t => update_load ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then none else (acq_flag (mp p0))).
  Proof. i. extensionality p0. apply update_load_ord2; auto. Qed.

  Lemma ord_inv1':
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o).
  Proof. i. destruct o; auto. Qed.

  Lemma update_read_ord1:
    forall ul o l t
      (ORD: Ordering.le o Ordering.na),
      update_read ul o l t = (if (Loc.eqb ul l) then none else t).
  Proof. i. unfold update_read. des_ifs. Qed.

  Lemma update_read_ord1f:
    forall ul o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => update_read ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then none else (mp p0)).
  Proof. i. extensionality p0. apply update_read_ord1; auto. Qed.

  Lemma update_read_ord2:
    forall ul o l t
      (ORD: Ordering.le Ordering.plain o),
      update_read ul o l t = (if (Loc.eqb ul l) then none else (acq_flag t)).
  Proof. i. unfold update_read. destruct o; ss; clarify. Qed.

  Lemma update_read_ord2f:
    forall ul o mp
      (ORD: Ordering.le Ordering.plain o),
      (fun p0: Loc.t => update_read ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then none else (acq_flag (mp p0))).
  Proof. i. extensionality p0. apply update_read_ord2; auto. Qed.

  Lemma ord_inv2:
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o)%bool.
  Proof. i. destruct o; auto. Qed.

  Lemma update_store_ord1:
    forall ul o l t
      (ORD: Ordering.le o Ordering.na),
      update_store ul o l t = if (Loc.eqb ul l) then full else t.
  Proof. i. unfold update_store. des_ifs. Qed.

  Lemma update_store_ord1f:
    forall ul o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => update_store ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then full else (mp p0)).
  Proof. i. extensionality p0. apply update_store_ord1; auto. Qed.

  Lemma update_store_ord2:
    forall ul o l t
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.na)%bool),
      update_store ul o l t = (if (Loc.eqb ul l) then none else t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_store_ord2f:
    forall ul o mp
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.na)%bool),
      (fun p0: Loc.t => update_store ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then none else (mp p0)).
  Proof. i. extensionality p0. apply update_store_ord2; auto. Qed.

  Lemma update_store_ord3:
    forall ul o l t
      (ORD: Ordering.le Ordering.plain o),
      update_store ul o l t = (if (Loc.eqb ul l) then none else (rel_flag t)).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_store_ord3f:
    forall ul o mp
      (ORD: Ordering.le Ordering.plain o),
      (fun p0: Loc.t => update_store ul o p0 (mp p0)) = fun p0 => (if (Loc.eqb ul p0) then none else (rel_flag (mp p0))).
  Proof. i. extensionality p0. apply update_store_ord3; auto. Qed.

  Lemma ord_inv3:
    forall o, (Ordering.le o Ordering.strong_relaxed) \/
         (Ordering.le Ordering.acqrel o).
  Proof. i. destruct o; auto. Qed.

  Lemma update_fence_r_ord1:
    forall o l t
      (ORD: Ordering.le o Ordering.strong_relaxed),
      update_fence_r o l t = t.
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_fence_r_ord1f:
    forall o mp
      (ORD: Ordering.le o Ordering.strong_relaxed),
      (fun p0: Loc.t => update_fence_r o p0 (mp p0)) = fun p0 => mp p0.
  Proof. i. extensionality p0. apply update_fence_r_ord1; auto. Qed.

  Lemma update_fence_r_ord2:
    forall o l t
      (ORD: (Ordering.le Ordering.acqrel o)),
      update_fence_r o l t = (acq_flag t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_fence_r_ord2f:
    forall o mp
      (ORD: (Ordering.le Ordering.acqrel o)),
      (fun p0: Loc.t => update_fence_r o p0 (mp p0)) = fun p0 => (acq_flag (mp p0)).
  Proof. i. extensionality p0. apply update_fence_r_ord2; auto. Qed.

  Lemma ord_inv3':
    forall o, (Ordering.le o Ordering.na) \/
         (Ordering.le Ordering.plain o && Ordering.le o Ordering.acqrel)%bool \/
         (Ordering.le Ordering.seqcst o).
  Proof. i. destruct o; auto. Qed.

  Lemma update_fence_w_ord1:
    forall o l t
      (ORD: Ordering.le o Ordering.na),
      update_fence_w o l t = t.
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_fence_w_ord1f:
    forall o mp
      (ORD: Ordering.le o Ordering.na),
      (fun p0: Loc.t => update_fence_w o p0 (mp p0)) = fun p0 => mp p0.
  Proof. i. extensionality p0. apply update_fence_w_ord1; auto. Qed.

  Lemma update_fence_w_ord2:
    forall o l t
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.acqrel)%bool),
      update_fence_w o l t = (rel_flag t).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_fence_w_ord2f:
    forall o mp
      (ORD: (Ordering.le Ordering.plain o && Ordering.le o Ordering.acqrel)%bool),
      (fun p0: Loc.t => update_fence_w o p0 (mp p0)) = fun p0 => (rel_flag (mp p0)).
  Proof. i. extensionality p0. apply update_fence_w_ord2; auto. Qed.

  Lemma update_fence_w_ord3:
    forall o l t
      (ORD: Ordering.le Ordering.seqcst o),
      update_fence_w o l t = (rel_flag (acq_flag t)).
  Proof. i. destruct o; ss; clarify. Qed.

  Lemma update_fence_w_ord3f:
    forall o mp
      (ORD: Ordering.le Ordering.seqcst o),
      (fun p0: Loc.t => update_fence_w o p0 (mp p0)) = fun p0 => (rel_flag (acq_flag (mp p0))).
  Proof. i. extensionality p0. apply update_fence_w_ord3; auto. Qed.

  Lemma rel_flag_mon:
    forall k1 k2 (LE: le k1 k2), le (rel_flag k1) (rel_flag k2).
  Proof.
    i. unfold rel_flag. des_ifs; ss; clarify.
  Qed.

  Lemma rel_flag_le:
    forall k, le (rel_flag k) k.
  Proof.
    i. unfold rel_flag. des_ifs; ss; clarify.
  Qed.

  Lemma acq_flag_mon:
    forall k1 k2 (LE: le k1 k2), le (acq_flag k1) (acq_flag k2).
  Proof.
    i. unfold acq_flag. des_ifs; ss; clarify.
  Qed.

  Lemma acq_flag_le:
    forall k, le (acq_flag k) k.
  Proof.
    i. unfold acq_flag. des_ifs; ss; clarify.
  Qed.

  Lemma update_load_kspec:
    forall l1 l2 o, knowledge_spec le bot (update_load l1 o l2).
  Proof.
    i. hexploit (ord_inv1 o). i. des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_load_ord1; auto. des_ifs.
      + rewrite ! update_load_ord1; auto. des_ifs. right; refl. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_load_ord2; auto. des_ifs. apply acq_flag_mon; auto.
      + rewrite ! update_load_ord2; auto. des_ifs. right; refl. left; apply acq_flag_le.
  Qed.

  Lemma update_read_kspec:
    forall l1 l2 o, knowledge_spec le bot (update_read l1 o l2).
  Proof.
    i. hexploit (ord_inv1' o). i. des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_read_ord1; auto. des_ifs.
      + rewrite ! update_read_ord1; auto. des_ifs. right; refl. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_read_ord2; auto. des_ifs. apply acq_flag_mon; auto.
      + rewrite ! update_read_ord2; auto. des_ifs. right; refl. left; apply acq_flag_le.
  Qed.

  Lemma update_store_kspec:
    forall l1 l2 o, knowledge_spec le bot (update_store l1 o l2).
  Proof.
    i. hexploit (ord_inv2 o). i; des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_store_ord1; auto. des_ifs.
      + rewrite ! update_store_ord1; auto. des_ifs.
        right; refl. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_store_ord3; auto. des_ifs.
        apply rel_flag_mon; auto.
      + rewrite ! update_store_ord3; auto. des_ifs.
        right; refl. left; apply rel_flag_le; auto.
  Qed.

  Lemma update_fence_r_kspec:
    forall l o, knowledge_spec le bot (update_fence_r o l).
  Proof.
    i. hexploit (ord_inv3 o). i; des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_fence_r_ord1; auto.
      + rewrite ! update_fence_r_ord1; auto. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_fence_r_ord2; auto. apply acq_flag_mon; auto.
      + rewrite ! update_fence_r_ord2; auto. left; apply acq_flag_le.
  Qed.

  Lemma update_fence_w_kspec:
    forall l o, knowledge_spec le bot (update_fence_w o l).
  Proof.
    i. hexploit (ord_inv3' o). i; des.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_fence_w_ord1; auto.
      + rewrite ! update_fence_w_ord1; auto. left; refl.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_fence_w_ord2; auto. apply rel_flag_mon; auto.
      + rewrite ! update_fence_w_ord2; auto. left; apply rel_flag_le.
    - unfold knowledge_spec. split; red; i.
      + rewrite ! update_fence_w_ord3; auto. apply rel_flag_mon. apply acq_flag_mon. auto.
      + rewrite ! update_fence_w_ord3; auto. left. etrans. apply rel_flag_le. apply acq_flag_le.
  Qed.

  Lemma update_inst_kspec:
    forall (i: Inst.t) (l: Loc.t), knowledge_spec le bot (update_inst i l).
  Proof.
    i. destruct i.
    1,2,7,8,9: unfold knowledge_spec; split; red; i; ss; clarify; auto.
    all: try (left; refl).
    all: unfold update_inst; ss.
    apply update_load_kspec.
    apply update_store_kspec.
    - eapply kspec_app; eauto. apply le_PreOrder. apply bot_spec. apply update_read_kspec. apply update_store_kspec.
    - eapply kspec_app; eauto. apply le_PreOrder. apply bot_spec. apply update_fence_r_kspec. apply update_fence_w_kspec.
  Qed.

  Lemma update_inst_sspec:
    forall p k, eq (update_inst Inst.skip p k) k.
  Proof. ss. Qed.

  Lemma update_inst_mon: forall (i: Inst.t) p d1 d2 (LE: le d1 d2), le (update_inst i p d1) (update_inst i p d2).
  Proof.
    i. hexploit update_inst_kspec. i. unfold knowledge_spec in H. des. eapply MON; eauto.
  Qed.

End ANALYSIS.

Section ALG.

  Definition DSE_do_opt (mp: Data Three Loc.t) (i: Inst.t) : Prop :=
    match i with
    | Inst.store l _ o =>
      match (mp l), o with
      | half, Ordering.na
      | full, Ordering.na => True
      | _, _ => False
      end
    | _ => False
    end
  .

  Lemma do_opt_not:
    forall (i : Inst.t) (data : Data Three Loc.t)
      (NOOPT: ~ (DSE_do_opt data i)),
      DSE_opt_inst data i = i.
  Proof.
    i. destruct i; ss; clarify. des_ifs; ss; clarify.
  Qed.

  Lemma do_opt_not_skip:
    forall data, not (DSE_do_opt data Inst.skip).
  Proof. ss. Qed.

  Definition DSE_opt2: Opt2.t :=
    Opt2.mk_opt2
      ThreeML bot bot_spec level
      update_inst update_inst_mon update_inst_sspec
      DSE_opt_inst
      DSE_do_opt do_opt_not do_opt_not_skip
      strict_order half.

  Definition block_d := Opt2.block_d DSE_opt2.

  Lemma analysis_correct: update_block = block_d.
  Proof. ss. Qed.

  Lemma opt_correct: DSE_opt_block = Opt2.opt_block DSE_opt2.
  Proof. ss. Qed.

End ALG.

Section FIXPOINT.

  Definition DSE_fix2: FixOpt2.t :=
    @FixOpt2.mk_fix2
      ThreeML bot bot_spec level level_grounded
      Loc.t update_inst update_inst_kspec update_inst_sspec
      half.

  Lemma DSE_kspec2: forall blk p, knowledge_spec (MLattice.le ThreeML) bot (update_block blk p).
  Proof.
    i. eapply (@update_block_is_knowledge DSE_fix2).
  Qed.

  Theorem block_d_fix: forall blk f (FUN: f = block_d blk) p,
      @n_fix Three (MLattice.eq ThreeML) (MLattice.eq_Equiv ThreeML) (f p) (S level).
  Proof.
    i. eapply (@update_block_fix DSE_fix2). eauto.
  Qed.

  Theorem block_d_dec: forall blk p d f (FUN: f = block_d blk p), (MLattice.le ThreeML) (f (f d)) (f d).
  Proof.
    i. clarify. ss. rewrite <- analysis_correct.
    hexploit (knowledge_le_n eq_leibniz (@MLattice.le_PartialOrder ThreeML) bot_spec 1 (DSE_kspec2 blk p)).
    i; ss. eauto.
  Qed.

End FIXPOINT.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** RTL function inlining *)

Require Import Coqlib.
Require Import Wfsimpl.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Op.
Require Import Registers.
Require Import RTL.

Ltac xomega := unfold Plt, Ple in *; zify; omega.

Section WITHEF.
Context `{Hsc: SyntaxConfiguration}.

(** ** Environment of inlinable functions *)

(** We maintain a mapping from function names to their definitions.
  In this mapping, we only include internal functions that are eligible for
  inlining, as determined by the external heuristic
  [should_inline]. *)

Definition funenv : Type := PTree.t function.

Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv.

Parameter should_inline: ident -> function -> bool.

Definition add_globdef (fenv: funenv) (idg: ident * globdef fundef unit) : funenv :=
  match idg with
  | (id, Gfun (Internal f)) =>
      if should_inline id f
      then PTree.set id f fenv
      else PTree.remove id fenv
  | (id, _) =>
      PTree.remove id fenv
  end.

Definition funenv_program (p: program) : funenv :=
  List.fold_left add_globdef p.(prog_defs) (PTree.empty function).

(** Resources used by a function. *)

(** Maximum PC (node number) in the CFG of a function.  All nodes of
  the CFG of [f] are between 1 and [max_pc_function f] (inclusive). *)

Definition max_pc_function (f: function) :=
  PTree.fold (fun m pc i => Pmax m pc) f.(fn_code) 1%positive.

(** Maximum pseudo-register defined in a function.  All results of
  an instruction of [f], as well as all parameters of [f], are between
  1 and [max_def_function] (inclusive). *)

Definition max_def_instr (i: instruction) :=
  match i with
  | Iop op args res s => res
  | Iload chunk addr args dst s => dst
  | Icall sg ros args res s => res
  | Ibuiltin ef args res s => res
  | _ => 1%positive
  end.

Definition max_def_function (f: function) :=
  Pmax
    (PTree.fold (fun m pc i => Pmax m (max_def_instr i)) f.(fn_code) 1%positive)
    (List.fold_left (fun m r => Pmax m r) f.(fn_params) 1%positive).

(** State monad *)

(** To construct incrementally the CFG of a function after inlining,
  we use a state monad similar to that used in module [RTLgen].
  It records the current state of the CFG, plus counters to generate
  fresh pseudo-registers and fresh CFG nodes.  It also records the
  stack size needed for the inlined function. *)

Record state : Type := mkstate {
  st_nextreg: positive;                 (**r last used pseudo-register *)
  st_nextnode: positive;                (**r last used CFG node *)
  st_code: code;                        (**r current CFG  *)
  st_stksize: Z                         (**r current stack size *)
}.

(** Monotone evolution of the state. *)

Inductive sincr (s1 s2: state) : Prop :=
  Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg))
        (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode))
        (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)).

Remark sincr_refl: forall s, sincr s s.
Proof.
  intros; constructor; xomega.
Qed.

Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3.
Proof.
  intros. inv H; inv H0. constructor; xomega.
Qed.

(** Dependently-typed state monad, ensuring that the final state is
  greater or equal (in the sense of predicate [sincr] above) than
  the initial state. *)

Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s').

Definition mon (A: Type) : Type := forall (s: state), @res A s.

(** Operations on this monad. *)

Definition ret {A: Type} (x: A): mon A :=
  fun s => R x s (sincr_refl s).

Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B :=
  fun s1 => match x s1 with R vx s2 I1 =>
              match f vx s2 with R vy s3 I2 =>
                R vy s3 (sincr_trans s1 s2 s3 I1 I2)
              end
            end.

Notation "'do' X <- A ; B" := (bind A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition initstate :=
  mkstate 1%positive 1%positive (PTree.empty instruction) 0.

Program Definition set_instr (pc: node) (i: instruction): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition add_instr (i: instruction): mon node :=
  fun s =>
    let pc := Psucc s.(st_nextnode) in
    R pc
      (mkstate s.(st_nextreg) pc (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_nodes (numnodes: positive): mon positive :=
  fun s =>
    R s.(st_nextnode)
      (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_regs (numregs: positive): mon positive :=
  fun s =>
    R s.(st_nextreg)
      (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition request_stack (sz: Z): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit :=
  match l with
  | nil => ret tt
  | (x,y) :: l' => do z <- f x y; mlist_iter2 f l'
  end.

(** ** Inlining contexts *)

(** A context describes how to insert the CFG for a source function into
  the CFG for the function after inlining:
- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)];
- all pseudo-registers of this instruction are shifted by [ctx.(dreg)];
- all stack references are shifted by [ctx.(dstk)];
- "return" instructions are transformed into "return" or "move" instructions
  as governed by [ctx.(retinfo)].
*)

Record context: Type := mkcontext {
  dpc: positive;                        (**r offset for PCs *)
  dreg: positive;                       (**r offset for pseudo-regs *)
  dstk: Z;                              (**r offset for stack references *)
  mreg: positive;                       (**r max pseudo-reg number *)
  mstk: Z;                              (**r original stack block size *)
  retinfo: option(node * reg)           (**r where to branch on return *)
                                        (**r and deposit return value *)
}.

(** The following functions "shift" (relocate) PCs, registers, operations, etc. *)

Definition spc (ctx: context) (pc: node) := Pplus pc ctx.(dpc).

Definition sreg (ctx: context) (r: reg) := Pplus r ctx.(dreg).

Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl.

Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros.

Definition sop (ctx: context) (op: operation) :=
  shift_stack_operation (Int.repr ctx.(dstk)) op.

Definition saddr (ctx: context) (addr: addressing) :=
  shift_stack_addressing (Int.repr ctx.(dstk)) addr.

(** The initial context, used to copy the CFG of a toplevel function. *)

Definition initcontext (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := 0;
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := None |}.

(** The context used to inline a call to another function. *)

Definition min_alignment (sz: Z) :=
  if zle sz 1 then 1
  else if zle sz 2 then 2
  else if zle sz 4 then 4 else 8.

Definition callcontext (ctx: context)
                      (dpc dreg nreg: positive) (sz: Z)
                      (retpc: node) (retreg: reg) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := Some (spc ctx retpc, sreg ctx retreg) |}.

(** The context used to inline a tail call to another function. *)

Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align ctx.(dstk) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := ctx.(retinfo) |}.

(** ** Recursive expansion and copying of a CFG *)

(** Insert "move" instructions to copy the arguments of an inlined
    function into its parameters. *)

Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node :=
  match srcs, dsts with
  | s1 :: sl, d1 :: dl =>
      do n <- add_instr (Iop Omove (s1 :: nil) d1 succ);
      add_moves sl dl n
  | _, _ =>
      ret succ
  end.

(** To prevent infinite inlining of a recursive function, when we
  inline the body of a function [f], this function is removed from the
  environment of inlinable functions and therefore becomes ineligible
  for inlining.  This decreases the size (number of entries) of the
  environment and guarantees termination.  Inlining is, therefore,
  presented as a well-founded recursion over the size of the environment. *)

Section EXPAND_CFG.

Variable fenv: funenv.

(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies
  the body of function [f], with inline expansion within, as governed
  by context [ctx].  It can only be called for function environments
  [fenv'] strictly smaller than the current environment [fenv]. *)

Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> function -> mon unit.

(** Given a register-or-symbol [ros], can we inline the corresponding call? *)

Inductive inline_decision (ros: reg + ident) : Type :=
  | Cannot_inline
  | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f).

Program Definition can_inline (ros: reg + ident): inline_decision ros :=
  match ros with
  | inl r => Cannot_inline _
  | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end
  end.

(** Inlining of a call to function [f].  An appropriate context is
  created, then the CFG of [f] is recursively copied, then moves
  are inserted to copy the arguments of the call to the parameters of [f]. *)

Definition inline_function (ctx: context) (id: ident) (f: function)
                           (P: PTree.get id fenv = Some f)
                           (args: list reg)
                           (retpc: node) (retreg: reg) : mon node :=
  let npc := max_pc_function f in
  let nreg := max_def_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** Inlining of a tail call to function [f].  Similar to [inline_function],
  but the new context is different. *)

Definition inline_tail_function (ctx: context) (id: ident) (f: function)
                               (P: PTree.get id fenv = Some f)
                               (args: list reg): mon node :=
  let npc := max_pc_function f in
  let nreg := max_def_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** The instruction generated for a [Ireturn] instruction found in an
  inlined function body. *)

Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg): instruction :=
  match retinfo, or with
  | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc
  | (retpc, retreg), None   => Inop retpc
  end.

(** Expansion and copying of an instruction.  For most instructions,
  its registers and successor PC are shifted as per the context [ctx],
  then the instruction is inserted in the final CFG at its final position
  [spc ctx pc].

  [Icall] instructions are either replaced by a "goto" to the expansion
  of the called function, or shifted as described above.

  [Itailcall] instructions are similar, with one additional case.  If
  the [Itailcall] occurs in the body of an inlined function, and
  cannot be inlined itself, it must be turned into an [Icall]
  instruction that branches to the return point of the inlined
  function.

  Finally, [Ireturn] instructions within an inlined function are
  turned into a "move" or "goto" that stores the result, if any,
  into the destination register, then branches back to the successor
  of the inlined call. *)

Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
  match i with
  | Inop s =>
      set_instr (spc ctx pc) (Inop (spc ctx s))
  | Iop op args res s =>
      set_instr (spc ctx pc)
                (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Iload chunk addr args dst s =>
      set_instr (spc ctx pc)
                (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
  | Istore chunk addr args src s =>
      set_instr (spc ctx pc)
                (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
  | Icall sg ros args res s =>
      match can_inline ros with
      | Cannot_inline =>
          set_instr (spc ctx pc)
                    (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s))
      | Can_inline id f P Q =>
          do n <- inline_function ctx id f Q args s res;
          set_instr (spc ctx pc) (Inop n)
      end
  | Itailcall sg ros args =>
      match can_inline ros with
      | Cannot_inline =>
          match ctx.(retinfo) with
          | None =>
              set_instr (spc ctx pc)
                        (Itailcall sg (sros ctx ros) (sregs ctx args))
          | Some(rpc, rreg) =>
              set_instr (spc ctx pc)
                        (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc)
          end
      | Can_inline id f P Q =>
          do n <- inline_tail_function ctx id f Q args;
          set_instr (spc ctx pc) (Inop n)
      end
  | Ibuiltin ef args res s =>
      set_instr (spc ctx pc)
                (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Icond cond args s1 s2 =>
      set_instr (spc ctx pc)
                (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
  | Ijumptable r tbl =>
      set_instr (spc ctx pc)
                (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
  | Ireturn or =>
      match ctx.(retinfo) with
      | None =>
          set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or))
      | Some rinfo =>
          set_instr (spc ctx pc) (inline_return ctx or rinfo)
      end
  end.

(** The expansion of a function [f] iteratively expands all its
  instructions, after recording how much stack it needs. *)

Definition expand_cfg_rec (ctx: context) (f: function): mon unit :=
  do x <- request_stack (ctx.(dstk) + ctx.(mstk));
  mlist_iter2 (expand_instr ctx) (PTree.elements f.(fn_code)).

End EXPAND_CFG.

(** Here we "tie the knot" of the recursion, taking the fixpoint
  of [expand_cfg_rec]. *)

Definition expand_cfg := Fixm size_fenv expand_cfg_rec.

(** Start of the recursion: copy and inline function [f] in the
  initial context. *)

Definition expand_function (fenv: funenv) (f: function): mon context :=
  let npc := max_pc_function f in
  let nreg := max_def_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in
  do x <- expand_cfg fenv ctx f;
  ret ctx.

(** ** Inlining in functions and whole programs. *)

Local Open Scope string_scope.

(** Inlining can increase the size of the function's stack block.  We must
  make sure that the new size does not exceed [Int.max_unsigned], otherwise
  address computations within the stack would overflow and produce incorrect
  results. *)

Definition transf_function (fenv: funenv) (f: function) : Errors.res function :=
  let '(R ctx s _) := expand_function fenv f initstate in
  if zlt s.(st_stksize) Int.max_unsigned then
    OK (mkfunction f.(fn_sig)
                   (sregs ctx f.(fn_params))
                   s.(st_stksize)
                   s.(st_code)
                   (spc ctx f.(fn_entrypoint)))
  else
    Error(msg "Inlining: stack too big").

Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef :=
  AST.transf_partial_fundef (transf_function fenv) fd.

Definition transf_program (p: program): Errors.res program :=
  let fenv := funenv_program p in
  AST.transform_partial_program (transf_fundef fenv) p.

End WITHEF.


(** * Facts about Static Expressions *)

Require Import hvhdl.Environment.
Require Import hvhdl.StaticExpressions.
Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.SemanticalDomains.

Require Import hvhdl.proofs.EnvironmentFacts.

(** ** Facts about Locally Static Expressions *)

Section LStatic.

End LStatic.

(** ** Facts about Globally Static Expressions *)

Section GStatic.

  Lemma IGStaticExpr_eq_iff_eq_gens :
    forall {Δ1 Δ2 e},
      EqGens Δ1 Δ2 ->
      IGStaticExpr Δ1 e <->
      IGStaticExpr Δ2 e.
  Proof.
    split.
    (* CASE A -> B *)
    - induction 1; eauto with hvhdl.
      eapply IsGStaticGeneric with (t := t) (v := v);
        rewrite <- H; assumption.
    (* CASE B -> A *)
    - induction 1; eauto with hvhdl.
      eapply IsGStaticGeneric with (t := t) (v := v);
        rewrite H; assumption.
  Qed.

End GStatic.


Require Import Coq.Bool.Sumbool.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.WfProofs.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Compilers.MapBaseType.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Prod.

Section language.
  Context {base_type_code1 base_type_code2 : Type}
          {op1 : flat_type base_type_code1 -> flat_type base_type_code1 -> Type}
          {op2 : flat_type base_type_code2 -> flat_type base_type_code2 -> Type}
          (f_base : base_type_code1 -> base_type_code2)
          (f_op : forall var1 s d,
              op1 s d
              -> exprf _ op1 (var:=var1) s
              -> option (op2 (lift_flat_type f_base s) (lift_flat_type f_base d))).

  Local Hint Constructors wf wff or.

  Local Notation mapf_base_type :=
    (@mapf_base_type base_type_code1 base_type_code2 op1 op2 f_base f_op).
  Local Notation map_base_type :=
    (@map_base_type base_type_code1 base_type_code2 op1 op2 f_base f_op).

  Section with_var.
    Context {var1 var1' : base_type_code1 -> Type}
            {var2 var2' : base_type_code2 -> Type}
            (f_var12 : forall t, var1 t -> var2 (f_base t))
            (f_var21 : forall t, var2 (f_base t) -> var1 t)
            (f_var'12 : forall t, var1' t -> var2' (f_base t))
            (f_var'21 : forall t, var2' (f_base t) -> var1' t)
            (failb : forall t, exprf _ op2 (var:=var2) (Tbase t))
            (failb' : forall t, exprf _ op2 (var:=var2') (Tbase t))
            (Hwf_failb : forall t G, wff G (failb t) (failb' t))
            (Hwf_f_op : forall G s d opc e1 e2,
                wff G e1 e2
                -> f_op var1 s d opc e1 = f_op var1' s d opc e2)
            (Hvar12 : forall t v, f_var12 t (f_var21 t v) = v)
            (Hvar'12 : forall t v, f_var'12 t (f_var'21 t v) = v).

    Lemma wff_mapf_base_type G G' {t}
          (e : exprf base_type_code1 op1 (var:=var1) t)
          (e' : exprf base_type_code1 op1 (var:=var1') t)
          (HG : forall t x x',
              List.In (existT _ t (x, x')) G
              -> List.In (existT _ (f_base t) (f_var12 _ x, f_var'12 _ x')) G')
          (Hwf : wff G e e')
      : wff G'
            (mapf_base_type f_var12 f_var21 failb e)
            (mapf_base_type f_var'12 f_var'21 failb' e').
    Proof.
      revert dependent G'; induction Hwf;
        repeat first [ progress simpl in *
                     | progress intros
                     | progress inversion_option
                     | progress subst
                     | break_innermost_match_step
                     | progress specialize_by_assumption
                     | apply wff_SmartPairf_SmartValf
                     | solve [ eauto using In_flatten_binding_list_untransfer_interp_flat_type ]
                     | match goal with
                       | [ |- wff _ _ _ ] => constructor
                       | [ H : _ |- _ ] => apply H; try setoid_rewrite List.in_app_iff
                       | [ H : f_op _ ?s ?d ?opc ?e = ?x, H' : f_op _ ?s ?d ?opc ?e' = ?y |- _ ]
                         => assert (x = y) by (rewrite <- H, <- H'; eauto); clear H'
                       end
                     | progress destruct_head'_or ].
    Qed.

    Lemma wf_map_base_type {t}
          (e : expr base_type_code1 op1 (var:=var1) t)
          (e' : expr base_type_code1 op1 (var:=var1') t)
          (Hwf : wf e e')
      : wf
          (map_base_type f_var12 f_var21 failb e)
          (map_base_type f_var'12 f_var'21 failb' e').
    Proof.
      destruct Hwf; constructor; simpl; intros.
      eapply wff_mapf_base_type; [ | eauto ].
      eauto using In_flatten_binding_list_untransfer_interp_flat_type.
    Qed.
  End with_var.

  Section MapBaseType.
    Context (failb : forall var t, exprf _ op2 (var:=var) (Tbase t))
            (Hwf_failb : forall var1 var2 G t, wff G (failb var1 t) (failb var2 t))
            (Hwf_f_op : forall var1 var1' s d opc G e1 e2,
                wff G e1 e2
                -> f_op var1 s d opc e1 = f_op var1' s d opc e2)
            {t} (e : Expr base_type_code1 op1 t)
            (Hwf : Wf e).

    Lemma Wf_MapBaseType'
      : Wf (MapBaseType' f_base f_op failb e).
    Proof using Hwf Hwf_failb Hwf_f_op.
      intros var1 var2; apply wf_map_base_type; eauto.
    Qed.

    Lemma Wf_MapBaseType
          r
          (H : MapBaseType f_base f_op failb e = Some r)
      : Wf r.
    Proof using Hwf Hwf_failb Hwf_f_op.
      cbv [MapBaseType] in *; break_innermost_match_hyps; inversion_option; subst.
      apply Wf_MapBaseType'.
    Qed.
  End MapBaseType.
End language.

Hint Resolve @Wf_MapBaseType' : wf.


(** * Recursing under binders with typeclasses, tracking variables with explicit contexts *)
Require Import Reify.ReifyCommon.

(** Points of note:

    - We make sure to fill in all implicit arguments explicitly, to
      minimize the number of evars generated; evars are one of the
      main bottlenecks.

    - In the [Hint] used to tie the recursive knot, we run [intros]
      before binding any terms to avoid playing fast and loose with
      binders, because we will sometimes be presented with goals with
      unintroduced binders.  If we did not call [intros] first,
      instead binding [?var] and [?term] in the hint pattern rule,
      they might contain unbound identifiers, causing reification to
      fail when it tried to deal with them. *)

Module var_context.
  Inductive var_context {var : Type} :=
  | nil
  | cons (n : nat) (v : var) (xs : var_context).
End var_context.

Class reify_helper_cls (var : Type) (term : nat)
      (ctx : @var_context.var_context var)
  := do_reify_helper : @expr var.

Ltac reify_helper var term ctx :=
  let reify_rec term := reify_helper var term ctx in
  lazymatch ctx with
  | context[var_context.cons term ?v _]
    => constr:(@Var var v)
  | _
    =>
    lazymatch term with
    | O => constr:(@NatO var)
    | S ?x
      => let rx := reify_rec x in
         constr:(@NatS var rx)
    | ?x * ?y
      => let rx := reify_rec x in
         let ry := reify_rec y in
         constr:(@NatMul var rx ry)
    | (dlet x := ?v in ?f)
      => let rv := reify_rec v in
         let not_x := fresh (*x *)in (* don't try to preserve variable names; c.f. comments around ReifyCommon.refresh *)
         let rf
             :=
             lazymatch
               constr:(_ : forall (x : nat) (not_x : var),
                          @reify_helper_cls
                            var f (@var_context.cons var x not_x ctx))
             with
             | fun _ => ?f => f
             | ?f => error_cant_elim_deps f
             end in
         constr:(@LetIn var rv rf)
    | ?v
      => error_bad_term v
    end
  end.

Module Export Exports.
  Global Hint Extern 0 (@reify_helper_cls _ _ _)
  => (intros;
     lazymatch goal with
     | [ |- @reify_helper_cls ?var ?term ?ctx ]
       => let res := reify_helper var term ctx in
          exact res
     end) : typeclass_instances.
End Exports.

Ltac reify var x :=
  reify_helper var x (@var_context.nil var).
Ltac Reify x := Reify_of reify x.
Ltac do_Reify_rhs
     do_trans
     restart_timer_norm_reif finish_timing_norm_reif
     restart_timer_actual_reif finish_timing_actual_reif
     restart_timer_eval_lazy finish_timing_eval_lazy
     time_lazy_beta_iota time_transitivity_Denote_rv
     _ :=
  do_Reify_rhs_of
    do_trans
    restart_timer_norm_reif finish_timing_norm_reif
    restart_timer_actual_reif finish_timing_actual_reif
    restart_timer_eval_lazy finish_timing_eval_lazy
    time_lazy_beta_iota time_transitivity_Denote_rv
    Reify ().
Ltac post_Reify_rhs do_trans _ := ReifyCommon.post_Reify_rhs do_trans ().
Ltac Reify_rhs
     do_trans
     restart_timer_norm_reif finish_timing_norm_reif
     restart_timer_actual_reif finish_timing_actual_reif
     restart_timer_eval_lazy finish_timing_eval_lazy
     time_lazy_beta_iota time_transitivity_Denote_rv
     _ :=
  Reify_rhs_of
    do_trans
    restart_timer_norm_reif finish_timing_norm_reif
    restart_timer_actual_reif finish_timing_actual_reif
    restart_timer_eval_lazy finish_timing_eval_lazy
    time_lazy_beta_iota time_transitivity_Denote_rv
    Reify ().