From Coq Require Logic.Eqdep Sets.Ensembles.
Require Import Rupicola.Lib.Api.
Require Export Rupicola.Examples.IO.Writer.

Open Scope list_scope.

Set Implicit Arguments.
Set Primitive Projections.

Module Observable.
  Import Writer.

  Section Observable.
  Context (T: Type).

  Definition M A := Writer.M T A -> Prop.

  Ltac s :=
    apply Ensembles.Extensionality_Ensembles;
    unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In;
    repeat match goal with
           | _ => reflexivity || eassumption
           | _ => progress (intros; subst; simpl in * )
           | [ H: exists _, _ |- _ ] => destruct H
           | [ H: _ /\ _ |- _ ] => destruct H
           | [  |- exists _, _ ] => eexists
           | [  |- _ /\ _ ] => split
           | _ => rewrite ?List.app_nil_r, ?List.app_assoc
           end.

  Global Program Instance MonadM : Monad M :=
    {| mret {A} (a: A) := fun r => r = {| val := a; trace := [] |};
       mbind {A B} (ma: M A) (k: A -> M B) :=
         fun obs => exists obsA obsB, ma obsA /\ k obsA.(val) obsB /\
                              obs = {| val := obsB.(val);
                                       trace := obsB.(trace) ++ obsA.(trace) |} |}.
  Obligation 1. Proof. s. Qed.
  Obligation 2. Proof. s. Qed.
  Obligation 3. Proof. s. Qed.
  End Observable.
End Observable.

Module IO.
  Import Writer.

  Section IO.
  Context (T: Type).

  Inductive Action : Type -> Type :=
  | Read : Action T
  | Write (w: T) : Action unit.

  Definition M := (@Free.M Action).
  (* Instance Monad : Monad (@Free.M Action) := @Free.Monad Action. *)

  Inductive Event T := R (t: T) | W (t: T).

  Definition interpAction {A} (rw: Action A) : Observable.M (Event T) A :=
    match rw with
    | Read => fun wr => wr.(trace) = [R wr.(val)]
    | Write w => fun wr => wr.(trace) = [W w]
    end.

  Definition interp {A} (spec: M A) : Observable.M (Event T) A :=
    Free.interp (MM' := Observable.MonadM (Event T)) (@interpAction) spec.

  Inductive Valid {A} : IO.M A -> Writer.M (Event T) A -> Prop :=
    | ValidPure a : Valid (Free.Pure a) {| val := a; trace := [] |}
    | ValidRead r k a t :
        Valid (k r) {| val := a; trace := t |} ->
        Valid (Free.Impure Read k) {| val := a; trace := t ++ [R r] |}
    | ValidWrite w k a t :
        Valid (k tt) {| val := a; trace := t |} ->
        Valid (Free.Impure (Write w) k) {| val := a; trace := t ++ [W w] |}.

  Hint Constructors Valid : io.
  Lemma interp_Valid {A} (spec: IO.M A):
    forall obs,
      Valid spec obs <-> interp spec obs.
  Proof.
    induction spec; simpl; unfold mret; intros.
    - split; inversion 1; subst; simpl; eauto with io.
    - split.
      + inversion 1;
          repeat match goal with
                 | _ => progress subst
                 | [ H: existT _ _ _ = _ |- _ ] => apply Eqdep.EqdepTheory.inj_pair2 in H
                 end.
        1: exists {| val := r; trace := [R r] |}, {| val := a; trace := t |}.
        2: exists {| val := tt; trace := [W w] |}, {| val := a; trace := t |}.
        all: firstorder.
      + destruct f; unfold mbind;
          repeat match goal with
                 | [ H: unit |- _ ] => destruct H
                 | [ H: exists _: Writer.M _ _, _ |- _ ] => destruct H as [(?&?) ?]
                 | [ H: _ /\ _ |- _ ] => destruct H
                 | _ => intros; subst; simpl in *
                 end.
        all: firstorder eauto with io.
  Qed.
  End IO.
End IO.

Arguments IO.Read {_} : assert.

Import Writer.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {memT: map.map word Byte.byte}.
  Context {localsT: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok memT}.
  Context {locals_ok : map.ok localsT}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Context {T: Type}.
  Notation IO := (IO.M T).
  Notation Event := (IO.Event T).
  Notation Writer := (Writer.M Event).

  Context (trace_entry_of_event: Event -> trace_entry (width := width)).
  Notation wrbind_spec := (wrbind_spec trace_entry_of_event).
  Notation lift_tr := (List.map trace_entry_of_event).

  Definition iobind {A} (io: IO A) (pred: Writer A -> Prop) :=
    (* NOTE: We do not need to capture the fact that all traces are achievable:
       Bedrock2 takes care of that for us (the source program has no control on the
       values returned by "read" *)
    exists wr, IO.Valid io wr /\ pred wr.

  Definition iobind_spec {A} tr0 (io: IO A) (pred: A -> Semantics.trace -> Prop) : Prop :=
    iobind io (fun wr => wrbind_spec tr0 wr pred).

  Definition iospec {A} (tr0 tr1: Semantics.trace) (io: IO A) (post: A -> Prop) : Prop :=
    iobind_spec tr0 io (fun a tr' => tr' = tr1 /\ post a).

  Definition iospec_k {A} tr0 (pred: A -> pure_predicate) (io: IO A) : predicate :=
    fun tr1 mem locals => iospec tr0 tr1 io (fun a => pred a mem locals).

  Lemma iobind_spec_bindn {A B} tr0 pred vars io wr (k : A -> IO B):
      IO.Valid io wr ->
      iobind_spec (List.map trace_entry_of_event wr.(trace) ++ tr0) (k wr.(val)) pred ->
      iobind_spec tr0 (mbindn vars io k) pred.
  Proof.
    unfold iobind_spec, iobind, wrbind_spec.
    intros H (wrb & Hb & Hwr).
    eexists {| val := wrb.(val); trace := wrb.(trace) ++ wr.(trace) |};
      split.
    - apply IO.interp_Valid in H, Hb; apply IO.interp_Valid.
      unfold IO.interp; rewrite <- @Free.interp_mbindn.
      red; red; red; eauto.
    - simpl; rewrite map_app, <- app_assoc; eassumption.
  Qed.

  Lemma WeakestPrecondition_iospec_k_bindn {A B} tr0 funcs prog tr mem locals :
    forall vars (io : IO A) (k : A -> IO B) wr (pred : B -> pure_predicate),
    IO.Valid io wr ->
    (IO.Valid io wr ->
     WeakestPrecondition.program
       funcs prog tr mem locals
       (iospec_k (lift_tr wr.(trace) ++ tr0) pred (k wr.(val)))) ->
    WeakestPrecondition.program
      funcs prog tr mem locals
      (iospec_k tr0 pred (mbindn vars io k)).
  Proof.
    intros; eapply WeakestPrecondition_weaken; [ | eauto ].
    intros; eapply iobind_spec_bindn; eauto.
  Qed.

  Lemma compile_setup_iospec_k {tr mem locals functions} :
    forall {A} {pred: A -> _ -> pure_predicate}
      {spec: IO A} {cmd}
      retvars,

      (let pred a := wp_pure_bind_retvars retvars (pred a) in
       <{ Trace := tr;
          Memory := mem;
          Locals := locals;
          Functions := functions }>
       cmd
       <{ iospec_k tr pred spec }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd
      <{ (fun spec =>
            wp_bind_retvars
              retvars
              (fun rets tr' mem' locals' =>
                 iospec tr tr' spec (fun a => pred a rets mem' locals')))
           spec }>.
  Proof.
    intros; unfold iospec_k, iospec, iobind_spec, wrbind_spec, iobind, wp_bind_retvars, wp_pure_bind_retvars in *.
    use_hyp_with_matching_cmd; simpl in *.
    cleanup; subst; eauto 10.
  Qed.

  (* FIXME can we generalize?  Basically this works with any monad that describes sets of values *)
  Lemma compile_if : forall {tr mem locals functions} (c: bool) {A} (t f: IO A),
    let v := if c then t else f in
    forall {B} {pred: B -> pure_predicate} {val_pred: A -> pure_predicate}
      {k: A -> IO B} {k_impl t_impl f_impl}
      c_expr vars,

      WeakestPrecondition.dexpr mem locals c_expr (word.b2w c) ->

      (let val_pred := val_pred in
       c = true ->
       <{ Trace := tr;
          Memory := mem;
          Locals := locals;
          Functions := functions }>
       t_impl
       <{ iospec_k tr val_pred (mbindn vars t mret) }>) ->
      (let val_pred := val_pred in
       c = false ->
       <{ Trace := tr;
          Memory := mem;
          Locals := locals;
          Functions := functions }>
       f_impl
       <{ iospec_k tr val_pred (mbindn vars f mret) }>) ->
      (forall a mem locals,
         IO.Valid v a ->
         val_pred a.(val) mem locals ->
         let tr := List.map trace_entry_of_event a.(trace) ++ tr in
       <{ Trace := tr;
          Memory := mem;
          Locals := locals;
          Functions := functions }>
       k_impl
       <{ iospec_k tr pred (k a.(val)) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq
        (cmd.cond c_expr t_impl f_impl)
        k_impl
      <{ iospec_k tr pred (mbindn vars v k) }>.
  Proof.
    intros * Hc Ht Hf Hk.
    repeat straightline.
    split_if ltac:(repeat straightline'); subst_lets_in_goal.
    eassumption.
    all: rewrite word.unsigned_b2w; cbv [Z.b2z].
    all: destruct_one_match; try congruence; [ ]; intros.
    all: eapply compile_seq; [ (eapply Ht + eapply Hf); reflexivity | ].
    all: intros * (out & Hvalid & <- & Hpred); rewrite mbindn_mret in Hvalid.
    all: eapply WeakestPrecondition_iospec_k_bindn; intros;
      try eapply Hk; eauto.
  Qed.
End with_parameters.

Ltac compile_if tr0 :=
  let vp := infer_val_predicate in
  eapply compile_if with (val_pred := fun args => vp args tr0).

#[export] Hint Extern 1
 (WeakestPrecondition.cmd _ _ ?tr0 _ _ (_ (mbindn _ (if _ then _ else _) _))) =>
  compile_if tr0; shelve : compiler.

#[export] Hint Resolve compile_setup_iospec_k : compiler_setup_post.
#[export] Hint Extern 1 (IO.Valid (mret _) _) => eapply IO.ValidPure : compiler_side_conditions.
#[export] Hint Unfold iospec_k iospec iobind_spec iobind: compiler_cleanup_post.


Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Require Import util.
Require Import Le.
Require Import EqNat.
Require Import Compare_dec.
Require Import Bool.
Require Import Lt.
Require Import list_utils.
Require Import List.
Require Import Compare_dec.
Require Import monads.
Require Import monoid_monad_trans.
Require Import nat_seqs.
Require Import qs_definitions.
Require Import monoid_expec.
Require qs_parts.
Require Import sort_order.
Require Import indices.
Require Import Arith.
Require Import nat_below.
Require Vector.
Require ne_tree_monad.

Import mon_nondet.

Section contents.

  Variable (e: E) (ol: list e).

  (* todo: use:

  Inductive UnordNatPair: Set := unord_nat_pair (x y: nat): x <= y -> UnordNatPair.

  Definition mk_unord_nat_pair (x y: nat): UnordNatPair :=
    match le_lt_dec x y with
    | left p => unord_nat_pair p
    | right p => unord_nat_pair (lt_le_weak _ _ p)
    end.

  *)

  Definition monoid := ListMonoid.M (nat * nat).

  Definition M: Monad := MonoidMonadTrans.M monoid ne_tree_monad.ext.

  Lemma Mext: extMonad M.
  Proof MonoidMonadTrans.Mext monoid ne_tree_monad.ext.

  Definition unordered_nat_pair (x y: nat): nat * nat :=
    if le_lt_dec x y then (x, y) else (y, x).

  Definition cmp (x y: Index e ol): M comparison
    := ret (unordered_nat_pair x y :: nil, Ecmp e (subscript x) (subscript y)).

  Definition homo: monoidHomo monoid NatAddMonoid (fun x => length x).
  Proof with auto. apply Build_monoidHomo... simpl. intros. rewrite app_length... Qed.

  Definition pick := monoid_tree_monad.pick monoid.

  Require Import Rdefinitions.

  Lemma partition d (l: list (Index e ol)):
    partition M cmp d l =
    ne_tree.Leaf (map (fun i: Index e ol => unordered_nat_pair i d) l, simplerPartition (UE e ol) d l).
  Proof with auto. (* todo: rename *)
    induction l...
    simpl.
    rewrite (@mon_assoc (ne_tree_monad.M)).
    rewrite IHl.
    simpl.
    rewrite app_nil_r...
  Qed.

  Lemma simplePartition_component (ee: E) i cr l:
    proj1_sig (simplerPartition ee i l) cr =
      filter (fun f => unsum_bool (cmp_cmp (Ecmp ee f i) cr)) l.
  Proof with auto.
    induction l...
    simpl.
    rewrite IHl.
    destruct (Ecmp ee a i); destruct cr...
  Qed.

  Section Uqs_ind.

    Variable P: list (Index e ol) -> M (list (Index e ol)) -> Prop.
    Hypothesis Pnil: P nil (ret nil).

    Hypothesis Pcons: forall n (v: Vector.t (Index e ol) (S n)),
      (forall x0 cr, P (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) cr)) (vec.remove v x0)) (qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) cr)) (vec.remove v x0)))) ->
      P v
      (ne_tree.Node
          (ne_list.map
            (fun x0: natBelow (S n) =>
              ne_tree.map
                (map_fst (C:=list (Index e ol)) (app (map (fun i0: Index e ol => unordered_nat_pair i0 (vec.nth v x0)) (vec.remove v x0))))
                (foo <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Lt)) (vec.remove v x0));
                bar <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Gt)) (vec.remove v x0));
                ret (foo ++ (vec.nth v x0 :: filter (fun f0: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f0 (vec.nth v x0)) Eq)) (vec.remove v x0)) ++ bar)))
            (ne_list.from_vec (vec.nats 0 (S n))))).

    Theorem qs_ind: forall l, P l (qs cmp pick l).
    Proof with auto.
      apply qs_parts.rect...
        apply Mext.
      intros.
      unfold qs_parts.body.
      replace (qs_parts.selectPivotPart M pick cmp v) with (ne_tree.Node (ne_list.map (fun x0: natBelow (S n) => ne_tree.map (map_fst (app (map (fun i0: Index e ol => unordered_nat_pair i0 ((vec.nth v x0))) (vec.remove v x0)))) (
      foo <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Lt)) (vec.remove v x0));
      bar <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Gt)) (vec.remove v x0));
      ret (m:=ne_tree_monad.M) (nil, foo ++ (vec.nth v x0 :: filter (fun f0: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f0 (vec.nth v x0)) Eq)) (vec.remove v x0)) ++ bar))) (ne_list.from_vec (vec.nats 0 (S n))))).
        simpl @ret in Pcons.
        Focus 1.
        specialize (Pcons v).
        simpl vec.to_list in Pcons.
        apply Pcons. clear Pcons.
        intros.
        apply H.
        rewrite length_filter.
        apply le_lt_trans with (length (vec.to_list (vec.remove v x0))).
          apply count_le.
        rewrite vec.length...
      unfold qs_parts.selectPivotPart.
      unfold qs_parts.partitionPart.
      unfold qs_parts.lowRecPart.
      simpl.
      f_equal.
      repeat rewrite ne_list.map_map.
      apply ne_list.map_ext. intro.
      unfold compose. simpl.
      rewrite ne_tree_monad.map_bind.
      rewrite (@mon_assoc (ne_tree_monad.M)).
      rewrite partition. simpl.
      rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
      rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
      rewrite (@simplePartition_component (UE e ol)).
      apply ne_tree_monad.ext. intro.
      rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
      rewrite ne_tree_monad.map_bind.
            rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
      rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
      rewrite (@simplePartition_component (UE e ol)).
      apply ne_tree_monad.ext. intro.
      unfold compose, map_fst.
      simpl.
      rewrite (@simplePartition_component (UE e ol)).
      reflexivity.
    Qed.

  End Uqs_ind.

  Lemma UcmpDec (x y: nat * nat): { x = y } + { x <> y }.
  Proof with auto.
    intros.
    destruct x.
    destruct y.
    destruct (eq_nat_dec n n1).
      destruct (eq_nat_dec n0 n2).
        subst.
        left...
      right. intro. inversion H...
    right. intro. inversion H...
  Qed.

  Definition UcmpCmp (x y: nat * nat): bool := unsum_bool (UcmpDec x y).

  Definition ijcount (i j: nat): monoid -> nat := count (UcmpCmp (i, j)).

  Lemma ijcount_0 i j l: ~ In (i, j) l -> ijcount i j l = 0.
  Proof with auto.
    unfold ijcount.
    intros.
    apply count_0.
    intros.
    unfold UcmpCmp.
    case_eq (UcmpDec (i, j) x); intros...
    elimtype False.
    apply H.
    rewrite e0...
  Qed.

  Lemma hom_ijcount i j: monoidHomo monoid NatAddMonoid (ijcount i j).
  Proof with auto.
    unfold ijcount.
    intros.
    apply Build_monoidHomo; intros; simpl...
    apply count_app.
  Qed.

  Hint Resolve hom_ijcount.

  Lemma ijcount_eq_count i j: ijcount i j = eq_count UcmpDec (i, j).
  Proof. auto. Qed.

  Definition qs: list (Index e ol) -> M (list (Index e ol)) := qs cmp pick.

End contents.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** Type inference for NRA when given the type of the input *)

Require Import String.
Require Import List.
Require Import Compare_dec.
Require Import Eqdep_dec.
Require Import Bool.
Require Import EquivDec.
Require Import Utils.
Require Import DataSystem.
Require Import cNRAEnv.
Require Import TcNRAEnv.
Require Import Program.
Require Import TNRAInfer. (* Only for a few auxiliary Lemmas that should probably be moved *)

Section TcNRAEnvInfer.
  (* Type inference for algebraic expressions *)

  Context {m:basic_model}.
  Context (τconstants:list (string*rtype)).

  Fixpoint infer_nraenv_core_type (e:nraenv_core) (τenv τin:rtype) : option rtype :=
    match e with
    | cNRAEnvGetConstant s =>
      tdot τconstants s
    | cNRAEnvID => Some τin
    | cNRAEnvConst d => infer_data_type (normalize_data brand_relation_brands d)
    | cNRAEnvBinop b op1 op2 =>
      let binf (τ₁ τ₂:rtype) := infer_binary_op_type b τ₁ τ₂ in
      olift2 binf (infer_nraenv_core_type op1 τenv τin) (infer_nraenv_core_type op2 τenv τin)
    | cNRAEnvUnop u op1 =>
      let unf (τ₁:rtype) := infer_unary_op_type u τ₁ in
      olift unf (infer_nraenv_core_type op1 τenv τin)
    | cNRAEnvMap op1 op2 =>
      let mapf (τ₁:rtype) :=
          olift (fun x => lift (fun y => Coll y) (infer_nraenv_core_type op1 τenv x)) (tuncoll τ₁)
      in
      olift mapf (infer_nraenv_core_type op2 τenv τin)
    | cNRAEnvMapProduct op1 op2 =>
      let mapconcatf (τ₁:list (string*rtype)) :=
          match RecMaybe Closed τ₁ with
          | None => None
          | Some τr₁ =>
            match olift (tmapConcatOutput τ₁) (infer_nraenv_core_type op1 τenv τr₁) with
            | None => None
            | Some τ₂ => Some (Coll τ₂)
            end
          end
      in
      olift mapconcatf (olift tmapConcatInput (infer_nraenv_core_type op2 τenv τin))
    | cNRAEnvProduct op1 op2 =>
      let mapconcatf (τ₁:list (string*rtype)) :=
          match RecMaybe Closed τ₁ with
          | None => None
          | Some τr₁ =>
            match olift (tmapConcatOutput τ₁) (infer_nraenv_core_type op2 τenv τin) with
            | None => None
            | Some τ₂ => Some (Coll τ₂)
            end
          end
      in
      olift mapconcatf (olift tmapConcatInput (infer_nraenv_core_type op1 τenv τin))
    | cNRAEnvSelect op1 op2 =>
      let selectf (τ₁:rtype) :=
          match tuncoll τ₁ with
          | Some τ₁' =>
            match infer_nraenv_core_type op1 τenv τ₁' with
            | Some τ₂ =>
              match `τ₂ with
              | Bool₀ => Some (Coll τ₁')
              | _ => None
              end
            | None => None
            end
          | None => None
          end
      in
      olift selectf (infer_nraenv_core_type op2 τenv τin)
    | cNRAEnvDefault op1 op2 =>
      match ((infer_nraenv_core_type op1 τenv τin), (infer_nraenv_core_type op2 τenv τin)) with
      | (Some τ₁', Some τ₂') =>
        match (tuncoll τ₁', tuncoll τ₂') with
        | (Some τ₁₀, Some τ₂₀) =>
          if (`τ₁₀ == `τ₂₀) then Some τ₁' else None
        | _ => None
        end
      | (_, _) => None
      end
    | cNRAEnvEither op1 op2 =>
      match tuneither τin with
      | Some (τl, τr) =>
        match ((infer_nraenv_core_type op1 τenv τl), (infer_nraenv_core_type op2 τenv τr)) with
        | (Some τ₁', Some τ₂') =>
          if (rtype_eq_dec τ₁' τ₂') (* Probably should be generalized using join... *)
          then Some τ₁'
          else None
        | (_, _) => None
        end
      | _ => None
      end
    | cNRAEnvEitherConcat op1 op2 =>
      match (infer_nraenv_core_type op1 τenv τin, infer_nraenv_core_type op2 τenv τin) with
      | (Some τeither, Some τrecplus) =>
        match tuneither τeither with
        | Some (τl, τr) =>
          match (trecConcat τl τrecplus, trecConcat τr τrecplus) with
          | (Some τrecl, Some τrecr) =>
            Some (Either τrecl τrecr)
          | (_, _) => None
          end
        | None => None
        end
      | (_, _) => None
      end
    | cNRAEnvApp op1 op2 =>
      let appf (τ₁:rtype) := infer_nraenv_core_type op1 τenv τ₁ in
      olift appf (infer_nraenv_core_type op2 τenv τin)
    | cNRAEnvEnv =>
      Some τenv
    | cNRAEnvAppEnv op1 op2 =>
      let appf (τ₁:rtype) := infer_nraenv_core_type op1 τ₁ τin in
      olift appf (infer_nraenv_core_type op2 τenv τin)
    | cNRAEnvMapEnv op1 =>
      let mapf (τenv':rtype) :=
          lift Coll (infer_nraenv_core_type op1 τenv' τin)
      in
      olift mapf (tuncoll τenv)
    end.

  Lemma infer_nraenv_core_type_correct (τenv τin τout:rtype) (e:nraenv_core) :
    infer_nraenv_core_type e τenv τin = Some τout ->
    nraenv_core_type τconstants e τenv τin τout.
  Proof.
    intros.
    revert τenv τin τout H.
    nraenv_core_cases (induction e) Case; intros; simpl in H.
    - Case "cNRAEnvGetConstant"%string.
      apply type_cNRAEnvGetConstant; assumption.
    - Case "cNRAEnvID"%string.
      inversion H; clear H.
      apply type_cNRAEnvID.
    - Case "cNRAEnvConst"%string.
      apply type_cNRAEnvConst.
      apply infer_data_type_correct. assumption.
    - Case "cNRAEnvBinop"%string.
      specialize (IHe1 τenv τin); specialize (IHe2 τenv τin).
      destruct (infer_nraenv_core_type e1 τenv τin);
        destruct (infer_nraenv_core_type e2 τenv τin); simpl in *;
      try discriminate.
      specialize (IHe1 r eq_refl); specialize (IHe2 r0 eq_refl).
      apply (@type_cNRAEnvBinop m τconstants τenv τin r r0 τout); try assumption.
      apply infer_binary_op_type_correct; assumption.
    - Case "cNRAEnvUnop"%string.
      specialize (IHe τenv τin).
      destruct (infer_nraenv_core_type e τenv τin); simpl in *;
      try discriminate.
      specialize (IHe r eq_refl).
      apply (@type_cNRAEnvUnop m τconstants τenv τin r τout); try assumption.
      apply infer_unary_op_type_correct; assumption.
    - Case "cNRAEnvMap"%string.
      case_eq (infer_nraenv_core_type e2 τenv τin); intros; simpl in *.
      + specialize (IHe2 τenv τin r H0). rewrite H0 in H. simpl in *.
        unfold lift in H.
        case_eq (tuncoll r); intros. rewrite H1 in *.
        inversion H. subst. clear H H0.
        case_eq (infer_nraenv_core_type e1 τenv r0); intros.
        specialize (IHe1 τenv r0 r1 H).
        rewrite H in H3.
        inversion H3.
        apply (@type_cNRAEnvMap m τconstants τenv τin r0 r1); try assumption.
        apply tuncoll_correct in H1.
        rewrite <- H1; assumption.
        rewrite H in H3; congruence.
        rewrite H1 in H; simpl in H; congruence.
      + rewrite H0 in H. simpl in H; congruence.
    - Case "cNRAEnvMapProduct"%string.
      case_eq (infer_nraenv_core_type e2 τenv τin); intros.
      + specialize (IHe2 τenv τin r H0). rewrite H0 in H; simpl in *.
        unfold tmapConcatInput in H.
        destruct r; try congruence.
        destruct x; simpl in H; try congruence.
        destruct x; simpl in H; try congruence.
        clear H0.
        destruct k; simpl in H; [congruence| ].
        destruct (from_Rec₀ srl e) as [l1' [pf1' [eq11 eq12]]].
        assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ (Rec₀ Closed srl)) e =
                Coll (Rec Closed l1' pf1')) by (rewrite eq12; apply rtype_fequal; reflexivity).
        rewrite H0 in IHe2; clear H0.
        simpl in H; clear eq12 eq11 e.
        assert (RecMaybe Closed l1' = Some (Rec Closed l1' pf1')) by apply RecMaybe_pf_some.
        rewrite H0 in H; clear H0.
        case_eq (infer_nraenv_core_type e1 τenv (Rec Closed l1' pf1')); intros.
        * rewrite H0 in H; simpl in H.
          destruct r; try congruence.
          destruct x; simpl in H; try congruence.
          destruct x; simpl in H; try congruence.
          destruct k; simpl in H; try congruence.
          destruct (from_Rec₀ srl0 e) as [l2' [pf2' [eq21 eq22]]].
          assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ (Rec₀ Closed srl0)) e =
                  Coll (Rec Closed l2' pf2')) by (rewrite eq22; apply rtype_fequal; reflexivity).
          rewrite H1 in *.
          specialize (IHe1 τenv (Rec Closed l1' pf1') (Coll (Rec Closed l2' pf2')) H0).
          assert (is_list_sorted ODT_lt_dec
                                 (domain (rec_concat_sort l1' l2')) = true)
            by (apply (rec_concat_sort_sorted l1' l2'); reflexivity).
          assert (RecMaybe Closed (rec_concat_sort l1' l2') = Some (Rec Closed (rec_concat_sort l1' l2') H2))
            by apply RecMaybe_pf_some.
          simpl in H.
          clear e eq22 H1 eq21 srl0 H0.
          generalize (@type_cNRAEnvMapProduct m τconstants τenv τin l1' l2' (rec_concat_sort l1' l2')
                                   e1 e2 pf1' pf2' H2 IHe1 IHe2 eq_refl); intros.
          assert (τout = (Coll (Rec Closed (rec_concat_sort l1' l2') H2))).
          assert ((@RecMaybe (@basic_model_foreign_type m)
            (@brand_model_relation (@basic_model_foreign_type m)
               (@basic_model_brand_model m)) Closed
            (@rec_concat_sort string ODT_string
               (@sig (@rtype₀ (@basic_model_foreign_type m))
                  (fun τ₀ : @rtype₀ (@basic_model_foreign_type m) =>
                   @eq bool
                     (@wf_rtype₀ (@basic_model_foreign_type m)
                        (@brand_model_relation
                           (@basic_model_foreign_type m)
                           (@basic_model_brand_model m)) τ₀) true)) l1'
               l2')) =
           (@RecMaybe (@basic_model_foreign_type m)
            (@brand_model_relation (@basic_model_foreign_type m)
               (@basic_model_brand_model m)) Closed
            (@rec_concat_sort string ODT_string
               (@rtype (@basic_model_foreign_type m)
                  (@brand_model_relation (@basic_model_foreign_type m)
                                         (@basic_model_brand_model m))) l1' l2')))
            by reflexivity.
          rewrite <- H1 in H.
          destruct (RecMaybe Closed (rec_concat_sort l1' l2')).
          inversion H.
          rewrite H5.
          inversion H3.
          rewrite <- H5.
          rewrite H6; reflexivity.
          congruence.
          rewrite H1.
          assumption.
        * rewrite H0 in H; simpl in H; congruence.
      + rewrite H0 in H; simpl in H; congruence.
    - Case "cNRAEnvProduct"%string.
      case_eq (infer_nraenv_core_type e1 τenv τin); intros.
      case_eq (infer_nraenv_core_type e2 τenv τin); intros.
      + specialize (IHe1 τenv τin r H0). rewrite H0 in H; simpl in *.
        unfold tmapConcatInput in H.
        destruct r; try congruence.
        destruct x; simpl in H; try congruence.
        destruct x; simpl in H; try congruence.
        destruct k; simpl in H; try congruence.
        clear H0.
        rewrite H1 in H; simpl in H.
        destruct (from_Rec₀ srl e) as [l1' [pf1' [eq11 eq12]]].
        assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ (Rec₀ Closed srl)) e =
                Coll (Rec Closed l1' pf1')) by (rewrite eq12; apply rtype_fequal; reflexivity).
        rewrite H0 in IHe1; clear H0.
        simpl in H; clear eq12 eq11 e.
        assert (RecMaybe Closed l1' = Some (Rec Closed l1' pf1')) by apply RecMaybe_pf_some.
        rewrite H0 in H; clear H0.
        destruct r0; try congruence.
        destruct x; simpl in H; try congruence.
        destruct x; simpl in H; try congruence.
        destruct k; simpl in H; try congruence.
        destruct (from_Rec₀ srl0 e) as [l2' [pf2' [eq21 eq22]]].
        assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ (Rec₀ Closed srl0)) e =
                Coll (Rec Closed l2' pf2')) by (rewrite eq22; apply rtype_fequal; reflexivity).
        rewrite H0 in *.
        specialize (IHe2 τenv τin (Coll (Rec Closed l2' pf2')) H1).
        assert (is_list_sorted ODT_lt_dec
                               (domain (rec_concat_sort l1' l2')) = true)
          by (apply (rec_concat_sort_sorted l1' l2'); reflexivity).
        assert (RecMaybe Closed (rec_concat_sort l1' l2') = Some (Rec Closed (rec_concat_sort l1' l2') H2))
          by apply RecMaybe_pf_some.
        clear e eq22 H1 eq21 srl0 H0.
        generalize (@type_cNRAEnvProduct m τconstants τenv τin l1' l2' (rec_concat_sort l1' l2')
                               e1 e2 pf1' pf2' H2 IHe1 IHe2 eq_refl); intros.
        assert (τout = (Coll (Rec Closed (rec_concat_sort l1' l2') H2))).
        assert (τout = (Coll (Rec Closed (rec_concat_sort l1' l2') H2))).
          assert ((@RecMaybe (@basic_model_foreign_type m)
            (@brand_model_relation (@basic_model_foreign_type m)
               (@basic_model_brand_model m)) Closed
            (@rec_concat_sort string ODT_string
               (@sig (@rtype₀ (@basic_model_foreign_type m))
                  (fun τ₀ : @rtype₀ (@basic_model_foreign_type m) =>
                   @eq bool
                     (@wf_rtype₀ (@basic_model_foreign_type m)
                        (@brand_model_relation
                           (@basic_model_foreign_type m)
                           (@basic_model_brand_model m)) τ₀) true)) l1'
               l2')) =
           (@RecMaybe (@basic_model_foreign_type m)
            (@brand_model_relation (@basic_model_foreign_type m)
               (@basic_model_brand_model m)) Closed
            (@rec_concat_sort string ODT_string
               (@rtype (@basic_model_foreign_type m)
                       (@brand_model_relation (@basic_model_foreign_type m)
                                              (@basic_model_brand_model m))) l1' l2')))
          by reflexivity.
          rewrite <- H1 in H.
        destruct (RecMaybe Closed (rec_concat_sort l1' l2')).
        inversion H.
        rewrite H5 in *.
        inversion H3.
        rewrite <- H6.
        auto.
        congruence.
        assumption.
        rewrite H1.
        auto.
      + rewrite H1 in H. simpl in H.
        destruct ((olift tmapConcatInput (infer_nraenv_core_type e1 τenv τin))); simpl in H.
        destruct (RecMaybe Closed l); congruence.
        congruence.
      + rewrite H0 in H; simpl in H; congruence.
    - Case "cNRAEnvSelect"%string.
      simpl.
      case_eq (infer_nraenv_core_type e2 τenv τin); intros; simpl in *.
      + specialize (IHe2 τenv τin r H0). rewrite H0 in H. simpl in *.
        unfold lift in H.
        case_eq (tuncoll r); intros. rewrite H1 in *.
        inversion H. subst. clear H H0.
        case_eq (infer_nraenv_core_type e1 τenv r0); intros.
        specialize (IHe1 τenv r0 r1 H).
        rewrite H in H3.
        destruct r1; try congruence; simpl in *.
        destruct x; try congruence; simpl in *.
        inversion H3; clear H3 H2.
        apply (@type_cNRAEnvSelect m τconstants τenv τin r0); try assumption.
        assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) Bool₀ e = Bool).
        apply rtype_fequal; reflexivity.
        rewrite H0 in IHe1. assumption.
        apply tuncoll_correct in H1.
        rewrite <- H1; assumption.
        rewrite H in H3; congruence.
        rewrite H1 in H; congruence.
      + rewrite H0 in H. simpl in H; congruence.
    - Case "cNRAEnvDefault"%string.
      specialize (IHe1 τenv τin); specialize (IHe2 τenv τin).
      destruct (infer_nraenv_core_type e1 τenv τin); destruct (infer_nraenv_core_type e2 τenv τin); simpl in *;
      try discriminate.
      specialize (IHe1 r eq_refl); specialize (IHe2 r0 eq_refl).
      case_eq r; case_eq r0;intros; subst; simpl in *.
      destruct x; destruct x0; try (subst; discriminate); simpl in *.
      destruct (equiv_dec x0 x); try congruence.
      inversion H; clear H.
      assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ x0) e0 = exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ x) e).
      apply rtype_fequal; simpl. subst. rewrite e3; reflexivity.
      rewrite H in *; clear H1 H e3 x0 e0 τout.
      assert (exists τ, Coll τ = exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) (Coll₀ x) e).
      exists (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true) x e).
      apply rtype_fequal; simpl; reflexivity.
      elim H; clear H; intros.
      rewrite <- H in *.
      apply type_cNRAEnvDefault; assumption.
    - Case "cNRAEnvEither"%string.
      unfold tuneither in H.
      destruct τin.
      destruct x; simpl in *; try discriminate.
      match_case_in H; intros; rewrite H0 in H; try discriminate.
      match_case_in H; intros; rewrite H1 in H; try discriminate.
      match_destr_in H.
      red in e0.
      invcs H; subst.
      specialize (IHe1 _ _ _ H0).
      specialize (IHe2 _ _ _ H1).
      erewrite Either_canon
      ; eapply type_cNRAEnvEither
      ; eauto.
    - Case "cNRAEnvEitherConcat"%string.
      case_eq (infer_nraenv_core_type e1 τenv τin); case_eq (infer_nraenv_core_type e2 τenv τin); simpl in *; intros;
      rewrite H0 in *; rewrite H1 in *; try discriminate.
      unfold tuneither in H.
      destruct r0; simpl in H.
      destruct x; simpl in H; try discriminate.
      destruct x1; simpl in H; try discriminate.
      destruct r; simpl in H; try discriminate.
      destruct x; simpl in H; try discriminate.
      match goal with
      | [H:context [from_Rec₀ _ ?x] |- _ ] => revert H; generalize x;
                                                let pff := fresh "pf" in
                                                intros pff H
      end.
      destruct k; simpl in H; try discriminate
      ; destruct k0; simpl in H; try (destruct (from_Rec₀ srl pf); destruct (from_Rec₀ srl0 e0); simpl in H; try discriminate).
      rewrite @RecMaybe_rec_concat_sort in H.
      destruct x2; simpl in H; try discriminate.
      match goal with
      | [H:context [from_Rec₀ _ ?x] |- _ ] => revert H; generalize x;
                                                let pff := fresh "pf" in
                                                intros pff H
      end.
      destruct k; simpl in H; try discriminate
      ; [ destruct (from_Rec₀ srl1 pf0); try discriminate | ].
      case_eq (from_Rec₀ (k:=Closed) srl1 pf0); intros.
      rewrite H2 in H.
      rewrite @RecMaybe_rec_concat_sort in H.
      invcs H.
      specialize (IHe1 _ _ _ H1).
      specialize (IHe2 _ _ _ H0).
      destruct e3 as [? [??]].
      destruct e4 as [? [??]].
      destruct e5 as [? [??]].
      subst.
      destruct (Either_canon_ex _ _ e) as [pfl [pfr eqq]].
      rewrite eqq in IHe1.
      clear eqq.
      destruct (to_Rec _ _ pfl) as [? eqq1].
      destruct (to_Rec _ _ pfr) as [? eqq2].
      rewrite eqq1, eqq2 in IHe1.
      destruct (to_Rec _ _ e0) as [? eqq3].
      rewrite eqq3 in IHe2.
      eapply type_cNRAEnvEitherConcat; eauto.
    - Case "cNRAEnvApp"%string.
      specialize (IHe2 τenv τin).
      destruct (infer_nraenv_core_type e2 τenv τin).
      specialize (IHe2 r eq_refl).
      econstructor; eauto.
      simpl in *; congruence.
    - Case "cNRAEnvEnv"%string.
      inversion H; apply type_cNRAEnvEnv.
    - Case "cNRAEnvAppEnv"%string.
      specialize (IHe2 τenv τin).
      destruct (infer_nraenv_core_type e2 τenv τin).
      simpl in H.
      specialize (IHe2 r eq_refl).
      specialize (IHe1 r τin τout).
      econstructor; eauto.
      econstructor; eauto.
      simpl in *; congruence.
    - Case "cNRAEnvMapEnv"%string.
      case_eq (tuncoll τenv); intros.
      + apply tuncoll_correct in H0.
        subst.
        simpl in H.
        assert (exist (fun τ₀ : rtype₀ => wf_rtype₀ τ₀ = true)
                      (` r) (proj2_sig r) = r) by (apply rtype_fequal; reflexivity).
        rewrite H0 in H; clear H0.
        case_eq (infer_nraenv_core_type e r τin); intros; simpl in *.
        * unfold lift in H.
          rewrite H0 in H; simpl in H.
          inversion H. subst; clear H.
          specialize (IHe r τin r0 H0).
          apply (@type_cNRAEnvMapEnv m τconstants r τin r0 e IHe).
        * rewrite H0 in H; simpl in H; congruence.
      + rewrite H0 in H; simpl in H; congruence.
  Qed.

  (* Still should try and prove most specific and completeness theorems ... *)

End TcNRAEnvInfer.


(** * Definition of Context Free Grammars *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Import Fiat.Common.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} (G : grammar Char).

  Context (ch : Char) (valid : nonterminals_listT).

  (** Relation defining if a character is reachable *)
  Inductive reachable_from_productions : productions Char -> Type :=
  | ReachableHead : forall pat pats, reachable_from_production pat
                                     -> reachable_from_productions (pat::pats)
  | ReachableTail : forall pat pats, reachable_from_productions pats
                                     -> reachable_from_productions (pat::pats)
  with reachable_from_production : production Char -> Type :=
  | ReachableProductionHead : forall it its, maybe_empty_production G valid its
                                             -> reachable_from_item it
                                             -> reachable_from_production (it::its)
  | ReachableProductionTail : forall it its, reachable_from_production its
                                             -> reachable_from_production (it::its)
  with reachable_from_item : item Char -> Type :=
  | ReachableTerminal : forall P, is_true (P ch) -> reachable_from_item (Terminal P)
  | ReachableNonTerminal : forall nt, is_valid_nonterminal valid (of_nonterminal nt)
                                      -> reachable_from_productions (Lookup G nt)
                                      -> reachable_from_item (NonTerminal nt).
End cfg.


(** * SLOT model checker *)
From LibTx Require Import
     FoldIn
     Misc
     EventTrace
     Permutation
     SLOT.Zipper
     SLOT.Hoare
     SLOT.Ensemble
     SLOT.Generator.

From Coq Require Import
     List
     Program
     Logic.Classical_Prop
     Logic.Decidable
     Relations
     Lia.

Import ListNotations.

From Coq Require
     Vector
     Fin.

From Hammer Require Import
     Tactics.

Module Z := Zipper.

Module Vec := Vector.

Open Scope list_scope.
Open Scope hoare_scope.
Open Scope zipper_scope.

Lemma trace_elems_commute_dec `{StateSpace} a b : decidable (trace_elems_commute a b).
Proof.
  apply classic.
Qed.

Section comm_rel.
  Class te_commut_rel {A} :=
    { comm_rel : relation A;
      comm_rel_symm : symmetric _ comm_rel;
      comm_rel_dec : forall a b, decidable (comm_rel a b);
    }.

  Definition always_can_switch {A} (_ _ : A) : Prop := True.

  Program Instance nonCommRel `{StateSpace} : @te_commut_rel TE :=
    { comm_rel a b := not (trace_elems_commute a b)
    }.
  Next Obligation.
  unfold symmetric. intros x y Hcomm.
  firstorder. Qed.
  Next Obligation.
  unfold decidable. apply classic. Qed.

  Program Instance alwaysCommRel {TE} : @te_commut_rel TE :=
    { comm_rel := always_can_switch;
    }.
  Next Obligation.
  easy. Qed.
  Next Obligation.
  cbv. left. easy. Qed.
End comm_rel.

Module ZipIlv.
  Section defn.
    Context `{Hssp : StateSpace} (Hcomm_rel : @te_commut_rel TE).

    Let T := list TE.
    Let TT := list T.

    Definition Traces := Z.t T.

    Definition clean (l : T) := match l with
                                | [] => None
                                | _  => Some l
                                end.

    Inductive MInt_ : Traces -> @TraceEnsemble TE :=
    | mint_nil :
        MInt_ ([], None, []) []
    | mint_cons : forall te rest l r t,
        MInt_ (l, clean rest, r) t ->
        MInt_ (l, Some (te :: rest), r) (te :: t)
    | mint_cons_l : forall te rest l r zipper t,
        zipper >z (l, clean rest, r) ->
        MInt_ zipper t ->
        MInt_ (l, Some (te :: rest), r) (te :: t)
    | mint_cons_r : forall te te' rest l r zipper t,
        zipper <z (l, clean rest, r)->
        comm_rel te te' ->
        MInt_ zipper (te' :: t) ->
        MInt_ (l, Some (te :: rest), r) (te :: te' :: t).

    Inductive MInt tt : @TraceEnsemble TE :=
      mint : forall z t,
        Z.zipper_of z tt ->
        MInt_ z t ->
        MInt tt t.
  End defn.

  Section tests.
    Context `{Hssp : StateSpace} (Hcomm_rel : @te_commut_rel TE).

    Ltac inv H := inversion_ H; clear H.

    Goal forall a b,
        MInt Hcomm_rel [[a]; [b]] [a; b] /\
        (comm_rel a b -> MInt Hcomm_rel [[a]; [b]] [b; a]).
    Proof.
      split.
      { apply mint with (z := ([], Some [a], [[b]])).
        { constructor. }
        apply mint_cons_l with (zipper := ([], Some [b], [])); repeat constructor.
      }
      { intros Hcomm.
        apply mint with (z := ([[a]], Some [b], [])).
        { repeat constructor. }
        apply mint_cons_r with (zipper := ([], Some [a], [])); repeat constructor.
        now apply comm_rel_symm.
      }
    Qed.

    Goal forall a b t,
        ~comm_rel a b ->
        MInt Hcomm_rel [[a]; [b]] t ->
        t = [a; b].
      intros a b t Hcomm H. destruct H. cbv in H.
      inv H.
      - inv H0.
        + inv H5.
        + inv H5. inv H6.
          * inversion H4. subst. reflexivity.
          * exfalso. inv H4.
          * exfalso. inv H4.
        + exfalso. inv H5.
      - inv H3.
        inv H0.
        + exfalso. inv H5.
        + exfalso. inv H5.
        + inv H5. inv H7;
          apply comm_rel_symm in H6; contradiction.
    Qed.

    Goal forall a b t,
        comm_rel a b ->
        MInt Hcomm_rel [[a]; [b]] t ->
        t = [a; b] \/ t = [b; a].
      intros a b t Hcomm H. destruct H. cbv in H.
      inv H.
      - inv H0.
        + inv H5.
        + inv H5. inv H6.
          * inversion H4. subst. left. reflexivity.
          * exfalso. inv H4.
          * exfalso. inv H4.
        + exfalso. inv H5.
      - inv H3.
        inv H0.
        + exfalso. inv H5.
        + exfalso. inv H5.
        + inv H5. inv H7.
          * inversion H0. subst. right. reflexivity.
          * exfalso. inv H1.
          * exfalso. inv H2.
    Qed.
  End tests.

  Section prune_interleavings.
    Context `{Hssp : StateSpace}.

    Lemma left_of_self {A} (z1 z2 : Z.t A) :
            z1 >z z2 ->
            Z.zipper_of z1 (Z.to_list z2).
    Admitted.

    Lemma right_of_self {A} (z1 z2 : Z.t A) :
            z1 <z z2 ->
            Z.zipper_of z1 (Z.to_list z2).
    Admitted.

    Fixpoint mint_add z l m r te t
             (Hz : Z.zipper_of z (Z.to_list (l, clean m, r)))
             (Ht : MInt_ nonCommRel z t) {struct Ht} :
      exists t', exists z',
          Z.zipper_of z'(Z.to_list (l, Some (te :: m), r)) /\
          MInt_ nonCommRel z' t' /\
          Permutation trace_elems_commute (te :: t) t'.
    Proof.
      inversion_ Ht; clear Ht.
      { exists []. exists ([], None, []). sauto. }
      { apply mint_add with (l := l0) (m := rest) (r := r0) (te := te) in H.
        2:{ apply Z.left_eq_self. }
    Admitted.

    Lemma zipper_of_trans {A} (l : list A) z1 z2 :
        Z.zipper_of z1 l ->
        Z.zipper_of z2 (Z.to_list z1) ->
        Z.zipper_of z2 l.
    Admitted.

    Fixpoint mint_prune0 traces zipper t
             (Hz : Z.zipper_of zipper traces)
             (Ht : MInt_ alwaysCommRel zipper t) {struct Ht} :
      exists t', exists zipper',
                Z.zipper_of zipper' traces /\
                MInt_ nonCommRel zipper' t' /\
                Permutation trace_elems_commute t t'.
    Proof.
      destruct Ht as [
                     |te rest l r t Ht
                     |te rest l r zipper' t Hz' Ht
                     |te te' rest l r zipper' t Hz' Hcomm Ht
                     ].
      { exists []. sauto. }
      { apply mint_prune0 with (traces := Z.to_list (l, clean rest, r)) in Ht.
        2:{ now apply Z.left_eq_self. }
        destruct Ht as [t' [z' [Hz' [Ht' Htt']]]].
        apply mint_add with (te := te) (t := t') in Hz'; trivial.
        destruct Hz' as [t'' [z'' [Hz'' [Ht'' Ht't'']]]].
        exists t''. exists z''. repeat split; auto.
        - eapply zipper_of_trans; eauto.
        - apply permut_cons with (a := te) in Htt'.
          eapply permut_trans; eauto.
      }
      { apply mint_prune0 with (traces := Z.to_list (l, clean rest, r)) in Ht.
        2:{ now apply left_of_self. }
        destruct Ht as [t' [z' [Hz_ [Ht' Htt']]]].
        apply mint_add with (te := te) (t := t') in Hz_; trivial.
        destruct Hz_ as [t'' [z'' [Hz'' [Ht'' Ht't'']]]].
        exists t''. exists z''. repeat split; auto.
        - eapply zipper_of_trans; eauto.
        - apply permut_cons with (a := te) in Htt'.
          eapply permut_trans; eauto.
      }
      { apply mint_prune0 with (traces := Z.to_list (l, clean rest, r)) in Ht.
        2:{ now apply right_of_self. }
        destruct Ht as [t' [z' [Hz_ [Ht' Htt']]]].
        apply mint_add with (te := te) (t := t') in Hz_; trivial.
        destruct Hz_ as [t'' [z'' [Hz'' [Ht'' Ht't'']]]].
        exists t''. exists z''. repeat split; auto.
        - eapply zipper_of_trans; eauto.
        - apply permut_cons with (a := te) in Htt'.
          eapply permut_trans; eauto.
      }
    Qed.

    Lemma mint_prune traces t
             (Ht : MInt alwaysCommRel traces t) :
      exists t',
        MInt nonCommRel traces t' /\
        Permutation trace_elems_commute t t'.
    Proof with trivial.
      destruct Ht as [zipper t Hz Ht].
      eapply mint_prune0 in Ht; eauto.
      destruct Ht as [t' [z' [Hz' [Ht Htt']]]].
      exists t'. split.
      - apply mint with (z := z'); auto.
      - assumption.
    Qed.

    Theorem mint_noncomm_sufficient : forall traces,
        sufficient_replacement_p (MInt alwaysCommRel traces) (MInt nonCommRel traces).
    Proof.
      intros traces t Ht.
      now apply mint_prune in Ht.
    Qed.
  End prune_interleavings.
End ZipIlv.

Module VecIlv.
  Open Scope vector_scope.

  Section defn.
    Context `{Hssp : StateSpace} (Hcomm_rel : @te_commut_rel TE).

    Let T := list TE.
    Let TT := list T.

    Definition Traces := Vec.t T.

    Definition vec_append {N} i te (vec : Vec.t (list TE) N) :=
      let rest := Vec.nth vec i in
      Vec.replace vec i (te :: rest).

    Inductive MInt Nelems : forall (start : Fin.t Nelems), Traces Nelems -> @TraceEnsemble TE :=
    | mint_nil : forall i,
        MInt Nelems i (vec_same Nelems []) []
    | mint_cons1 : forall (i j : Fin.t Nelems) vec te t,
        i <= j ->
        MInt Nelems j vec t ->
        MInt Nelems i (vec_append i te vec) (te :: t)
    | mint_cons2 : forall (i j : Fin.t Nelems) vec te_i te_j t,
        j < i ->
        comm_rel te_i te_j ->
        MInt Nelems j vec (te_j :: t) ->
        MInt Nelems i (vec_append i te_i vec) (te_i :: te_j :: t).

    Definition MInt_ (tt : TT) : @TraceEnsemble TE :=
      fun t => exists i, MInt (length tt) i (Vec.of_list tt) t.
  End defn.

  Section prune_interleavings.
    Context `{Hssp : StateSpace}.

    Lemma vec_append_swap {N} (i j : Fin.t N) vec (te_i te_j : TE) :
      i <> j ->
      vec_append j te_j (vec_append i te_i vec) = vec_append i te_i (vec_append j te_j vec).
    Admitted.

    Ltac swap_vec_append := rewrite vec_append_swap; [|intros nonsense; subst; lia].

    Fixpoint mint_add0 {N} (i k : Fin.t N) te_i te' t0 vec
             (Ht : MInt nonCommRel N k vec (te' :: t0))
             (Hik : k < i)
             (Hcomm0 : trace_elems_commute te_i te')
             {struct Ht} :
      exists t' : list TE,
          MInt nonCommRel N k (vec_append i te_i vec) (te' :: t') /\
          Permutation trace_elems_commute (te_i :: te' :: t0) (te' :: t').
    Proof with eauto.
      (* Welcome to the hell proof! *)
      remember (te' :: t0) as t_.
      destruct Ht as [k
                     |k j vec te_k t Hij Ht
                     |k j vec te_k te_j t Hij Hcomm Ht
                     ];
        [discriminate
        |replace te' with te_k in * by congruence; clear Heqt_..
        ].
      2:{ destruct (trace_elems_commute_dec te_i te_j).
          - apply mint_add0 with (te_i := te_i) (i := i) in Ht; [|lia|assumption].
            destruct Ht as [t' [Ht' Hperm']].
            exists (te_j :: t'). split.
            + swap_vec_append.
              eapply mint_cons2...
            + apply permut_cons with (a := te_k) in Hperm'.
              eapply permut_trans...
              now apply permut_head'.
          - exists (te_i :: te_j :: t). split.
            + swap_vec_append.
              apply mint_cons1 with (j0 := i); [lia|].
              apply mint_cons2 with (j0 := j); [lia|auto..].
            + now apply permut_head'.
      }
      { inversion_ Ht.
        - exists [te_i]. split.
          + swap_vec_append.
            apply mint_cons1 with (j0 := i); [lia|].
            apply mint_cons1 with (j0 := i); [lia|].
            constructor.
          + now apply permut_head'.
        - rename te into te_j.
          destruct (PeanoNat.Nat.lt_ge_cases j i).
          2:{ exists (te_i :: te_j :: t1). split.
              - swap_vec_append.
                apply mint_cons1 with (j1 := i); [lia|].
                apply mint_cons1 with (j1 := j); [lia|assumption].
              - now apply permut_head'.
          }
          { destruct (trace_elems_commute_dec te_i te_j) as [Hte_ij|Hte_ij].
            - apply mint_add0 with (i := i) (te_i := te_i) in Ht; [|lia|assumption].
              destruct Ht as [t' [Ht' Hperm']].
              exists (te_j :: t'). split.
              + swap_vec_append.
                eapply mint_cons1...
              + apply permut_cons with (a := te_k) in Hperm'.
                now apply permut_head.
            - exists (te_i :: te_j :: t1). split.
              + swap_vec_append.
                apply mint_cons1 with (j1 := i); [lia|].
                apply mint_cons2 with (j1 := j); [lia|assumption..].
              + apply permut_head; [assumption|constructor].
          }
        - rename j0 into i0. cbn in H0.
          destruct (PeanoNat.Nat.lt_ge_cases j i).
          2:{ exists (te_i :: te_i0 :: te_j :: t1). split.
              + swap_vec_append.
                apply mint_cons1 with (j0 := i); [lia|].
                apply mint_cons1 with (j0 := j); [lia|assumption].
              + now apply permut_head'.
          }
          { destruct (trace_elems_commute_dec te_i te_i0).
            - apply mint_add0 with (i := i) (te_i := te_i) in Ht; [|lia|assumption].
              destruct Ht as [t' [Ht' Hperm']].
              exists (te_i0 :: t'). split.
              + swap_vec_append.
                eapply mint_cons1...
              + apply permut_cons with (a := te_k) in Hperm'.
                now apply permut_head.
            - exists (te_i :: te_i0 :: te_j :: t1). split.
              + swap_vec_append.
                apply mint_cons1 with (j0 := i); [lia|].
                apply mint_cons2 with (j0 := j); [lia|assumption..].
              + apply permut_head.
                * assumption.
                * constructor.
          }
      }
    Qed.

    Lemma mint_add {N} (i k : Fin.t N) t te vec
          (Ht : MInt nonCommRel N k vec t) :
      exists t' : list TE, exists (j : Fin.t N),
          MInt nonCommRel N j (vec_append i te vec) t' /\
          Permutation trace_elems_commute (te :: t) t'.
    Proof.
      destruct (PeanoNat.Nat.lt_ge_cases k i) as [Hki|Hki].
      2:{ exists (te :: t). exists i. split.
          - apply mint_cons1 with (j := k); auto.
          - constructor.
      }
      destruct t as [|te' t].
      { inversion_ Ht.
        exists [te]. exists i. split.
        - eapply mint_cons1; eauto. constructor.
        - constructor.
      }
      destruct (trace_elems_commute_dec te te') as [Hcomm|Hcomm].
      { eapply mint_add0 in Hcomm; eauto.
        destruct Hcomm as [t' H].
        exists (te' :: t'). exists k. assumption.
      }
      { exists (te :: te' :: t). exists i. split.
        - apply mint_cons2 with (j := k); auto.
        - constructor.
      }
    Qed.

    Fixpoint mint_prune N i0 tt_vec t
      (Ht : MInt alwaysCommRel N i0 tt_vec t) {struct Ht} :
      exists t' : list TE, exists i : Fin.t N,
          MInt nonCommRel N i tt_vec t' /\ Permutation trace_elems_commute t t'.
    Proof.
      destruct Ht as [i
                     |i j vec te t Hij Ht
                     |i j vec te_i te_j t Hij Hcomm Ht
                     ].
      - exists []. exists i. split; constructor.
      - subst. apply mint_prune in Ht. destruct Ht as [t' [k [Ht' Hperm]]].
        specialize (mint_add i k t' te vec Ht') as H.
        destruct H as [t'' [i' [Ht'' Hperm'']]].
        exists t''. exists i'. split.
        + assumption.
        + eapply permut_cons in Hperm;
            eapply permut_trans; eauto.
      - subst. apply mint_prune in Ht. destruct Ht as [t' [k [Ht' Hperm]]].
        specialize (mint_add i k t' te_i vec Ht') as H.
        destruct H as [t'' [i' [Ht'' Hperm'']]].
        exists t''. exists i'. split.
        + assumption.
        + eapply permut_cons in Hperm;
            eapply permut_trans; eauto.
    Qed.

    Theorem mint_noncomm_sufficient tt : sufficient_replacement_p (MInt_ alwaysCommRel tt) (MInt_ nonCommRel tt).
    Proof.
      intros t Ht.
      destruct Ht as [i0 Ht]. unfold MInt_.
      remember (Vec.of_list tt) as tt_vec.
      eapply mint_prune in Ht. destruct Ht as [t' [i [Ht Hperm]]].
      exists t'. split.
      - now exists i.
      - assumption.
    Qed.
  End prune_interleavings.

  Section pack_interleaving.
    Context `{Hssp : StateSpace}.

    Lemma shiftin_append_swap {N} t (i : Fin.t N) (te : TE) vec :
      (Vec.shiftin t (vec_append i te vec)) = vec_append (Fin.L_R 1 i) te (Vec.shiftin t vec).
    Admitted.

    Lemma shiftin_cons_append {N} (vec : Vec.t (list TE) N) te t :
      Vec.shiftin (te :: t) vec = vec_append (last_fin N) te (Vec.shiftin t vec).
    Proof.
      induction vec.
      - reflexivity.
      - simpl. rewrite IHvec. reflexivity.
    Qed.

    Fixpoint shiftin_interleaving N i (vec : Vec.t (list TE) N) t1 t2 t
      (HMint : MInt alwaysCommRel N i vec t1)
      (HIlv : Interleaving t1 t2 t) {struct HIlv} :
      exists j, MInt alwaysCommRel (S N) j (Vec.shiftin t2 vec) t.
    Proof.
      destruct HIlv as [te t1' t2' t' HIlv
                       |te t1' t2' t' HIlv
                       |].
      (* Solve easy cases first: *)
      3:{ (* Null: *)
        inversion_ HMint.
        exists (last_fin N). rewrite shiftin_same. constructor.
      }
      2:{ (* t2: *)
        apply shiftin_interleaving with (t2 := t2') (t := t') in HMint; auto.
        rewrite shiftin_cons_append.
        set (k := last_fin N).
        exists k.
        destruct HMint as [j Ht'].
        destruct (last_fin_is_last j).
        - subst.
          apply mint_cons1 with (j := k); auto.
        - destruct t' as [|te' t'].
          + inversion_ Ht'.
            apply mint_cons1 with (j0 := last_fin N); constructor.
          + apply mint_cons2 with (j0 := j); auto.
            constructor.
      }
      set (i' := Fin.L_R 1 i). exists i'.
      inversion_ HMint.
      - eapply shiftin_interleaving in H4; eauto. clear HMint.
        destruct H4 as [k Ht'].
        rewrite shiftin_append_swap.
        destruct (PeanoNat.Nat.lt_ge_cases k i').
        2:{ now apply mint_cons1 with (j0 := k). }
        { destruct t' as [|te' t'].
          - inversion_ Ht'.
            apply mint_cons1 with (j0 := i'); constructor.
          - apply mint_cons2 with (j0 := k); auto; constructor.
        }
      - eapply shiftin_interleaving in H5; eauto. clear HMint.
        destruct H5 as [k Ht'].
        rewrite shiftin_append_swap.
        destruct (PeanoNat.Nat.lt_ge_cases k i').
        2:{ now apply mint_cons1 with (j0 := k). }
        { destruct t' as [|te' t'].
          - inversion_ Ht'.
            apply mint_cons1 with (j0 := i'); constructor.
          - apply mint_cons2 with (j0 := k); auto; constructor.
        }
    Qed.
  End pack_interleaving.
End VecIlv.

(* Deeply magical function from here:
http://jamesrwilcox.com/more-cardinality.html. Reproduced with
permission from the author *)
Definition fin_case n x :
  forall (P : Fin.t (S n) -> Type),
    P Fin.F1 ->
    (forall y, P (Fin.FS y)) ->
    P x :=
  match x as x0 in Fin.t n0
     return
       forall P,
         match n0 as n0' return (Fin.t n0' -> (Fin.t n0' -> Type) -> Type) with
           | 0 => fun _ _ => False
           | S m => fun x P => P Fin.F1 -> (forall x0, P (Fin.FS x0)) -> P x
         end x0 P
  with
  | Fin.F1 => fun _ H1 _ => H1
  | Fin.FS _ => fun _ _ HS => HS _
  end.

Ltac fin_dep_destruct v :=
  let v' := fresh v in
  rename v into v';
  generalize dependent v'; intros v'; pattern v';
  apply fin_case; try clear v'; [|intros v].

Ltac fin_all_cases v :=
  repeat fin_dep_destruct v ; [..|exfalso; inversion v].

Section tests.
  Goal forall (n : Fin.t 3), const True n.
  Proof.
    intros.
    fin_all_cases n.
    - constructor.
    - constructor.
    - constructor.
  Qed.

  Goal forall (n m : Fin.t 3), n < m -> const False n.
  Proof.
    intros.
    fin_all_cases n; fin_all_cases m; intros Hnm; try (lia || now inversion Hnm); cbv.
    3:{
  Abort.
End tests.

Check VecIlv.MInt.

(* I can't into Ltac, sorry *)
Ltac destruct_mint H :=
  let H__type := type of H in
  lazymatch H__type with
  | VecIlv.MInt _ ?Nelems ?i0 ?vec ?t =>
    let Hvec := fresh "Hvec" in
    let vec0 := fresh "vec" in
    let vec' := fresh "vec" in
    let i0' := fresh "pos_" in
    let Hi0' := fresh "Hpos_" in
    let i1 := fresh "pos" in
    let i2 := fresh "pos" in
    let Hij := fresh "H_" i1 "_" i2 in
    let te := fresh "te" in
    let te2 := fresh "te" in
    let Hcomm := fresh "Hcomm" in
    let t := fresh "t" in
    remember vec as vec0 eqn:Hvec;
    remember i0 as i0' eqn:Hi0';
    destruct H as [i1
                  |i1 i2 vec' te t Hij H
                  |i1 i2 vec' te te2 t Hij Hcomm H
                  ];
    [inversion_clear Hi0';
     inversion Hvec
    |fin_all_cases i1;
     fin_all_cases i2;
     intros H Hvec Hi0' Hij;
     ((now inversion Hij) || clear Hij);
     inversion_clear Hi0'
     ..
    ]
  | _ =>
    fail 100 "The argument doesn't look like MInt"
  end.

Section tests.
  Goal forall `{Hssp : StateSpace} i0 vec t, VecIlv.MInt nonCommRel 2 i0 vec t -> const True t -> False.
  Proof.
    intros *. intros H Ht.
    destruct_mint H.
    5:{ destruct_mint H.
        3:{
  Abort.

  Import Vector.VectorNotations.

  Context `{Hssp : StateSpace nat nat}.

  Let vec := [[1; 2]%list; [3; 4]%list]%vector.

  Goal forall i t, VecIlv.MInt nonCommRel 2 i vec t -> const True t -> False.
  Proof.
    subst vec.
    intros *. intros H Ht.
    destruct_mint H.
    - (* Hvec : VecIlv.vec_append Fin.F1 te vec0 = [[1; 2]%list; [3; 4]%list] *)
  Abort.
End tests.


(*
 * Copyright (c) 2009 Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.msl_standard.

Require Import lam_ref_tcb.
Require Import lam_ref_eval.
Require Import lam_ref_mach_defs.
Require Import lam_ref_mach_lemmas.
Require Import lam_ref_type_defs.
Require Import lam_ref_type_safety.
Require Import lam_ref_type_rules.

Definition unary_primop (f:nat -> nat) : expr :=
  Lam (prim (v_Nat oo f) (Var 0)).

Program Definition bin_primop (f:nat -> nat -> nat) : expr :=
  Lam (prim (fun n1 => Lam (prim (fun n2 => v_Nat (f n1 n2)) (Var 0))) (Var 0)).
Next Obligation.
  compute; split; auto.
Qed.

Lemma unary_primop_typ : forall f,
  Typ nil (unary_primop f) (ty_lam ty_nat ty_nat).
Proof.
  intros; unfold unary_primop.
  apply T_Abs.
  apply T_Prim.
  intros.
  unfold val_to_exp, v_Nat; simpl.
  eapply T_Nat.
  apply T_Var; auto.
Qed.

Lemma binary_primop_typ : forall (f:nat -> nat -> nat),
  Typ nil (bin_primop f) (ty_lam ty_nat (ty_lam ty_nat ty_nat)).
Proof.
  intros.
  unfold bin_primop.
  apply T_Abs.
  apply T_Prim; intros.
  unfold val_to_exp; simpl.
  apply T_Abs.
  apply T_Prim; intros.
  unfold val_to_exp, v_Nat; simpl.
  apply T_Nat.
  apply T_Var; auto.
  apply T_Var; auto.
Qed.

Definition ty_bool := ALL a:pred world, ty_lam a (ty_lam a a).
Definition e_true := Lam (Lam (Var 1)).
Definition e_false := Lam (Lam (Var 0)).

Definition e_if b t f :=
  (App (App (App b (Lam t)) (Lam f)) (Nat 0)).

Lemma e_true_typ :
  Typ nil e_true ty_bool.
Proof.
  unfold e_true, ty_bool.
  apply T_UnivI; simpl; intros; auto.
  apply T_Abs.
  apply T_Abs.
  apply T_Var; simpl; auto.
Qed.

Lemma e_false_typ :
  Typ nil e_false ty_bool.
Proof.
  unfold e_false, ty_bool.
  apply T_UnivI; simpl; intros; auto.
  apply T_Abs.
  apply T_Abs.
  apply T_Var; simpl; auto.
Qed.

Lemma T_if : forall G b t f tau,
  Typ G b ty_bool ->
  Typ (TT :: G) t tau ->
  Typ (TT :: G) f tau ->
  Typ G (e_if b t f) tau.
Proof.
  intros.
  unfold e_if.
  apply T_App with TT.
  apply T_App with (ty_lam TT tau).
  apply T_App with (ty_lam TT tau).
  change (ty_lam (ty_lam TT tau) (ty_lam (ty_lam TT tau) (ty_lam TT tau)))
    with ((fun t => ty_lam t (ty_lam t t)) (ty_lam TT tau)).
  apply T_UnivE.
  apply H.
  apply T_Abs; auto.
  apply T_Abs; auto.
  apply T_weaken_nil.
  apply T_sub with ty_nat.
  apply subp_top.
  apply T_Nat.
Qed.

Program Definition isZ : expr -> expr :=
  prim (fun n => if beq_nat n 0 then e_true else e_false).
Solve Obligations using (compute; split; auto).

Lemma T_isZ : forall G e,
  Typ G e ty_nat ->
  Typ G (isZ e) ty_bool.
Proof.
  intros.
  unfold isZ.
  apply T_Prim; intros; auto.
  unfold val_to_exp; simpl.
  destruct (beq_nat n 0); simpl.
  apply e_true_typ.
  apply e_false_typ.
Qed.

Definition e_let (def body:expr) :=
  (App (Lam body) def).

Definition option (a:pred world) :=
  ALL b:pred world, ty_lam b (ty_lam (ty_lam a b) b).

Definition none : expr := Lam (Lam (Var 1)).
Definition some : expr := Lam (Lam (Lam (App (Var 0) (Var 2)))).
Definition out  : expr := Lam (Lam (App (App (Var 0) (Var 1)) (Lam (Var 0)))).

Lemma out_typ :
  Typ nil out (ALL tau:pred world, ty_lam tau (ty_lam (option tau) tau)).
Proof.
  intros.
  unfold out.
  apply T_UnivI; simpl; intros; auto.
  apply T_Abs.
  apply T_Abs.
  eapply T_App with (ty_lam tau tau).
  2: apply T_Abs.
  2: apply T_Var; simpl; auto.
  apply T_App with tau.
  2: apply T_Var; simpl; auto.
  unfold option.
  change (ty_lam tau (ty_lam (ty_lam tau tau) tau))
    with ((fun b => ty_lam b (ty_lam (ty_lam tau b) b)) tau).
  apply T_UnivE.
  apply T_Var; simpl; auto.
Qed.

Lemma none_typ :
  Typ nil none (ALL tau:pred world, option tau).
Proof.
  intros.
  unfold none.
  unfold option.
  apply T_UnivI.
  simpl; auto.
  intros.
  apply T_UnivI.
  simpl; auto.
  intros b.
  apply T_Abs.
  apply T_Abs.
  apply T_Var.
  simpl; auto.
Qed.

Lemma some_typ :
  Typ nil some (ALL tau:pred world, ty_lam tau (option tau)).
Proof.
  unfold some.
  apply T_UnivI; simpl; intros; auto.
  apply T_Abs.
  unfold option.
  apply T_UnivI; simpl; intros; auto.
  apply T_Abs.
  apply T_Abs.
  apply T_App with tau.
  apply T_Var; simpl; auto.
  apply T_Var; simpl; auto.
Qed.

Definition W := (Lam (App (Var 0) (Var 0))).
Definition diverge := App W W.

Definition W_ty Z := fun X => ty_lam X Z.
Lemma W_ty_cont : forall Z, contractive (W_ty Z).
Proof.
  intros.
  unfold W_ty.
  apply ty_lam_contractive.
  hnf; simpl; intros.
  hnf; auto.
  hnf; simpl; repeat intro.
  split; hnf; eauto.
Qed.

Lemma W_typ : forall Z, Typ nil W (Rec (W_ty Z)).
Proof.
  intros.
  rewrite Rec_fold_unfold.
  2: apply W_ty_cont.
  unfold W.
  unfold W_ty.
  apply T_Abs.
  apply T_App with (Rec (W_ty Z)).
  rewrite Rec_fold_unfold.
  2: apply W_ty_cont.
  apply T_Var; auto.
  apply T_Var; auto.
Qed.

Lemma diverge_typ : forall t,
  Typ nil diverge t.
Proof.
  intros.
  unfold diverge.
  apply T_App with (Rec (W_ty t)).
  generalize (W_typ t).
  rewrite Rec_fold_unfold at 1; auto.
  apply W_ty_cont.
  apply W_typ.
Qed.

(* The standard CBV fixpoint combinator *)
Definition Wf := (Lam (App (Var 1) (Lam (App (App (Var 1) (Var 1)) (Var 0))))).
Definition Y := Lam (App Wf Wf).

Definition Wf_ty A B := fun X => ty_lam X (ty_lam A B).
Lemma Wf_ty_cont : forall A B, contractive (Wf_ty A B).
Proof.
  intros.
  unfold Wf_ty.
  apply ty_lam_contractive.
  repeat intro; auto.
  repeat intro; split; repeat intro; auto.
Qed.

Lemma Wf_typ : forall A B,
  Typ (ty_lam (ty_lam A B) (ty_lam A B) :: nil) Wf (Rec (Wf_ty A B)).
Proof.
  intros.
  unfold Wf.
  rewrite Rec_fold_unfold.
  2: apply Wf_ty_cont.
  unfold Wf_ty.
  apply T_Abs.
  apply T_App with (ty_lam A B).
  apply T_Var; simpl; auto.
  apply T_Abs.
  apply T_App with A.
  apply T_App with (Rec (Wf_ty A B)).
  rewrite Rec_fold_unfold at 1.
  2: apply (Wf_ty_cont A B).
  apply T_Var; auto.
  apply T_Var; auto.
  apply T_Var; auto.
Qed.

Lemma Y_typ : forall A B,
  Typ nil Y (ty_lam (ty_lam (ty_lam A B) (ty_lam A B)) (ty_lam A B)).
Proof.
  intros.
  unfold Y.
  apply T_Abs.
  apply T_App with (Rec (Wf_ty A B)).
  generalize (Wf_typ A B).
  rewrite Rec_fold_unfold at 1; auto.
  apply Wf_ty_cont.
  apply Wf_typ.
Qed.

Definition e_fix f := App Y (Lam f).

Lemma fix_ty : forall A B G f,
  Typ (ty_lam A B :: G) f (ty_lam A B) ->
  Typ G (e_fix f) (ty_lam A B).
Proof.
  intros.
  unfold e_fix.
  apply T_App with (ty_lam (ty_lam A B) (ty_lam A B)).
  apply T_weaken_nil.
  apply Y_typ.
  apply T_Abs.
  auto.
Qed.

(* The "backpatching" fixpoint combinator, AKA Landin's knot. *)
Definition refY :=
  Lam (e_let (New (Lam diverge))
             (Update (Var 0) (Lam (App (App (Var 2) (Deref (Var 1))) (Var 0))) (Deref (Var 0)) )).

Lemma refY_typ : forall A B,
  Typ nil refY (ty_lam (ty_lam (ty_lam A B) (ty_lam A B)) (ty_lam A B)).
Proof.
  intros.
  unfold refY.
  apply T_Abs.
  unfold e_let.
  apply T_App with (ty_ref (ty_lam A B)).
  2: apply T_New.
  2: apply T_Abs.
  2: apply T_weaken_nil.
  2: apply diverge_typ.
  apply T_Abs.
  eapply T_Update.
  apply T_Var; simpl; auto.
  apply T_Abs.
  apply T_App with A.
  apply T_App with (ty_lam A B).
  apply T_Var; simpl; auto.
  apply T_Deref.
  apply T_Var; simpl; auto.
  apply T_Var; simpl; auto.
  apply T_Deref.
  apply T_Var; simpl; auto.
Qed.

Definition r_fix f := App refY (Lam f).

Lemma rfix_ty : forall A B G f,
  Typ (ty_lam A B :: G) f (ty_lam A B) ->
  Typ G (r_fix f) (ty_lam A B).
Proof.
  intros.
  unfold r_fix.
  apply T_App with (ty_lam (ty_lam A B) (ty_lam A B)).
  apply T_weaken_nil.
  apply refY_typ.
  apply T_Abs.
  assumption.
Qed.

(* Factorial function
 *)
Definition e_fac : expr :=
  r_fix (Lam
          (e_if (isZ (Var 0))

            (* base case *)
            (Nat 1)

            (* recursive case *)
            (App (App (bin_primop mult) (Var 1))
                 (App (Var 2) (App (unary_primop Peano.pred) (Var 1)))))).

Lemma e_fac_typ :
  Typ nil e_fac (ty_lam ty_nat ty_nat).
Proof.
  unfold e_fac.
  apply rfix_ty.
  apply T_Abs.
  apply T_if.
  apply T_isZ.
  apply T_Var; auto.
  apply T_Nat.
  apply T_App with ty_nat.
  apply T_App with ty_nat.
  apply T_weaken_nil.
  apply binary_primop_typ.
  apply T_Var; auto.
  apply T_App with ty_nat.
  apply T_Var; auto.
  apply T_App with ty_nat.
  apply T_weaken_nil.
  apply unary_primop_typ.
  apply T_Var; auto.
Qed.

(* Demonstrate an example of the factorial program
   working correctly.
 *)
Eval vm_compute in (snd (eval 100 empty_mem (App e_fac (Nat 6)))).

(* Our typed calculus is turing-complete.
   We demonstrate this by embedding the
   "untyped" CBV lambda terms.
   First we define a type U with the characteristic
   equation U = U -> U, and then we show that all closed
   terms formed from abstraction, application and
   variables can be given this type.

   Turing-completeness follows from the fact that
   untyped CBV l-calc is turing-complete.
 *)

Fixpoint isULTerm (e:expr) : Prop :=
  match e with
  | Lam e' => isULTerm e'
  | App e1 e2 => isULTerm e1 /\ isULTerm e2
  | Var _ => True
  | _ => False
  end.

Lemma U_contractive : contractive (fun X => ty_lam X X).
Proof.
  apply ty_lam_contractive; hnf; repeat intro; auto.
Qed.

Definition U := Rec (fun X => ty_lam X X).
Lemma U_eqn : U = ty_lam U U.
Proof.
  unfold U at 1.
  rewrite Rec_fold_unfold; fold U; auto.
  apply U_contractive.
Qed.

Fixpoint Ulist (n:nat) :=
  match n with
  | 0 => nil
  | S n' => U :: Ulist n'
  end.

Lemma ULTyped' : forall e n,
  isULTerm e ->
  closed' n e ->
  Typ (Ulist n) e U.
Proof.
  induction e; simpl; intuition.

  apply T_Var.
  revert n0 H0; induction n; simpl; intros.
  inv H0; simpl; auto.
  destruct n0.
  omegac.
  simpl; apply IHn; omega.

  rewrite U_eqn.
  apply T_Abs.
  apply (IHe (S n)); auto.
  replace (S n) with (n+1) by omega; auto.

  apply T_App with U.
  rewrite <- U_eqn.
  apply IHe1; auto.
  apply IHe2; auto.
Qed.

Theorem ULTyped : forall e,
  closed e /\ isULTerm e ->
  Typ nil e U.
Proof.
  intuition; apply (ULTyped' e 0); auto.
Qed.


(** * Chapter 10 - Type Safety for F-Sub *)

(** ** Part 1 : System F *)

Require Export Coq.Lists.List.
Require Import Coq.Program.Equality.
From Chapter10 Require Export sysf.
Require Import Coq.Program.Tactics.
Import CommaNotation.

Ltac inv H := inversion H; try clear H; try subst.

Ltac autorevert x :=
  try (match goal with
    | [y : ?Y |- ?claim] =>
      try (match x with y => idtac end; fail 1);
        match goal with [z : _ |- _] =>
          match claim with context[z] =>
            first
              [ match Y with context[z] => revert y; autorevert x end
              | match y with z => revert y; autorevert x end]
          end
        end
       end).

Definition ctx n := fin n -> ty n.

Reserved Notation "'SUB' Delta |- A <: B"
         (at level 68, A at level 99, no associativity).

(** *** Properties of Subtyping *)

Inductive sub {n} (Delta : ctx n) : ty n -> ty n -> Prop :=
| SA_top A :
    SUB Delta |- A <: top
| SA_Refl x :
    SUB Delta |- var_ty x <: var_ty x
| SA_Trans x  B :
     SUB Delta |- (Delta x) <: B ->  SUB Delta |- var_ty x <: B
| SA_arrow A1 A2 B1 B2 :
    SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 ->
    SUB Delta |- arr A1 A2 <: arr B1 B2
| SA_all (A1: ty n) (A2: ty (S n)) B1 B2 :
    SUB Delta |- B1 <: A1 -> @sub (S n) ((B1, Delta) >> ⟨↑⟩) A2 B2 ->
    SUB Delta |- all A1 A2 <: all B1 B2
where "'SUB' Delta |- A <: B" := (sub Delta A B).

Hint Constructors sub.

Lemma sub_refl n (Delta: ctx n) A : SUB Delta |- A <: A.
Proof. revert Delta. induction A; intuition; constructor; eauto. Qed.

Lemma sub_weak m n (Delta1: ctx m) (Delta2: ctx n) A1 A2 A1' A2' (xi: fin m -> fin n) :
  SUB Delta1 |- A1 <: A2 ->
 (forall x, (Delta1 x)⟨xi⟩ = Delta2 (xi x)) ->
  A1' = A1⟨xi⟩ -> A2' = A2⟨xi⟩ ->
  SUB Delta2 |- A1' <: A2' .
Proof.
  intros H. autorevert H. induction H; intros; subst; asimpl; econstructor; eauto.
  - eapply IHsub2; try reflexivity.
    auto_case. rewrite <- H1. now asimpl.
Qed.

Lemma sub_weak1 n (Delta : ctx n) A A' B B' C :
  SUB Delta |- A <: B ->  A' = A⟨↑⟩ ->  B' = B⟨↑⟩ -> SUB ((C, Delta) >> ⟨↑⟩) |- A' <: B'.
Proof. intros. eapply sub_weak;  eauto. intros x. now asimpl. Qed.

Definition transitivity_at {n} (B: ty n) := forall m Gamma (A : ty m) C  (xi: fin n -> fin m),
  SUB Gamma |- A <: B⟨xi⟩ -> SUB Gamma |- B⟨ xi⟩ <: C ->  SUB Gamma |- A <: C.

 Lemma transitivity_proj n (Gamma: ctx n) A B C :
  transitivity_at B ->
  SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof. intros H. specialize (H n Gamma A C id). now asimpl in H. Qed.
Hint Resolve transitivity_proj.

Lemma transitivity_ren m n B (xi: fin m -> fin n) : transitivity_at B -> transitivity_at B⟨xi⟩.
Proof. unfold transitivity_at. intros. eapply H; asimpl in H0; asimpl in H1; eauto. Qed.

Lemma sub_narrow n (Delta Delta': ctx n) A C :
  (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  (forall x, Delta x = Delta' x \/ transitivity_at (Delta x)) ->
  SUB Delta |- A <: C -> SUB Delta' |- A <: C.
Proof with asimpl;eauto.
  intros H H' HH. autorevert HH. induction HH; intros; eauto.
  - destruct (H' x); eauto. rewrite H0 in *. eauto.
  - constructor; eauto.
    eapply IHHH2.
    + auto_case; try apply sub_refl.
      eapply sub_weak; try reflexivity. eapply H. now asimpl.
    + auto_case. destruct (H' f);  eauto using transitivity_ren.
      rewrite H0. now left.
Qed.

Corollary sub_trans' n (B : ty n): transitivity_at B.
Proof with asimpl;eauto.
  unfold transitivity_at.
  autorevert B. induction B; intros...
  - depind H...
  - depind H... depind H0...
  - depind H... depind H1...
  - depind H... depind H1...
    econstructor... clear IHsub0 IHsub3 IHsub1 IHsub2.
    eapply IHB2; eauto.
    + asimpl in *. eapply sub_narrow; try eapply H0.
      * auto_case. apply sub_refl.
        eapply sub_weak with (xi := ↑); try reflexivity; eauto. now asimpl.
      * intros [x|]; try cbn; eauto. right. apply transitivity_ren. apply transitivity_ren. eauto.
    + asimpl in H1_0. auto.
Qed.

Corollary sub_trans n (Delta  : ctx n) A B C:
  SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C.
Proof. eauto using sub_trans'. Qed.

Lemma sub_substitution m m' (sigma : fin m -> ty m') Delta (Delta': ctx m') A B:
   (forall x ,  SUB Delta' |- sigma x <: (Delta x)[sigma] ) ->
   SUB Delta |- A <: B -> SUB Delta' |- subst_ty sigma A <: subst_ty sigma B.
Proof.
    intros eq H. autorevert H. induction H; try now (econstructor; eauto).
  - intros. asimpl. eapply sub_refl.
  - intros. asimpl. eauto. cbn in *. eauto using sub_trans.
  - intros. asimpl. econstructor; eauto.
    asimpl. eapply IHsub2.
    auto_case; asimpl; cbn; eauto using sub_refl.
    eapply sub_weak; try reflexivity. eapply eq.
    all: now asimpl.
Qed.

(** *** Type Safety *)

Inductive value {m n}: tm m n -> Prop :=
| Value_abs A s : value(abs A s)
| Value_tabs A s : value(tabs A s).

Reserved Notation "'TY' Delta ; Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Delta ; Gamma  |-  A  :  B").

Definition dctx m n := fin m -> ty n.

Inductive has_ty {m n} (Delta : ctx m) (Gamma : dctx  n m) : tm m n -> ty m -> Prop :=
| T_Var  x :
    TY Delta;Gamma |- var_tm x : (Gamma x)
 | T_abs (A: ty m) B (s: tm m (S n)):
    @has_ty m (S n) Delta (A, Gamma) s B   ->
    TY Delta;Gamma |- abs A s : arr A B
| T_app A B s t:
    TY Delta;Gamma |- s : arr A B   ->   TY Delta;Gamma |- t : A   ->
    TY Delta;Gamma |- app s t : B
| T_tabs A B s :
    @has_ty (S m) n ((A, Delta) >> ⟨↑⟩) (Gamma >> ⟨↑⟩) s B ->
    TY Delta;Gamma |- tabs A s : all A B
| T_Tapp A B A' s B' :
    TY Delta;Gamma |- s : all A B ->
    SUB Delta |- A' <: A -> B' = subst_ty (A'..) B ->
    TY Delta;Gamma |- tapp s A' : B'
 | T_Sub A B s :
    TY Delta;Gamma |- s : A   ->   SUB Delta |- A <: B   ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (has_ty Delta Gamma s A).

Hint Constructors has_ty.

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'   s  =>  t").
Inductive eval {m n} : tm m n -> tm m n -> Prop :=
| E_appabs A s t : EV app (abs A s) t => s[ids; t..]
| E_Tapptabs A s B : EV tapp (tabs A s) B => s[B..; ids]
| E_appFun s s' t :
     EV s => s' ->
     EV app s t => app s' t
| E_appArg s s' v:
     EV s => s' -> value v ->
     EV app v s => app v s'
| E_TyFun s s' A :
     EV s => s' ->
     EV tapp s A => tapp s' A
where "'EV' s => t" := (eval s t).

(** **** Progress *)

Definition empty {X} : fin 0 -> X :=
  fun x => match x with end.

Lemma can_form_arr {s: tm 0 0} {A B}:
  TY empty;empty |- s : arr A B -> value s -> exists C t, s = abs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0; try inversion H1).
  inversion H0; subst; eauto. inversion x.
Qed.

Lemma can_form_all {s A B}:
  TY empty;empty |- s : all A B -> value s -> exists C t, s = tabs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0; try inversion H1).
  inv H0; subst; eauto. inversion x.
Qed.

Theorem ev_progress s A:
  TY empty;empty |- s : A -> value s \/ exists t,  EV s => t.
Proof.
  intros. depind H; eauto; try (left; constructor).
  - inversion x.
  - right. edestruct IHhas_ty1 as [? | [? ?]]; try reflexivity.
    + edestruct (can_form_arr H H1) as [? [? ?]]; subst.
      eexists. econstructor.
    + eexists. econstructor. eauto.
  - right. edestruct IHhas_ty as [? | [? ?]]; try reflexivity.
    + edestruct (can_form_all H H1) as [? [? ?]]; subst. eexists. econstructor.
    + eexists. econstructor. eauto.
Qed.

(** **** Preservation *)

Lemma context_renaming_lemma m m' n n' (Delta: ctx m') (Gamma: dctx n' m')                                                   (s: tm m n) A (sigma : fin m -> fin m') (tau: fin n -> fin n') Delta' (Gamma' : dctx n m):
  (forall x, (Delta' x)⟨sigma⟩ = Delta (sigma x)) ->
  (forall (x: fin n) , (Gamma' x)⟨sigma⟩ =  (Gamma (tau x))) ->
  TY Delta'; Gamma' |- s : A -> TY Delta; Gamma |- s⟨sigma;tau⟩ : A⟨sigma⟩.
Proof.
  intros H H' ty. autorevert ty.
  induction ty; intros; asimpl in *; subst; try now (econstructor; eauto).
  - rewrite H'. constructor.
  - constructor. apply IHty; eauto. auto_case.
  - econstructor. apply IHty; eauto.
    + auto_case; try now asimpl. rewrite <- H. now asimpl.
    + intros. asimpl. rewrite <- H'. now asimpl.
  - eapply T_Tapp with (A0 := A⟨sigma⟩) .
    asimpl in IHty. eapply IHty; eauto.
    eapply sub_weak; eauto.
    now asimpl.
  - econstructor. eauto.
    eapply sub_weak; eauto.
Qed.

Lemma context_morphism_lemma m m' n n' (Delta: ctx m) (Delta': ctx m') (Gamma: dctx n m) (s: tm m n) A (sigma : fin m -> ty m') (tau: fin n -> tm m' n') (Gamma' : dctx n' m'):
  (forall x, SUB Delta' |- sigma x <: (Delta x)[sigma]) ->
  (forall (x: fin n) ,  TY Delta'; Gamma' |- tau x : subst_ty sigma (Gamma x)) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma' |- s[sigma;tau] : A[sigma].
Proof.
  intros eq1 eq2 ty. autorevert ty.
  induction ty; intros; subst; asimpl; try now (econstructor; eauto).
  - eapply eq2.
  - constructor. eapply IHty; eauto.
    auto_case; asimpl.
    +  assert (subst_ty sigma (Gamma f)  = ((Gamma f)[sigma]⟨id⟩)) as -> by (now asimpl) .
       eapply context_renaming_lemma; eauto; now asimpl.
    + econstructor.
  - constructor. eapply IHty; eauto.
    + auto_case.
      * asimpl.
        specialize (eq1 f).
        eapply sub_weak1 with (C := A[sigma]) in eq1; eauto.  asimpl in eq1. eapply eq1.
      * asimpl. econstructor. apply sub_refl.
    + intros x. asimpl.
      assert ((Gamma x) [sigma >> ⟨↑⟩] = (Gamma x)[sigma]⟨↑⟩) by (now asimpl).
      auto_unfold in *. rewrite H.
      eapply context_renaming_lemma; eauto.
      * intros. now asimpl.
      * intros. now asimpl.
  - eapply T_Tapp with (A0 := subst_ty sigma A) .
    asimpl in IHty. eapply IHty; eauto.
    eapply sub_substitution; eauto.
    now asimpl.
 - econstructor.
    + eapply IHty; eauto.
    + eapply sub_substitution; eauto.
Qed.

 Lemma ty_inv_abs m n Delta Gamma A A' B C (s: tm m (S n)):
  TY Delta;Gamma |- abs A s : C   ->   SUB Delta |- C <: arr A' B   ->
  (SUB Delta |- A' <: A /\
    exists B', TY Delta; A .: Gamma |- s : B' /\ SUB Delta |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H0. split; eauto.
  - eauto using sub_trans.
Qed.

Lemma ty_subst m n (Gamma: dctx m n) (Delta: ctx n) Delta' s A:
    (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma |- s : A.
Proof.
  intros eq H. autorevert H. induction H; eauto; intros.
  - econstructor; eauto. asimpl. eapply IHhas_ty. auto_case; eauto using sub_refl.
    eapply sub_weak; try reflexivity. apply eq. intros x. now asimpl.
  - econstructor; eauto.
    replace A with (A[ids]) by (now asimpl). replace A' with (A'[ids]) by (now asimpl).
    eapply sub_substitution; eauto. intros x.
    asimpl. econstructor. eauto.
  - econstructor; eauto. eapply sub_substitution with (sigma := ids) in H0; eauto.
    asimpl in H0. eapply H0. intros x. econstructor. asimpl. eapply eq.
Qed.

Lemma ty_inv_tabs {m n} {Delta Gamma A A' B C} (s : tm (S m) n):
  TY Delta;Gamma |- tabs A s : C   ->   SUB Delta |- C <: all A' B   ->
  (SUB Delta |- A' <: A /\ exists B',
   TY (A'.:Delta) >> ren_ty ↑; Gamma >> ren_ty ↑ |- s : B' /\ SUB (A' .: Delta) >> ren_ty ↑ |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H0. split; eauto.
    eexists. split; eauto.
    eapply ty_subst; eauto. auto_case.
    apply sub_refl. eapply sub_weak; try reflexivity; eauto.
  - eauto using sub_trans.
Qed.

Theorem preservation m n Delta Gamma (s: tm m n) t A :
  TY Delta;Gamma |- s : A -> EV s => t ->
  TY Delta;Gamma |- t : A.
Proof.
  intros H_ty H_ev. autorevert H_ev.
  induction H_ev; intros; eauto using ty.
  all: try (now (depind H_ty; eauto)).
  - depind H_ty; [|eauto].
    + depind H_ty1; subst.
      * replace B with (B[ids]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. apply sub_refl.
        -- intros [|]; intros; cbn; asimpl; eauto.
      * pose proof (ty_inv_abs _ _ _ _ _ _ _ _ _ H_ty1 H) as (?&?&?&?).
        eapply T_Sub; eauto.
        replace x with (x[var_ty]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. apply sub_refl.
        -- intros [|]; intros; cbn; asimpl; eauto.
  - depind H_ty; eauto.
    + depind H_ty.
      * asimpl in H_ty.
        eapply context_morphism_lemma; try eapply H_ty; eauto.
        -- auto_case.
           ++ asimpl. constructor. apply sub_refl.
           ++ now asimpl.
        -- intros x. asimpl. constructor.
      * pose proof (ty_inv_tabs _ H_ty H) as (?&?&?&?).
        eapply T_Sub; eauto. asimpl in *.
        eapply context_morphism_lemma; eauto.
        -- auto_case; asimpl; eauto. asimpl. constructor. apply sub_refl.
        -- intros z. unfold funcomp. asimpl. constructor.
        -- eapply sub_substitution; eauto.
           auto_case; asimpl.
           constructor. apply sub_refl.
Qed.


Require Import Fiat.QueryStructure.Automation.MasterPlan.

Definition Market := string.
Definition StockType := nat.
Definition StockCode := nat.
Definition Date      := nat.
Definition Timestamp := nat.

Definition TYPE := "TYPE".
Definition MARKET := "MARKET".
Definition STOCK_CODE := "STOCK_CODE".
Definition FULL_NAME := "FULL_NAME".

Definition DATE := "DATE".
Definition TIME := "TIME".
Definition PRICE := "PRICE".
Definition VOLUME := "VOLUME".

Definition STOCKS := "STOCKS".
Definition TRANSACTIONS := "TRANSACTIONS".

Definition StocksSchema :=
  Query Structure Schema
    [ relation STOCKS has
              schema <STOCK_CODE :: StockCode,
                      FULL_NAME :: string,
                      MARKET :: Market,
                      TYPE :: StockType>
              where attributes [FULL_NAME; MARKET; TYPE] depend on [STOCK_CODE]; (* uniqueness, really *)
      relation TRANSACTIONS has
              schema <STOCK_CODE :: nat,
                      DATE :: Date,
                      TIME :: Timestamp,
                      PRICE :: N,
                      VOLUME :: N>
              where attributes [PRICE] depend on [STOCK_CODE; TIME] ]
    enforcing [attribute STOCK_CODE for TRANSACTIONS references STOCKS].

Definition StocksSig : ADTSig :=
  ADTsignature {
      Constructor "Init"               : rep,
      Method "AddStock"           : rep * (StocksSchema#STOCKS)       -> rep * bool,
      Method "AddTransaction"     : rep * (StocksSchema#TRANSACTIONS) -> rep * bool,
      Method "TotalVolume"        : rep * StockCode * Date          -> rep * N,
      Method "MaxPrice"           : rep * StockCode * Date          -> rep * (option N),
      Method "TotalActivity"      : rep * StockCode * Date          -> rep * nat,
      Method "LargestTransaction" : rep * StockType * Date          -> rep * (option N)
    }.

Definition StocksSpec : ADT StocksSig :=
  Def ADT {
    rep := QueryStructure StocksSchema,

    Def Constructor0 "Init" : rep := empty,,

    Def Method1 "AddStock" (r : rep) (stock: StocksSchema#STOCKS) : rep * bool :=
        Insert stock into r!STOCKS,

    Def Method1 "AddTransaction" (r : rep) (transaction : StocksSchema#TRANSACTIONS) : rep * bool :=
        Insert transaction into r!TRANSACTIONS,

    Def Method2 "TotalVolume" (r : rep) (code : StockCode) (date : Date) : rep * N :=
          sum <- SumN (For (transaction in r!TRANSACTIONS)
                           Where (transaction!STOCK_CODE = code)
                           Where (transaction!DATE = date)
                           Return transaction!VOLUME);
    ret (r, sum),

    Def Method2 "MaxPrice" (r : rep) (code : StockCode) (date : Date) : rep * option N :=
      max <- MaxN (For (transaction in r!TRANSACTIONS)
                       Where (transaction!STOCK_CODE = code)
                       Where (transaction!DATE = date)
                       Return transaction!PRICE);
     ret (r, max),

    Def Method2 "TotalActivity" (r : rep) (code : StockCode) (date : Date) : rep * nat :=
       count <- Count (For (transaction in r!TRANSACTIONS)
                           Where (transaction!STOCK_CODE = code)
                           Where (transaction!DATE = date)
                           Return ());
     ret (r, count),

    Def Method2 "LargestTransaction" (r : rep) (type : StockType) (date : Date) : rep * option N :=
        max <- MaxN (For (stock in r!STOCKS) (transaction in r!TRANSACTIONS)
                         Where (stock!TYPE = type)
                         Where (transaction!DATE = date)
                         Where (stock!STOCK_CODE = transaction!STOCK_CODE)
                         Return (N.mul transaction!PRICE transaction!VOLUME));
     ret (r, max)
}%methDefParsing.

Ltac drop_constraints_from_insert ::=
  remove trivial insertion checks; rewrite refine_bind;
   [
   | reflexivity
   | unfold pointwise_relation; intros * *;
     set_refine_evar;
     repeat (first
       [ drop_symmetric_functional_dependencies
       | remove_trivial_fundep_insertion_constraints
       | fundepToQuery; try simplify with monad laws
       | foreignToQuery; try simplify with monad laws
       | setoid_rewrite refine_trivial_if_then_else; simplify with monad laws ]); pose_string_hyps;
     pose_heading_hyps; finish honing ]; pose_string_hyps; pose_heading_hyps; finish honing.

    Ltac finish_planning' PickIndex
     BuildEarlyIndex BuildLastIndex
     IndexUse createEarlyTerm createLastTerm
     IndexUse_dep createEarlyTerm_dep createLastTerm_dep
     BuildEarlyBag BuildLastBag ::=
  (* Automatically select indexes + data structure. *)

    PickIndex ltac:(fun attrlist =>
                      make_simple_indexes attrlist BuildEarlyIndex BuildLastIndex).

Definition SharpenedStocks :
  FullySharpened StocksSpec.
Proof.

  master_plan EqIndexTactics.
  plan
    EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
    EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  plan
    EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
    EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  Focus 5.
  Focused_refine_Query.
  Time implement_In_opt. (* 13.076s *)
  (* This is the optimized version of the first step of refining queries. It takes 13.076s on my machine. *)
  Undo 1.
  Time repeat first
       [setoid_rewrite (@refine_Filtered_Query_In_Enumerate); try eassumption
       | setoid_rewrite refine_Filtered_Join_Query_In_Enumerate'; try eassumption
       | setoid_rewrite (refine_List_Query_In_Where _ _ _); try eassumption; simpl
       | setoid_rewrite <- filter_and
       | setoid_rewrite andb_true_r].
  (* The setoid_rewrite version takes 177.104s but is much simpler. *)
  (* I haven't patched up the rest. *)

  implement_In_opt.
  setoid_rewrite refine_Filtered_Join_Query_In_Enumerate'.

  start sharpening ADT.
  start_honing_QueryStructure'.
  pose_string_hyps.

  master_plan EqIndexTactics.

  (* Uncomment this to see the mostly sharpened implementation *)
  (* partial_master_plan EqIndexTactics. *)
  (*master_plan EqIndexTactics. *)

Time Defined.
(* 2590MB  *)

Time Definition StocksImpl : ComputationalADT.cADT StocksSig :=
  Eval simpl in projT1 SharpenedStocks.
(* 3728MB *)
Print StocksImpl.


Require Export Iron.Language.SystemF2Effect.Step.TypeC.
Require Export Iron.Language.SystemF2Effect.Store.LiveE.
Require Export Iron.Language.SystemF2Effect.Store.LiveS.

(* Evaluation is done when the stack is empty and the expression has
   been reduced to a value. *)
Definition done (fs : stack) (x : exp)
 := fs = nil /\ (exists v, x = XVal v).

(* Add condition, e1 does not mention handles of any deleted regions.
   Also add this condition to preservation to get region deallocation. *)
Lemma progress
 :   forall se ss sp fs x1 t1 e1
 ,   WfFS   se sp ss fs
 ->  LiveS  ss fs -> LiveE fs e1
 ->  TypeC  nil nil se sp fs x1 t1 e1
 ->  done fs x1
  \/ (exists ss' sp' fs' x1', StepF ss sp fs x1 ss' sp' fs' x1').
Proof.
 intros se ss sp fs x1 t1 e1 HW HLS HLE HC.
 gen t1 e1.
 induction x1; intros; eauto.

 (*********************************************************)
 Case "XVal".
 { induction fs.
   - SCase "fs = nil".
     left.
     unfold done. rip. exists v. auto.

   - SCase "fs = cons ...".
     right.
     destruct a as [t x | m1 p2].
     + SSCase "FLet".
       exists ss. exists sp. exists fs. exists (substVX 0 v x).
       eauto.
     + destruct m1 as [p1 | ].
       * SSCase "FPriv ext".
         exists (map (mergeB p1 p2) ss).
         exists sp. exists fs. exists (XVal (mergeV p1 p2 v)).
         eauto.

       * SSCase "FPriv top".
         exists (map (deallocRegion p2) ss).
         exists sp. exists fs. exists (XVal v).
         eauto.
 }

 (*********************************************************)
 Case "XLet".
 { right.
   exists ss. exists sp. exists (fs :> FLet t x1_2). exists x1_1.
   eauto.
 }

 (*********************************************************)
 Case "XApp".
 { right.
   exists ss. exists sp. exists fs.
   inverts_typec.
   destruct v; nope.
   SCase "v1 = XLam".
    exists (substVX 0 v0 e). eauto.
   SCase "v1 = XConst".
    destruct c; nope.
 }

 (*********************************************************)
 Case "XAPP".
 { right.
   exists ss. exists sp. exists fs.
   inverts_typec.
   destruct v; nope.
   SCase "v1 = XLAM".
    exists (substTX 0 t e). eauto.
   SCase "v1 = XConst".
    destruct c; nope.
 }

 (*********************************************************)
 Case "XOp1".
 { right.
   exists ss. exists sp. exists fs.
   destruct o.
   SCase "OSucc".
    inverts_typec.
    snorm. inverts H8.
    destruct v; nope.
    destruct c; nope.
    eauto.
  SCase "OIsZero".
    inverts_typec.
    snorm. inverts H8.
    destruct v; nope.
    destruct c; nope.
    eauto.
 }

 (*********************************************************)
 Case "XPrivate".
 { right.
   exists ss.
   exists (SRegion (allocRegion sp) <: sp).
   exists (fs :> FPriv None (allocRegion sp)).
   eauto.
 }

 (*********************************************************)
 Case "XExtend".
 { right.
   inverts HC. inverts_type.
   have HR: (exists n, t = TRgn n).
   destruct HR as [p]. subst.

   exists ss.
   exists (SRegion (allocRegion sp) <: sp).
   exists (fs :> FPriv (Some p) (allocRegion sp)).
   eauto.
 }

 (*********************************************************)
 Case "XAlloc".
 { right.
   inverts_typec.
   have HR: (exists n, t = TRgn n).
   destruct HR as [n].
   exists (StValue n v <: ss).
   exists sp.
   exists fs.
   exists (XVal (VLoc (length ss))).
   subst. auto.
 }

 (*********************************************************)
 Case "XRead".
 { right.
   inverts HC. inverts_type.
   have HR: (exists n, t = TRgn n).
   destruct HR as [n]. subst.

   assert (exists l, v = VLoc l) as HL.
    destruct v; burn.
    destruct c; nope.
   dest l. subst.

   inverts_type. inverts HW.
   exists ss. exists sp. exists fs.
   rip.

   (* There is a binding in the store corresponding
      to the entry in the store environment. *)
   have (exists b, get l ss = Some b).
    dest b.

   unfold StoreT in *.

   destruct b.
   (* Store binding contains a value. *)
   - have HB: (TypeB nil nil se sp (StValue n0 v) (TRef (TRgn n) t0))
      by (eapply Forall2_get_get_same; eauto).
     inverts HB.
     exists (XVal v).
     eauto.

   (* Store binding is dead,
      can't happen due to binding liveness constraints LiveE/LiveE *)
   - have HB: (TypeB nil nil se sp (StDead n0)    (TRef (TRgn n) t0))
      by (eapply Forall2_get_get_same; eauto).
     inverts HB.

     remember (TRgn n) as p.

     have (SubsT nil sp e1 (TRead p) KEffect)
      by  (eapply EqSym in H; eauto).

     have (LiveE fs (TRead p)).

     lets D: liveS_liveE_value ss fs (TRead p) l (StDead n).
     spec D n. rip. subst p. snorm. rip.
     have (Some n = Some n). rip.
     have (n = n). rip. nope.
 }

 (*********************************************************)
 Case "XWrite".
 { right.
   inverts_typec. inverts HW. rip.

   have HR: (exists n, t = TRgn n).
    destruct HR as [n]. subst.

   destruct v; burn.

   (* Write to a location. *)
   - inverts_type.

     exists (update n0 (StValue n v0) ss).
     exists sp. exists fs. exists (XVal (VConst CUnit)).

     have (exists b, get n0 ss = Some b).
      dest b.

     destruct b.
     (* Original binding contains a live value that can be overwritten. *)
     + have HB: (TypeB nil nil se sp (StValue n1 v) (TRef (TRgn n) t2))
        by (eapply Forall2_get_get_same; eauto).
       inverts HB.
       eauto.

     (* Original binding is dead,
        can't happen due to binding liveness constraints. *)
     + have HB: (TypeB nil nil se sp (StDead n1)    (TRef (TRgn n) t2))
        by (eapply Forall2_get_get_same; eauto).
       inverts HB.

       remember (TRgn n) as p.

       have (SubsT nil sp e1 (TWrite p) KEffect)
         by  (eapply EqSym in H; eauto).

       have (LiveE fs (TWrite p)).

       lets D: liveS_liveE_value ss fs (TWrite p) n0 (StDead n).
       spec D n. rip. subst p. snorm.
       have (Some n = Some n). rip.
       have (n = n). rip. nope.

   (* Write to a constant, can't happen. *)
   - destruct c; nope.
 }
Qed.


Require Import HoareDef OpenDef Open STB.
Require Import Add0 Repeat0 Add1 Repeat1 Add01proof Repeat01proof.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.

Require Import ProofMode Invariant.

Require Import Imp.
Require Import ImpNotations.
Require Import ImpProofs.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section PROOF.
  Let Σ: GRA.t := GRA.of_list [].
  Local Existing Instance Σ.

  Let FunStb: Sk.t -> gname -> option fspec :=
    fun sk => to_stb [("succ", succ_spec)].

  Let GlobalStb: Sk.t -> gname -> option fspec :=
    fun sk => to_closed_stb (KMod.get_stb [Add1.KAdd; Repeat1.KRepeat FunStb] sk).

  Let FunStb_incl: forall sk,
      stb_incl (FunStb sk) (GlobalStb sk).
  Proof. i. etrans; [|eapply to_closed_stb_weaker]. stb_incl_tac. Qed.

  Let GlobalStb_repeat: forall sk,
      fn_has_spec (GlobalStb sk) "repeat" (Repeat1.repeat_spec FunStb sk).
  Proof. ii. econs; ss. refl. Qed.

  Let FunStb_succ: forall sk,
      fn_has_spec (FunStb sk) "succ" (Add1.succ_spec).
  Proof. ii. econs; ss. refl. Qed.

  Let prog_tgt := [Add0.Add; Repeat0.Repeat].
  Let prog_src := KMod.transl_src_list [Add1.KAdd; Repeat1.KRepeat FunStb].

  Theorem correct: refines2 prog_tgt prog_src.
  Proof.
    etrans; cycle 1.
    { eapply adequacy_open. i. exists ε. splits; ss. g_wf_tac. }
    eapply refines2_cons.
    { eapply Add01proof.correct; et. }
    { eapply Repeat01proof.correct; et. unfold to_closed_stb. ii. des_ifs. }
  Qed.
End PROOF.