(* These proofs use an equivalence defined up to some number of execution steps.

   It's still not totally clear how this works, but this is used inductively to
   prove a congruence theorem about trace_incl for Until.
 *)

Require Import Spec.ConcurExec.
Require Import Spec.ThreadsState.
Require Import Spec.Equiv.Execution.
Require Import Spec.Equiv.TraceIncl.

Require Import ProofAutomation.
Require Import Helpers.Instances.
Require Import Morphisms.
Require Import Spec.Equiv.Automation.

Require Import Omega.

Set Implicit Arguments.

Section OpSemantics.

  Context {Op:Type -> Type}.
  Context {State:Type}.
  Variable op_step: OpSemantics Op State.

  Hint Constructors exec_tid.
  Hint Constructors exec_till.

  (** A stronger notion of equivalence where number of steps taken must be
    identical *)

  Local Definition exec_equiv_ts_N n (ts1 ts2: threads_state Op) :=
    forall (s: State) tr,
      exec_till op_step n s ts1 tr <->
      exec_till op_step n s ts2 tr.

  Definition exec_equiv_N n T (p1 p2: proc Op T) :=
    forall ts tid, exec_equiv_ts_N n (ts [[tid := Proc p1]]) (ts [[tid := Proc p2]]).

  Definition trace_incl_ts_N n (ts1 ts2 : threads_state Op) :=
    forall tr s n',
      n' <= n ->
      exec_till op_step n' s ts1 tr ->
      exec op_step s ts2 tr.

  Definition trace_incl_N n {T} (p1 p2 : proc Op T) :=
    forall (ts: threads_state Op) tid,
      trace_incl_ts_N n
                      (ts [[ tid := Proc p1 ]])
                      (ts [[ tid := Proc p2 ]]).

  Definition trace_incl_rx_N n {T} (p1 p2: proc Op T) :=
    forall TF (rx1 rx2 : _ -> proc _ TF) n0,
      n0 <= n ->
      (forall a, trace_incl_N (n0-1) (rx1 a) (rx2 a)) ->
      trace_incl_N n0 (Bind p1 rx1) (Bind p2 rx2).

  Local Definition trace_incl_rx_N' n {T} (p1 p2: proc Op T) :=
    forall TF (rx1 rx2 : _ -> proc _ TF),
      (forall a, trace_incl_N (n-1) (rx1 a) (rx2 a)) ->
      trace_incl_N n (Bind p1 rx1) (Bind p2 rx2).

  Local Theorem trace_incl_rx_N_to_N' : forall n T (p1 p2: proc Op T),
      trace_incl_rx_N n p1 p2 -> trace_incl_rx_N' n p1 p2.
  Proof.
    unfold trace_incl_rx_N, trace_incl_rx_N', trace_incl_N, trace_incl_ts_N.
    intros.
    eapply H; intros; eauto.
    eapply H0; [ | eassumption ].
    omega.
  Qed.

  Local Definition trace_incl_rx {T} (p1 p2: proc Op T) :=
    forall n, trace_incl_rx_N n p1 p2.

  (* unused, just a remark *)
  Local Theorem trace_incl_rx'_all_n : forall T (p1 p2: proc Op T),
      (forall n, trace_incl_rx_N n p1 p2) ->
      trace_incl_rx' op_step p1 p2.
  Proof.
    unfold trace_incl_rx', trace_incl, trace_incl_ts, trace_incl_ts_s,
    trace_incl_rx_N, trace_incl_N, trace_incl_ts_N.

    intros.
    apply exec_to_counter in H1; propositional.
    eapply H in H1; eauto.
    intros.
    eapply H0.
    eapply exec_till_to_exec; eauto.
  Qed.

  (* unused, just a remark *)
  Local Theorem trace_incl_rx_all_n : forall T (p1 p2: proc Op T),
      (forall n, trace_incl_rx_N n p1 p2) ->
      trace_incl_rx p1 p2.
  Proof.
    unfold trace_incl_rx; eauto.
  Qed.

  (* unused, just a remark *)
  (* this is not true of trace_incl_rx' due to p1 and p2 possibly taking different
numbers of steps *)
  Local Theorem trace_incl_rx_to_N : forall T (p1 p2: proc Op T),
      trace_incl_rx p1 p2 ->
      forall n, trace_incl_rx_N n p1 p2.
  Proof.
    unfold trace_incl_rx; eauto.
  Qed.

  (* unused, just a remark *)
  Local Theorem trace_incl_all_n : forall T (p1 p2: proc Op T),
      (forall n, trace_incl_N n p1 p2) ->
      trace_incl op_step p1 p2.
  Proof.
    unfold trace_incl_rx, trace_incl, trace_incl_ts, trace_incl_ts_s,
    trace_incl_rx_N, trace_incl_N, trace_incl_ts_N.

    intros.
    apply exec_to_counter in H0; propositional.
    eauto.
  Qed.

  Local Theorem exec_equiv_N_bind_bind : forall `(p1 : proc Op T1) `(p2 : T1 -> proc Op T2) `(p3 : T2 -> proc Op T3) n,
      exec_equiv_N n (Bind (Bind p1 p2) p3) (Bind p1 (fun v => Bind (p2 v) p3)).
  Proof.
    split; intros.
    - ExecEquiv p1.
      + ExecOne tid tid'.
        destruct result; eauto.
      + ExecOne tid0 tid'.
        abstract_ts; typeclasses eauto 7 with exec.
    - ExecEquiv p1.
      + ExecOne tid tid'.
        destruct result0; eauto.
      + ExecOne tid0 tid'.
        abstract_ts; typeclasses eauto 7 with exec.
  Qed.

  Local Theorem trace_incl_N_le :
    forall T (p1 p2 : proc _ T) n1 n2,
      trace_incl_N n2 p1 p2 ->
      n1 <= n2 ->
      trace_incl_N n1 p1 p2.
  Proof.
    repeat ( hnf; intros ).
    eapply H in H2; try omega.
    eauto.
  Qed.

  Hint Extern 4 (_ <= _) => omega.

  Local Theorem trace_incl_N_bind_a : forall `(p : proc Op T) `(p2 : T -> proc _ T') p2' n,
      (forall x, trace_incl_N (n-1) (p2 x) (p2' x)) ->
      trace_incl_N n (Bind p p2) (Bind p p2').
  Proof.
    unfold trace_incl_N, trace_incl_ts_N.
    intros.
    ExecEquiv p.
    - destruct result0.
      + ExecPrefix tid tid'.
        eapply H with (n':=n0); eauto.
      + ExecPrefix tid tid'.
        eapply IHexec_till; eauto.
    - ExecPrefix tid0 tid'.
      abstract_ts.
      eapply IHexec_till; eauto with exec.
      auto with exec.
  Qed.

  (* NOTE: this is a specialization of trace_incl_N_bind_a, but it's all that's
  needed for the trace_incl Until proof so I've left a standalone proof *)
  Local Theorem trace_incl_N_ret_bind :
    forall `(v : T) TF (rx1 rx2 : _ -> proc _ TF) n,
      (forall a, trace_incl_N (n - 1) (rx1 a) (rx2 a)) ->
      trace_incl_N n (Bind (Ret v) rx1) (Bind (Ret v) rx2).
  Proof.
    repeat (hnf; intros).
    ExecEquiv tt.
    + ExecPrefix tid tid'.
      eapply H in H4; eauto.
    + ExecPrefix tid0 tid'.
      abstract_ts.
      eapply IHexec_till; eauto with exec.
      auto with exec.
  Qed.

  Global Instance trace_incl_ts_N_reflexive :
    Reflexive (@trace_incl_ts_N n).
  Proof.
    RelInstance_t.
    unfold trace_incl_ts_N; intros.
    eapply exec_till_to_exec; eauto.
  Qed.

  Hint Resolve trace_incl_N_le.

  Global Instance trace_incl_N_reflexive :
    Reflexive (@trace_incl_N n T) := RelInstance.

  Global Instance trace_incl_rx_preorder :
    PreOrder (@trace_incl_rx T).
  Proof.
    RelInstance_t.
    - repeat (hnf; intros).
      eapply trace_incl_N_bind_a; typeclasses eauto with core.
    - repeat (hnf; intros).
      eapply H in H4; intros; try apply le_n; eauto.
      apply exec_to_counter in H4; propositional.
      eapply H0 in H4; try apply le_n; eauto.
      reflexivity.
  Qed.

  Local Theorem trace_incl_rx_to_exec :
    forall T (p1 p2: proc _ T)
      (ts: threads_state _) s tid tr,
      trace_incl_rx p1 p2 ->
      exec op_step s (ts [[tid := Proc p1]]) tr ->
      exec op_step s (ts [[tid := Proc p2]]) tr.
  Proof.
    intros.
    eapply exec_equiv_bind_ret in H0.
    eapply exec_equiv_bind_ret.
    eapply exec_to_counter in H0; propositional.
    eapply H in H0; eauto.
    reflexivity.
  Qed.

  (* TODO: surely this can be proven without using [trace_incl_rx] (only
  [trace_incl_rx'_spawn] is needed, which uses a counter-free definition of
  trace inclusion) *)
  Local Theorem trace_incl_rx_spawn
    : forall T (p1 p2 : proc Op T),
      trace_incl_rx p1 p2 ->
      trace_incl_rx (Spawn p1) (Spawn p2).
  Proof.
    repeat (hnf; intros).
    match goal with
    | H : exec_till _ _ _ (thread_upd ?ts ?tid (Proc ?p)) _ |- _ =>
      remember (thread_upd ts tid (Proc p));
        generalize dependent ts;
        induction H; intros; subst; eauto; NoProc_upd
    end.

    cmp_ts tid0 tid.
    - repeat maybe_proc_inv.
      repeat exec_tid_inv.
      ExecPrefix tid tid'.

      eapply H1 in H6; try omega.
      rewrite thread_upd_ne_comm in H6 |- * by auto.
      eapply trace_incl_rx_to_exec; eauto.
    - ExecPrefix tid0 tid'.
      abstract_ts.
      eapply IHexec_till; eauto with exec; try omega.
      auto with exec.
  Qed.

  Theorem trace_incl_rx_to_trace_incl :
    forall T (p1 p2 : proc Op T),
      trace_incl_rx p1 p2 ->
      forall `(rx : _ -> proc _ TF),
        trace_incl op_step (Bind p1 rx) (Bind p2 rx).
  Proof.
    repeat (hnf; intros).
    eapply exec_to_counter in H0; propositional.
    eapply H; eauto.
    reflexivity.
  Qed.

  Theorem trace_incl_to_trace_incl_rx :
    forall T (p1 p2 : proc Op T),
      (forall `(rx : _ -> proc _ TF),
          trace_incl op_step (Bind p1 rx) (Bind p2 rx)) ->
      trace_incl_rx p1 p2.
  Proof.
    repeat (hnf; intros).
    assert (trace_incl_rx p1 p1) by reflexivity.
    eapply H4 in H3; [ | reflexivity | eassumption | omega ].
    eapply H; eauto.
  Qed.

  Theorem trace_incl_rx'_spawn
    : forall T (p1 p2 : proc Op T),
      trace_incl_rx' op_step p1 p2 ->
      trace_incl_rx' op_step (Spawn p1) (Spawn p2).
  Proof.
    intros.
    unfold trace_incl_rx'; intros.
    etransitivity.
    eapply trace_incl_rx_to_trace_incl.
    eapply trace_incl_rx_spawn.
    eapply trace_incl_to_trace_incl_rx; intros.
    eapply H.
    reflexivity.
    eapply trace_incl_bind_a; eauto.
  Qed.

  Local Theorem trace_incl_rx_N_le :
    forall T (p1 p2 : proc _ T) n1 n2,
      trace_incl_rx_N n2 p1 p2 ->
      n1 <= n2 ->
      trace_incl_rx_N n1 p1 p2.
  Proof.
    repeat ( intro; intros ).
    eapply H in H4.
    eassumption.
    3: reflexivity.
    omega.
    intros.
    eapply trace_incl_N_le; eauto.
  Qed.

  Theorem trace_incl_upto_0 : forall T (p1 p2: proc Op T),
      trace_incl_rx_N 0 p1 p2.
  Proof.
    repeat (hnf; intros).
    replace n' with 0 in * by omega.
    match goal with
    | [ H: exec_till _ _ _ _ _ |- _ ] =>
      invert H; eauto
    end.
  Qed.

  Local Theorem trace_incl_rx_until_helper :
    forall T (p1 p2 : option T -> proc Op T)
      (c : T -> bool) n v,
      (forall v', trace_incl_rx_N (n-1) (p1 v') (p2 v')) ->
      trace_incl_rx_N n (Until c p1 v) (Until c p2 v).
  Proof.
    induction n; intros.

    - apply trace_incl_upto_0.
    - assert (forall v, trace_incl_rx_N n (Until c p1 v) (Until c p2 v)) as IHn'.
      intros.
      eapply IHn; intros.
      eapply trace_incl_rx_N_le; eauto.
      clear IHn.
      replace (S n - 1) with n in * by omega.

      repeat (hnf; intros).
      match goal with
      | H : exec_till _ _ _ _ _ |- _ =>
        invert H; clear H; eauto; NoProc_upd
      end.

      cmp_ts tid0 tid.

      + repeat maybe_proc_inv.
        repeat exec_tid_inv.

        unfold until1 in *.
        lazymatch goal with
        | H : exec_till _ _ _ _ _ |- _ =>
          eapply exec_equiv_N_bind_bind in H
        end.

        match goal with
        | H : exec_till _ _ _ _ _,
              H' : forall _, trace_incl_rx_N _ _ _ |- _ =>
          eapply H' in H; try omega
        end.

        ExecPrefix tid tid'.
        unfold until1.
        rewrite exec_equiv_bind_bind.
        eassumption.
        instantiate (1 := n1); omega.

        simpl; intros.
        destruct (c a).
        * eapply trace_incl_N_ret_bind; eauto.

        * repeat ( intro; intros ).
          eapply IHn' with (n0:=n'); eauto.
        * auto.

      + ExecPrefix tid0 tid'.
        rewrite ConcurExec.thread_upd_abc_to_cab in * by auto.
        eapply IHn' with (n0:=n1) (n':=n1) (rx1:=rx1); intros; try omega; eauto.
  Qed.

  Local Theorem trace_incl_rx_until :
    forall T (p1 p2 : option T -> proc Op T)
      (c : T -> bool) v,
      (forall v', trace_incl_rx (p1 v') (p2 v')) ->
      trace_incl_rx (Until c p1 v) (Until c p2 v).
  Proof.
    repeat ( intro; intros ).
    eapply trace_incl_rx_until_helper in H3; eauto.
    intros; eapply H.
  Qed.

  Theorem trace_incl_rx'_until :
    forall T (p1 p2 : option T -> proc Op T)
      (c : T -> bool) v,
      (forall v', trace_incl_rx' op_step (p1 v') (p2 v')) ->
      trace_incl_rx' op_step (Until c p1 v) (Until c p2 v).
  Proof.
    intros.
    unfold trace_incl_rx'; intros.
    etransitivity.
    eapply trace_incl_rx_to_trace_incl.
    eapply trace_incl_rx_until; intros.
    eapply trace_incl_to_trace_incl_rx; intros.
    eapply H.
    reflexivity.
    eapply trace_incl_bind_a; intros.
    eauto.
  Qed.

  (** Reuse the complicated proof about [Until]. *)

  Theorem exec_equiv_until_body : forall `(p1 : option T -> proc Op T) p2 c v,
      (forall a, exec_equiv_rx op_step (p1 a) (p2 a)) ->
      exec_equiv_rx op_step (Until c p1 v) (Until c p2 v).
  Proof.
    split; intros.
    - eapply exec_to_counter in H0; deex.
      eapply trace_incl_rx_until; try eassumption; try reflexivity.
      intros; eapply trace_incl_to_trace_incl_rx.
      intros; eapply exec_equiv_to_trace_incl.
      eapply H.
    - eapply exec_to_counter in H0; deex.
      eapply trace_incl_rx_until; try eassumption; try reflexivity.
      intros; eapply trace_incl_to_trace_incl_rx.
      intros; eapply exec_equiv_to_trace_incl.
      symmetry.
      eapply H.
  Qed.

  Global Instance Until_exec_equiv_proper :
    Proper (eq ==>
               pointwise_relation _ (exec_equiv_rx op_step) ==>
               eq ==>
               exec_equiv_rx op_step (T:=T)) Until.
  Proof.
    unfold Proper, respectful, pointwise_relation; intros; subst.
    apply exec_equiv_until_body; eauto.
  Qed.

End OpSemantics.


Require Import RelationClasses.
Require Import List.

From sflib Require Import sflib.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.

Set Implicit Arguments.

Module Reg := Ident.
Module RegSet := IdentSet.
Module RegMap := IdentMap.
Module RegFun := IdentFun.

Module Value.
  Inductive t :=
  | reg (reg:Reg.t)
  | const (const:Const.t)
  .

  Definition regs_of (v:t): RegSet.t :=
    match v with
    | reg r => RegSet.singleton r
    | const _ => RegSet.empty
    end.

  Fixpoint regs_of_list (l:list t): RegSet.t :=
    match l with
    | nil => RegSet.empty
    | (reg r)::l => RegSet.add r (regs_of_list l)
    | (const _)::l => regs_of_list l
    end.

  Definition of_nat (n:nat): t := const n.
End Value.
Coercion Value.reg: Reg.t >-> Value.t.
Coercion Value.const: Const.t >-> Value.t.
Coercion Value.of_nat: nat >-> Value.t.

Module Op1.
  Inductive t :=
  | not
  .

  Definition eval (op:t) (op1:Const.t): Const.t :=
    match op with
    | not =>
      if Const.eq_dec op1 Const.zero
      then Const.one
      else Const.zero
    end.
End Op1.

Module Op2.
  Inductive t :=
  | add
  | sub
  | mul
  | eq
  .

  Definition const_eq (op1 op2: Const.t): Const.t :=
    if Const.eq_dec op1 op2 then 0 else 1.

  Definition eval (op:t): forall (op1 op2:Const.t), Const.t :=
    match op with
    | add => Const.add
    | sub => Const.sub
    | mul => Const.mul
    | eq => const_eq
    end.
End Op2.

Module Instr.
  Inductive expr :=
  | expr_val (val:Value.t)
  | expr_op1 (op:Op1.t) (op:Value.t)
  | expr_op2 (op:Op2.t) (op1 op2:Value.t)
  .

  Definition regs_of_expr (r:expr): RegSet.t :=
    match r with
    | expr_val val => Value.regs_of val
    | expr_op1 _ op => Value.regs_of op
    | expr_op2 _ op1 op2 => RegSet.union (Value.regs_of op1) (Value.regs_of op2)
    end.

  Inductive rmw :=
  | fetch_add (addendum:Value.t)
  | cas (old new:Value.t)
  .

  Inductive t :=
  | skip
  | assign (lhs:Reg.t) (rhs:expr)
  | load (lhs:Reg.t) (rhs:Loc.t) (ord:Ordering.t)
  | store (lhs:Loc.t) (rhs:Value.t) (ord:Ordering.t)
  | update (lhs:Reg.t) (loc:Loc.t) (rmw:rmw) (ordr ordw:Ordering.t)
  | fence (ordr ordw:Ordering.t)
  | syscall (lhs:Reg.t) (rhses:list Value.t)
  | abort
  .

  Definition regs_of_rmw (rmw:rmw): RegSet.t :=
    match rmw with
    | fetch_add addendum => (Value.regs_of addendum)
    | cas old new => RegSet.union (Value.regs_of old) (Value.regs_of new)
    end.

  Definition regs_of (i:t): RegSet.t :=
    match i with
    | skip => RegSet.empty
    | assign reg rhs => RegSet.add reg (regs_of_expr rhs)
    | load reg _ _ => RegSet.singleton reg
    | store _ val _ => Value.regs_of val
    | update reg _ rmw _ _ => RegSet.add reg (regs_of_rmw rmw)
    | fence _ _ => RegSet.empty
    | syscall lhs rhses => RegSet.add lhs (Value.regs_of_list rhses)
    | abort => RegSet.empty
    end.

  Inductive ord: forall (i_src i_tgt:Instr.t), Prop :=
  | ord_skip:
      ord Instr.skip Instr.skip
  | ord_assign
      r e:
      ord (Instr.assign r e) (Instr.assign r e)
  | ord_load
      r l o1 o2 (O: Ordering.le o1 o2):
      ord (Instr.load r l o1) (Instr.load r l o2)
  | ord_store
      l v o1 o2 (O: Ordering.le o1 o2):
      ord (Instr.store l v o1) (Instr.store l v o2)
  | ord_update
      r l rmw or1 or2 ow1 ow2
      (OR: Ordering.le or1 or2)
      (OW: Ordering.le ow1 ow2):
      ord (Instr.update r l rmw or1 ow1) (Instr.update r l rmw or2 ow2)
  | ord_fence
      or1 or2 ow1 ow2
      (OR: Ordering.le or1 or2)
      (OW: Ordering.le ow1 ow2):
      ord (Instr.fence or1 ow1) (Instr.fence or2 ow2)
  | ord_syscall
      o i:
      ord (Instr.syscall o i) (Instr.syscall o i)
  | ord_abort:
      ord Instr.abort Instr.abort
  .

  Global Program Instance instr_ord_Reflexive: Reflexive ord.
  Next Obligation. destruct x; econs; refl. Qed.

  Lemma ord_regs_of
        instr_src instr_tgt
        (ORD: ord instr_src instr_tgt):
    Instr.regs_of instr_src = Instr.regs_of instr_tgt.
  Proof. inv ORD; auto. Qed.
End Instr.
Coercion Instr.expr_val: Value.t >-> Instr.expr.

Module Stmt.
  Inductive t :=
  | instr (i:Instr.t)
  | ite (cond:Instr.expr) (c1 c2:list t)
  | dowhile (c:list t) (cond:Instr.expr)
  .

  Lemma ind
        (P: Stmt.t -> Prop)
        (INSTR: forall i, P (Stmt.instr i))
        (ITE: forall cond c1 c2 (THEN: List.Forall P c1) (ELSE: List.Forall P c2), P (Stmt.ite cond c1 c2))
        (WHILE: forall c cond (LOOP: List.Forall P c), P (Stmt.dowhile c cond)):
    forall stmt, P stmt.
  Proof.
    fix IH 1.
    i. destruct stmt.
    - eapply INSTR.
    - eapply ITE.
      + induction c1; ss.
        econs; eauto.
      + induction c2; ss.
        econs; eauto.
    - eapply WHILE.
      induction c; ss.
      econs; eauto.
  Qed.
End Stmt.
Coercion Stmt.instr: Instr.t >-> Stmt.t.


Require Import GHC.Base.
Require State.
Require Data.Traversable.

Set Bullet Behavior "Strict Subproofs".

Local Ltac expand_pairs :=
match goal with
  |- context[let (_,_) := ?e in _] =>
  rewrite (surjective_pairing e)
end.

Definition SP {a} {s} (P Q : s -> Prop) (R : a -> Prop) (act : State.State s a) :=
  forall s, P s -> Q (snd (State.runState' act s)) /\ R (fst (State.runState' act s)).

Definition StateInvariant {a} {s} (P : s -> Prop) (act : State.State s a) :=
  SP P P (fun _ => True) act.

Lemma SP_snd_runState:
  forall {a s} (P P' : s -> Prop) (R : a -> Prop) (act : State.State s a) (x : s),
  SP P P' R act ->
  P x ->
  P' (snd (State.runState act x)).
Proof.
  intros.
  unfold State.runState.
  expand_pairs. simpl.
  apply H. assumption.
Qed.

Lemma SP_return:
  forall {a s} (P : s -> Prop) (Q : a -> Prop) (x : a),
  Q x -> SP P P Q (return_ x).
Proof. intros. intros s0 HP. split; assumption. Qed.

Lemma StateInvariant_return:
  forall {a s} (P : s -> Prop) (x : a),
  StateInvariant P (return_ x).
Proof. intros. apply SP_return. trivial. Qed.

Lemma SP_put:
  forall {s} (P P' : s -> Prop) x,
  P' x ->
  SP P P' (fun _ => True) (State.put x).
Proof. intros. intros s0 _. split; [ apply H | trivial ]. Qed.

Lemma SP_get:
  forall {s} (P : s -> Prop),
  SP P P P State.get.
Proof. intros. intros s0 H. split; assumption. Qed.

Lemma SP_bind:
  forall {a b s} P P' P'' R R' (act1 : State.State s a) (act2 : a -> State.State s b),
  SP P P' R act1 ->
  (forall x, R x -> SP P' P'' R' (act2 x)) ->
  SP P P'' R' (act1 >>= act2).
Proof.
  intros ?????????? H1 H2.
  intros s0 H.
  simpl.
  expand_pairs; simpl.
  eapply H2; apply H1; assumption.
Qed.

Lemma StateInvariant_bind:
  forall {a b s} P (act1 : State.State s a) (act2 : a -> State.State s b),
  StateInvariant P act1 ->
  (forall x, StateInvariant P (act2 x)) ->
  StateInvariant P (act1 >>= act2).
Proof.
  intros. eapply SP_bind.
  * apply H.
  * intros ? _.  apply H0.
Qed.

Lemma StateInvariant_bind_return: (*  acommon pattern *)
  forall {a b s} P (act1 : State.State s a) (f : a -> b),
  StateInvariant P act1 ->
  StateInvariant P (act1 >>= (fun x => return_ (f x))).
Proof.
  intros.
  apply StateInvariant_bind.
  * apply H.
  * intro. apply StateInvariant_return.
Qed.

Lemma StateInvariant_liftA2:
  forall {a b c s} P (f : a -> b -> c) (act1 : State.State s a) (act2 : State.State s b),
  StateInvariant P act1 ->
  StateInvariant P act2 ->
  StateInvariant P (liftA2 f act1 act2).
Proof.
  intros.
  unfold liftA2, State.Applicative__State, liftA2__, State.Applicative__State_liftA2,
         State.Applicative__State_op_zlztzg__.
  intros s0 HPs0.
  simpl.
  repeat (expand_pairs;simpl).
  split; only 2: trivial.
  apply H0. apply H. apply HPs0.
Qed.

Lemma StateInvariant_mapM:
  forall {a b s} P (act : a -> State.State s b) (xs : list a),
  (forall x, In x xs -> StateInvariant P (act x)) ->
  StateInvariant P (Traversable.mapM act xs).
Proof.
  intros ?????? Hact.
  unfold Traversable.mapM, Traversable.Traversable__list, Traversable.mapM__,
         Traversable.Traversable__list_mapM, Traversable.Traversable__list_traverse.
  induction xs.
  * apply StateInvariant_return.
  * simpl.
    apply StateInvariant_liftA2.
    - apply Hact. left. reflexivity.
    - apply IHxs. intros x Hin. apply Hact. right. assumption.
Qed.

Lemma StateInvariant_forM:
  forall {a b s} P (act : a -> State.State s b) (xs : list a),
  (forall x, In x xs -> StateInvariant P (act x)) ->
  StateInvariant P (Traversable.forM xs act).
Proof.
  intros.
  unfold Traversable.forM, flip.
  apply StateInvariant_mapM.
  assumption.
Qed.

Definition RevStateInvariant {a} {s} (P : s -> Prop) (act : State.State s a)  (R : a -> Prop) :=
  forall s, P (snd (State.runState' act s)) -> P s /\ R (fst (State.runState' act s)).

Lemma RevStateInvariant_runState {a} {s} (P : s -> Prop)  (act : State.State s a)  (R : a -> Prop)(s0 : s) :
  RevStateInvariant P act R ->
  P (snd (State.runState act s0)) ->
  R (fst (State.runState act s0)).
Proof.  unfold State.runState in *. expand_pairs. intros. apply H. apply H0. Qed.

Lemma RevStateInvariant_return {a} {s} (P : s -> Prop) (x : a)  (R : a -> Prop):
  R x ->
  RevStateInvariant P (return_ x) R.
Proof. intros. intros ??. simpl in *. intuition. Qed.

Lemma RevStateInvariant_bind {a b} {s} (P : s -> Prop)
    (act1 : State.State s a) (act2 : a -> State.State s b)
    (Q : a -> Prop) (R : b -> Prop):
  RevStateInvariant P (act1) Q ->
  (forall x,  RevStateInvariant P (act2 x) (fun x' => Q x -> R x')) ->
  RevStateInvariant P (act1 >>= act2) R.
Proof.
  intros Hact1 Hact2.
  unfold RevStateInvariant,
         op_zgzgze__, State.Monad__State, op_zgzgze____, State.Monad__State_op_zgzgze__ in *.
  simpl in *.
  intro s0.
  expand_pairs. simpl in *.
  intros HPs''.
  split.
  * apply Hact1.
    apply (Hact2 (fst (State.runState' act1 s0)) (snd (State.runState' act1 s0)) HPs'').
  * apply Hact2.
    + apply HPs''.
    + apply Hact1.
      apply (Hact2 (fst (State.runState' act1 s0)) (snd (State.runState' act1 s0)) HPs'').
Qed.

Lemma RevStateInvariant_impl {a} {s} (P : s -> Prop)
    (act1 : State.State s a) (R Q : a -> Prop):
  RevStateInvariant P act1 R ->
  (forall x, R x -> Q x) ->
  RevStateInvariant P act1 Q.
Proof.
  intros Hact1 Himpl.
  split.
  * apply Hact1. apply H.
  * apply Himpl. apply Hact1. apply H.
Qed.

Lemma RevStateInvariant_bind_return {a b} {s} (P : s -> Prop)
    (act1 : State.State s a) (f : a -> b)
    (R : b -> Prop):
  RevStateInvariant P act1 (fun x => R (f x)) ->
  RevStateInvariant P (act1 >>= (fun x => return_ (f x))) R.
Proof.
  intros Hact1.
  eapply RevStateInvariant_bind.
  * apply Hact1.
  * intro x.
    apply RevStateInvariant_return.
    auto.
Qed.

Lemma RevStateInvariant_liftA2:
  forall {a b c s} P (f : a -> b -> c) (act1 : State.State s a) (act2 : State.State s b) R1 R2 (R3 : c -> Prop),
  RevStateInvariant P act1 R1 ->
  RevStateInvariant P act2 R2 ->
  (forall x y, R1 x -> R2 y -> R3 (f x y)) ->
  RevStateInvariant P (liftA2 f act1 act2) R3.
Proof.
  intros ??????????? Hact1 Hact2 Hf s1.
  unfold liftA2, State.Applicative__State, liftA2__, State.Applicative__State_liftA2,
         State.Applicative__State_op_zlztzg__.
  simpl; repeat (expand_pairs;simpl).
  intro HPs3.
  split.
  * apply Hact1.
    apply Hact2.
    assumption.
  * apply Hf.
    + apply Hact1.
      apply Hact2.
      assumption.
    + apply Hact2.
      assumption.
Qed.

Lemma RevStateInvariant_mapM2:
  forall {a b s} P (act : a -> State.State s b) (xs : list a) R,
  (forall x, In x xs -> RevStateInvariant P (act x) (R x)) ->
  RevStateInvariant P (Traversable.mapM act xs) (Forall2 R xs).
Proof.
  intros ??????? Hact.
  unfold Traversable.mapM, Traversable.Traversable__list, Traversable.mapM__,
         Traversable.Traversable__list_mapM, Traversable.Traversable__list_traverse.
  induction xs.
  * apply RevStateInvariant_return. constructor.
  * simpl.
    apply RevStateInvariant_liftA2 with (R1 := R a0) (R2 := Forall2 R xs).
    - apply Hact. left. reflexivity.
    - apply IHxs. intros x Hin. apply Hact. right. assumption.
    - intros. constructor; assumption.
Qed.

Lemma RevStateInvariant_forM2:
  forall {a b s} P (act : a -> State.State s b) (xs : list a) R,
  (forall x, In x xs -> RevStateInvariant P (act x) (R x)) ->
  RevStateInvariant P (Traversable.forM xs act) (Forall2 R xs).
Proof.
  intros.
  unfold Traversable.forM, flip.
  apply RevStateInvariant_mapM2.
  assumption.
Qed.

Lemma Forall2_const_Forall:
  forall {a b} R (xs : list a) (ys : list b),
  Forall2 (fun _ => R) xs ys -> Forall R ys.
Proof.
  intros. induction H.
  * constructor.
  * constructor; assumption.
Qed.

Lemma Forall2_and:
  forall {a b} P Q (xs : list a) (ys : list b),
  Forall2 (fun x y => P x y /\ Q x y) xs ys -> (Forall2 P xs ys /\ Forall2 Q xs ys).
Proof.
  intros. induction H.
  * constructor; constructor.
  * constructor; constructor; intuition.
Qed.

Lemma Forall2_eq:
  forall {a b c} (f : a -> c) (g : b -> c) (xs : list a) (ys : list b),
  Forall2 (fun x y => f x = g y) xs ys -> List.map f xs = List.map g ys.
Proof.
  intros. induction H.
  * reflexivity.
  * simpl. f_equal; assumption.
Qed.

Lemma RevStateInvariant_forM:
  forall {a b s} P (act : a -> State.State s b) (xs : list a) R,
  (forall x, In x xs -> RevStateInvariant P (act x) R) ->
  RevStateInvariant P (Traversable.forM xs act) (Forall R).
Proof.
  intros.
  eapply RevStateInvariant_impl.
  * apply RevStateInvariant_forM2.
    apply H.
  * apply Forall2_const_Forall.
Qed.


From stbor.lang Require Import expr_semantics.

(** Induction scheme for expressions *)
Lemma expr_ind (P : expr → Prop):
  (∀ v, P (Val v)) →
  (∀ x, P (Var x)) →
  (∀ e el, P e → Forall P el → P (Call e el)) →
  (∀ e, P e → P (InitCall e)) →
  (∀ e, P e → P (EndCall e)) →
  (∀ e1 e2, P e1 → P e2 → P (Proj e1 e2)) →
  (∀ e1 e2, P e1 → P e2 → P (Conc e1 e2)) →
  (∀ o e1 e2, P e1 → P e2 → P (BinOp o e1 e2)) →
  (∀ l tg ty, P (Place l tg ty)) →
  (∀ e ty, P e → P (Deref e ty)) →
  (∀ e, P e → P (Ref e)) →
  (∀ e, P e → P (Copy e)) →
  (∀ e1 e2, P e1 → P e2 → P (Write e1 e2)) →
  (∀ ty, P (Alloc ty)) →
  (∀ e, P e → P (Free e)) →
  (∀ e pk T rk, P e → P (Retag e pk T rk)) →
  (∀ b e1 e2, P e1 → P e2 → P (Let b e1 e2)) →
  (∀ e el, P e → Forall P el → P (Case e el)) →
  ∀ e, P e.
Proof.
  intros. revert e. fix REC 1. destruct e; try
  (* Find head symbol, then find lemma for that symbol.
     We have to be this smart because we can't use the unguarded [REC]! *)
  match goal with
  | |- P (?head _ _ _ _) =>
    match goal with H : context[head] |- _ => apply H; try done end
  | |- P (?head _ _ _) =>
    match goal with H : context[head] |- _ => apply H; try done end
  | |- P (?head _ _) =>
    match goal with H : context[head] |- _ => apply H; try done end
  | |- P (?head _) =>
    match goal with H : context[head] |- _ => apply H; try done end
  end.
  (* 2 remaining cases: The [Forall]. *)
  induction el; eauto using Forall.
  induction el; eauto using Forall.
Qed.

(** Parallel Substitution. *)
Definition binder_delete {T} (b: binder) (xs: gmap string T) :=
  if b is BNamed x then delete x xs else xs.
Definition binder_insert {T} (b: binder) (r: T) (xs: gmap string T) :=
  if b is BNamed x then <[x:=r]> xs else xs.
Fixpoint subst_map (xs : gmap string result) (e : expr) : expr :=
  match e with
  | Var y => if xs !! y is Some v then of_result v else Var y
  | Val v => Val v
  | Call e el => Call (subst_map xs e) (fmap (subst_map xs) el)
  | InitCall e => InitCall (subst_map xs e)
  | EndCall e => EndCall (subst_map xs e)
  | Place l tag T => Place l tag T
  | BinOp op e1 e2 => BinOp op (subst_map xs e1) (subst_map xs e2)
  | Proj e1 e2 => Proj (subst_map xs e1) (subst_map xs e2)
  | Conc e1 e2 => Conc (subst_map xs e1) (subst_map xs e2)
  | Copy e => Copy (subst_map xs e)
  | Write e1 e2 => Write (subst_map xs e1) (subst_map xs e2)
  | Alloc T => Alloc T
  | Free e => Free (subst_map xs e)
  | Deref e T => Deref (subst_map xs e) T
  | Ref e => Ref (subst_map xs e)
  | Retag e pk T kind => Retag (subst_map xs e) pk T kind
  | Let x1 e1 e2 =>
      Let x1
        (subst_map xs e1)
        (subst_map (binder_delete x1 xs) e2)
  | Case e el => Case (subst_map xs e) (fmap (subst_map xs) el)
  end.

Lemma subst_map_empty e :
  subst_map ∅ e = e.
Proof.
  induction e using expr_ind; simpl; f_equal; eauto.
  - induction H; first done. simpl. by f_equal.
  - destruct b; first done. simpl. rewrite delete_empty. done.
  - induction H; first done. simpl. by f_equal.
Qed.

Lemma subst_map_subst map x (r: value) (e: expr) :
  subst_map map (subst x r e) = subst_map (<[x:=ValR r]>map) e.
Proof.
  revert x r map; induction e using expr_ind; intros xx r map; simpl;
  try (f_equal; eauto).
  - case_bool_decide.
    + simplify_eq/=. rewrite lookup_insert. destruct r; done.
    + rewrite lookup_insert_ne //.
  - induction H; first done. simpl. f_equal; done.
  - destruct b; simpl. done.
    case_bool_decide.
    + rewrite IHe2. f_equal. rewrite delete_insert_ne //.
      intros ?. apply H. f_equal. done.
    + simplify_eq/=. rewrite delete_insert_delete //.
  - induction H; first done. simpl. f_equal; done.
Qed.

(** Turning list-subst into par-subst while preserving a pointwise property.
FIXME: There probably is a way to do this with a lemma that talks about
just one list... *)
Lemma subst_l_map (xbs : list binder) (xes xet : list value)
  (ebs ebt es et : expr) (R : result → result → Prop) :
  subst_l xbs (Val <$> xes) ebs = Some es →
  subst_l xbs (Val <$> xet) ebt = Some et →
  Forall2 R (ValR <$> xes) (ValR <$> xet) →
  ∃ map : gmap string (result * result),
  es = subst_map (fst <$> map) ebs ∧ et = subst_map (snd <$> map) ebt ∧
  map_Forall (λ _ '(s, t), R s t) map.
Proof.
  revert xes xet ebs ebt es et; induction xbs;
  intros xes xet ebs ebt es et Hsubst1 Hsubst2 HR; simplify_eq/=.
  - exists ∅. rewrite !fmap_empty !subst_map_empty.
    destruct xes; last done. destruct xet; last done. simplify_eq/=.
    split; first done. split; first done.
    apply map_Forall_empty.
  - destruct xes as [|ees xes]; first done. destruct xet as [|eet xet]; first done.
    inversion HR. simplify_eq/=. destruct a.
    + eapply IHxbs; eauto.
    + edestruct (IHxbs xes xet) as (map & ? & ? & ?); [done..|].
      exists (<[s:=(ValR ees, ValR eet)]> map). simplify_eq/=.
      rewrite !subst_map_subst !fmap_insert.
      split; first done. split; first done.
      apply map_Forall_insert_2; done.
Qed.

Lemma subst_subst_map x (r: result) map e :
  subst x r (subst_map (delete x map) e) =
  subst_map (<[x:=r]>map) e.
Proof.
  revert map r x; induction e using expr_ind; intros map r xx; simpl;
  try (f_equal; eauto).
  - destruct (decide (xx=x)) as [->|Hne].
    + rewrite lookup_delete // lookup_insert //. simpl.
      rewrite bool_decide_true //.
    + rewrite lookup_delete_ne // lookup_insert_ne //.
      destruct (map !! x) as [rr|].
      * by destruct rr.
      * simpl. rewrite bool_decide_false //.
  - induction H; first done. simpl. by f_equal.
  - destruct b; simpl; first by auto.
    case_bool_decide.
    + rewrite delete_insert_ne //. { intros [=EQ]. apply H. f_equal. done. }
      rewrite delete_commute. apply IHe2.
    + simplify_eq. rewrite delete_idemp delete_insert_delete. done.
  - induction H; first done. simpl. by f_equal.
Qed.

Lemma subst'_subst_map b (r: result) map e :
  subst' b r (subst_map (binder_delete b map) e) =
  subst_map (binder_insert b r map) e.
Proof.
  destruct b; first done.
  exact: subst_subst_map.
Qed.

Lemma binder_insert_map {T U: Type} b (r: T) (f : T → U) map :
  binder_insert b (f r) (f <$> map) =
  f <$> binder_insert b r map.
Proof.
  destruct b; first done. simpl.
  rewrite fmap_insert. done.
Qed.


Require Export CatSem.STS.STS_representations.
(*Require Setoid.*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** in this file we define
    - STS, the initial monad
    - Var, a constructor of STS
    - rename, the functoriality
    - inj, renaming with (v => Some v)
    - shift, taking the substitution function and changing it in a capture
             avoiding fashion
    - subst, the substitution

    correspondences to the general monad definitions
        (STS left, Monad right):
    - Var = weta
    - rename f = lift f
    - inj = lift weta
    - shift = opt_inj
    - subst = kleisli

    subst is defined in terms of rename. this is precisely the other way
       round for monads.
    after having established monadicity, we must show:
    - rename = lift
    - shift = opt_inj
*)

Section initial_type.

Ltac fin := simpl in *; intros; autorewrite with fin; auto with fin.

Variable T : Type.
Variable S : Signature T.
Notation "V * u" := (opt u V).
Notation "V ** l" := (pow l V) (at level 10).
Notation "f ^^ l" := (pow_map (l:=l) f) (at level 10).
Notation "^ f" := (lift (M:= opt_monad _) f) (at level 5).
Notation "[ T ]" := (list T) (at level 5).

(** STS will be the initial monad, STS_list represents the arguments of
     a constructor *)
(** STS_list is actually isomorphic to [prod_mod_carrier STS], but
    we wouldn't get such a nice induction scheme with a non-mutual
    inductive type
*)

Inductive STS (V : ITYPE T) : ITYPE T :=
  | Var : forall t, V t -> STS V t
  | Build : forall t (i : sig_index (S t)),
        prod_mod_c STS V (sig i) -> STS V t.

Section STS_ind2.

Variable P : forall V t, STS V t -> Prop.

Variable Q : forall V l, prod_mod_c STS V l -> Prop.
(*
Variable Q : forall V t (i : sig_index (S t)),
      prod_mod_c STS V (sig i) -> Prop.
*)
Hypothesis H : forall V t (i : sig_index (S t))
                     (x : prod_mod_c STS V (sig i)),
          Q  x -> P (Build x).

Hypothesis HVar : forall V (t : T) (v : V t), P (Var v).

Hypothesis H0 : forall V, Q (TTT STS V).

Hypothesis H1 : forall V b l (x : STS (V ** (fst b)) (snd b)), P x ->
         forall s : prod_mod_c STS V l, Q s ->
                Q (CONSTR x s).

Fixpoint STSind V t (x : STS V t) : P x :=
   match x as r return P r with
   | Var _ v => HVar v
   | Build t i s => H
         ((fix STSind2 V l (s' : prod_mod_c STS V l) : Q s' :=
              match s' as q return Q q with
              | TTT  => H0 _
              | CONSTR _ _ b bs =>
                      H1 (STSind b) (STSind2 _ _ bs)
              end) _ _ s)
   end.

End STS_ind2.
(*
Section STS_ind_i.

Variable P : forall V t, STS V t -> Prop.

Variable Q : forall V t (i : sig_index (S t)),
      prod_mod_c STS V (sig i) -> Prop.

Hypothesis H : forall V t (i : sig_index (S t))
                     (x : prod_mod_c STS V (sig i)),
          Q  x -> P (Build x).

Hypothesis HVar : forall V (t : T) (v : V t), P (Var v).
(*
Hypothesis H0 : forall V, Q (TTT STS V).
*)
Hypothesis H1 : forall V b (x : STS (V ** (fst b)) (snd b)), P x ->
         forall i (s : prod_mod_c STS V (sig i)), Q s ->
                Q (CONSTR x s).

Fixpoint STSind V t (x : STS V t) : P x :=
   match x as r return P r with
   | Var _ v => HVar v
   | Build t i s => H
         ((fix STSind2 V l (s' : prod_mod_c STS V l) : Q s' :=
              match s' as q return Q q with
              | TTT  => H0 _
              | CONSTR _ _ b bs =>
                      H1 (STSind b) (STSind2 _ _ bs)
              end) _ _ s)
   end.
*)
Section Forall_def.

Variable M : ITYPE T -> ITYPE T.

Inductive Forall V (P : forall V t, M V t -> Prop) :
      forall l, prod_mod_c M V l -> Prop :=
 | Forall_nil : Forall P (TTT _ _ )
 | Forall_cons : forall b (x : M (V**(fst b)) (snd b)),
        P _ _  x ->
        forall l (xl : prod_mod_c M V l),
          Forall P xl -> Forall P
         (CONSTR x xl).

End Forall_def.

Section forall_ind.

Variable P : forall V t, STS V t -> Prop.

Hypothesis NVar : forall V (t:T) (v : V t), P (Var v).

Hypothesis NBuild : forall V t (i : sig_index (S t))
          (x : prod_mod_c STS V (sig i)),
      Forall P x -> P (Build x).

Fixpoint STS_ind2 V t (x : STS V t) : P x :=
  match x return P x with
  | Var _ v => NVar v
  | Build t i s => NBuild
    ((fix list_STS_ind2 V l (y : prod_mod_c STS V l) :
                Forall P y :=
         match y return Forall P y with
         | TTT => Forall_nil _ P
         | CONSTR _ _ e el =>
              @Forall_cons STS V P _ e (STS_ind2 e)
                     _ _ (list_STS_ind2 V _ el)
              end) _ _ s)
  end.

End forall_ind.

Section rename.

Section STS_rect2.

Variable X : forall V t, STS V t -> Type.
Variable Y : forall V l, prod_mod_c STS V l -> Type.

Hypothesis H : forall V t (i : sig_index (S t))
                     (x : prod_mod_c STS V (sig i)),
          Y x -> X (Build x).

Hypothesis HVar : forall V (t : T) (v : V t), X (Var v).

Hypothesis H0 : forall V, Y (TTT STS V).

Hypothesis H1 : forall V b l (x : STS (V ** (fst b)) (snd b)), X x ->
         forall s : prod_mod_c STS V l, Y s ->
                Y (CONSTR x s).

Fixpoint STSrect V t (x : STS V t) : X x :=
   match x as r return X r with
   | Var _ v => HVar v
   | Build t i s => H
         ((fix STSrect2 V l (s' : prod_mod_c STS V l) : Y s' :=
              match s' as q return Y q with
              | TTT  => H0 _
              | CONSTR _ _ b bs =>
                      H1 (STSrect b) (STSrect2 _ _ bs)
              end) _ _ s)
   end.

End STS_rect2.
(*
Inductive STS (V : ITYPE T) : ITYPE T :=
  | Var : forall t, V t -> STS V t
  | Build : forall t (i : sig_index (S t)),
             STS_list V (sig i) -> STS V t
with
STS_list (V : ITYPE T) :
            [[T] * T] -> Type :=
  | TT : STS_list V nil
  | constr : forall b bs,
      STS (V ** (fst b)) (snd b) ->
      STS_list V bs ->
      STS_list V (b::bs).

Scheme STSind := Induction for STS Sort Prop with
       STSlistind := Induction for STS_list Sort Prop.
*)
(*
Lemma constr_eq : forall (V : ITYPE T) (b : [T] * T)
            (bs : [[T] * T]) (x y : STS _ (snd b))
              (v w : STS_list V bs),
     x = y -> v = w -> constr x v = constr y w.
Proof.
  intros V b bs x y v w H H'.
  rewrite H;
  rewrite H';
  auto.
Qed.

Hint Rewrite constr_eq : fin.
Hint Resolve constr_eq f_equal : fin.
*)
Reserved Notation "x //- f" (at level 42, left associativity).
Reserved Notation "x //-- f" (at level 42, left associativity).
(*
Fixpoint rename (V : ITYPE T)
             (W : ITYPE T) (f : V ---> W) t (v : STS V t) {struct v} :=
    match v in STS _ t return STS W t with
    | Var t v => Var (f t v)
    | Build  t i l => Build (i:=i) (list_rename l f)
    end
with
  list_rename V t (l : prod_mod_c STS  V t) W (f : V ---> W) {struct l} :
           prod_mod_c STS W t :=
     match l in prod_mod_c _ _ t return prod_mod_c STS W t with
     | TTT => TTT _ _
     | CONSTR b bs elem elems =>
             CONSTR (elem //- ( f ^^ (fst b)))
                               (elems //-- f)
     end
where "x //- f" := (rename f x)
and "x //-- f" := (list_rename x f).
*)

Section list_iter.

(** given a function on STS, we want to use it on prod_mod_c STS *)

Variable op : forall V W t, STS V t -> STS W t.

Fixpoint list_iter V W l (s : prod_mod_c STS V l) : prod_mod_c STS W l :=
     match s in prod_mod_c _ _ l return prod_mod_c STS W l with
     | TTT => TTT _ W
     | CONSTR _ _ b bs => CONSTR (op _ b) (list_iter _ bs)
     end.

End list_iter.
(** renaming is a mutually recursive function *)

(*
Fixpoint rename (V : ITYPE T) (W : ITYPE T)
    (f : V ---> W) t (v : STS V t) : STS W t :=
    match v in STS _ t return STS W t with
    | Var t v => Var _ _ (f t v)
    | Build t i s =>
         Build W t i
    (( fix rename_ V0 W0 (f0 : V0 ---> W0)
          l (s' : prod_mod_c STS V0 l) : prod_mod_c STS W0 l :=
            match s' in prod_mod_c _ _ l' return prod_mod_c STS W0 l' with
            | TTT => TTT _ _
            | CONSTR b bs elem elems =>
                    CONSTR  (M:=STS) (V:=W0) (b:=b)(bs:=bs)
                       (rename (*V0 ** (fst b)) (W0 ** (fst b)*) _ _
                           (f0 ^^ (fst b)) _ elem)
                           (rename_ V0 W0 f0 bs elems)
            end) V W f _ s)
    end.
*)

Fixpoint rename (V : ITYPE T) (W : ITYPE T)
    (f : V ---> W) t (v : STS V t) : STS W t :=
    match v in STS _ t return STS W t with
    | Var t v => Var (f t v)
    | Build t i s =>
         Build
    (( fix rename_
          l (s' : prod_mod_c STS V l) : prod_mod_c STS W l :=
            match s' in prod_mod_c _ _ l' return prod_mod_c STS W l' with
            | TTT => TTT _ _
            | CONSTR b bs elem elems =>
                    CONSTR (rename (f ^^ (fst b)) elem)
                           (rename_ _ elems)
            end) _ s)
    end.

Fixpoint list_rename V W f l (x : prod_mod_c STS V l) :
                     prod_mod_c STS W l :=
     match x in prod_mod_c _ _ l return prod_mod_c STS W l with
     | TTT => TTT _ _
     | CONSTR b bs elem elems =>
            CONSTR (rename (f ^^ (fst b)) elem)
                   (list_rename _ f elems)
     end.

Notation "x //- f" := (rename f x).
Notation "x //-- f" := (list_rename f x).

(*
Lemma ren V t (i : sig_index (S t)) (x : prod_mod_c STS V (sig i))
          W (f : V ---> W):
       rename f (Build x) = Build (list_rename f x).
Proof.
  intros V t i x.

  intros.

  elim x using
  dependent induction x.
  rewrite <- x.
  simpl.
  apply f_equal.

  dependent induction x0.
  *)

(** functoriality of renaming for STS *)

Require Import Coq.Program.Equality.

Lemma rename_eq : forall (V : T -> Type) (t : T) (v : STS V t)
         (W : T -> Type) (f g : V ---> W),
     (forall t x, f t x = g t x) -> v //- f = v //- g.
Proof.
  intros. Check STSind. Check STS_ind2.
  induction v using STS_ind2.
  simpl.
  intros.
  rewrite H.
  auto.
  dependent induction H0.
  assert (H':=JMeq_eq x).
  destruct x.
  dependent induction x.
  inversion H0.
  simpl.
  apply f_equal.
  destruct H0.
  auto.
  apply CONSTR_eq.

  simpl.
  auto.
  apply subst_eq.
  simpl.
   (STSind (Q:=fun V l x => Build x //- f = Build x //- g)).
  simpl.
  intros.
  rewrite H.

  auto.
  inversion H0.
  subst.

  case x.
  dependent induction x.
  destruct x0.

  simpl.

  dependent destruction x.
  s
  simpl.
  intros.
  generalize dependent H.

  simpl.
  elim x;
  simpl.

  assert (H:= (@STSind
       (fun (a : T -> Type) t (v : STS a t) =>
            forall (b : T -> Type)(f g : a ---> b),
         (f == g) ->
         rename (W:=b) f v = rename (W:=b) g v))
       (fun V l (v : prod_mod_c STS V l) =>
            forall (b : T -> Type)(f g : V ---> b),
         (f == g) ->
         list_rename f v = list_rename g v)).
  apply H;
  clear H; lazy iota beta delta; intros.

  apply f_equal.
  fold rename_.
  unfold list_rename in H.

  intros V t i s H' W f g H2;
  simpl.
  apply f_equal;
  auto.
  unfold list_rename in H'.

  apply H'.
  simpl.

  intros V t v b f g H';
  simpl.
  rewrite H'.
  auto.

  intros V t i s H' W f g H2;
  simpl.
  apply f_equal;
  auto.

  intros; simpl;
  auto.

  intros V b bs s H'
  s0 H2 W f g H3;
  simpl.
  apply constr_eq;
  auto.
  apply H'.
  rewrite H3.
  cat.
Qed.

Hint Resolve rename_eq constr_eq : fin.
Hint Rewrite rename_eq constr_eq : fin.

Obligation Tactic := unfold Proper ; red; fin.

Program Instance rename_oid V W :
  Proper (A:=(V ---> W) -> (STS V ---> STS W))
       (equiv ==> equiv) (@rename V W).

Lemma rename_id V t (x : STS V t) : x //- id _ = x .
Proof.
  assert (H:= @STSind
      (fun a t (x : STS a t) =>
           x //- id _ = x)
      (fun a t (l : STS_list a t) =>
            l //-- id _ = l)).
  apply H;
  simpl;
  auto;
  clear H.

  intros V t i s H.
  rewrite H.
  auto.

  intros V b bs s H s0 H1.
  rewrite <- H at 2.
  assert (H':=preserve_ident (Func:=POW (fst b))).
  fin.
Qed.

Lemma rename_comp V t (x : STS V t) W (f : V ---> W) X (g : W ---> X):
 x //- (fun s y => g s (f s y)) =  x //- f //- g.
Proof.
  assert (H:= @STSind
   (fun a t (x : STS a t) =>
     forall b (f : a ---> b) c (g : b ---> c),
      x //- (f ;; g) = x //- f //- g)
   (fun a t (l : STS_list a t) =>
     forall b (f : a ---> b) c (g : b ---> c),
      l //-- (f ;; g) = l //-- f //-- g )).
  apply H;
  simpl;
  auto;
  clear H.

  intros V t i s H0 W f X g.
  rewrite H0.
  auto.

  intros V b bs s H s0 H0 b0 f c g.
  rewrite <- H.
  assert (H':=preserve_comp (Func:=POW (fst b))).
  fin.
Qed.

Hint Rewrite rename_comp rename_id : fin.
Hint Resolve rename_comp rename_id : fin.

Obligation Tactic := fin.

Program Instance rename_func : Func (Fobj := @STS) rename.

(** injection of a term into the type of terms with one more variable *)

Definition inj u V := rename (V:=V) (W:=V * u)
                (@some T u V).

Definition inj_list u V :=
    fun t (v : STS_list V t) => list_rename v (@some T u V).

(** the shifting, needed to avoid capture *)
(** we'll call it _shift in order to avoid clash with generic shift *)

Definition _shift (u : T) (V W : ITYPE T) (f : V ---> STS W) :
         V * u ---> STS (W * u) :=
   fun t v =>
   match v in (opt _ _ y) return (STS (W * u) y) with
   | some t0 p => inj u (f t0 p)
   | none => Var (none u W)
   end.

Notation "x >- f" := (_shift f x) (at level 40).

(** same for lshift, being given a list of object language types *)

Fixpoint _lshift (l : [T]) (V W : ITYPE T) (f : V ---> STS W) :
        V ** l ---> STS (W ** l) :=
    match l return V ** l ---> STS (W**l) with
    | nil => f
    | b::bs => @_lshift bs _ _ (_shift (u:=b) f)
    end.

(*Implicit Arguments shift_l [V W t].*)

Notation "x >>-- f" := (_lshift f x) (at level 40).

(*Notation "f $$ l" := (shift_list l f) (at level 20).*)

(** finally the substitution *)
Reserved Notation "x >== f" (at level  59, left associativity).
Reserved Notation "x >>== f" (at level 59, left associativity).

Fixpoint subst (V W : ITYPE T) (f : V ---> STS W) t (v : STS V t) :
  STS W t :=  match v in STS _ t return STS W t with
    | Var t v => f t v
    | Build t i l => Build (l >>== f)
    end
with
  list_subst V t (l : STS_list V t) W (f : V ---> STS W) : STS_list W t :=
     match l in STS_list _ t return STS_list W t with
     | TT => TT W
     | constr b bs elem elems =>
       constr (elem >== (_lshift f)) (elems >>== f)
     end
where "x >== f" := (subst f x)
and "x >>== f" := (list_subst x f).

(** substitution of one variable only *)

Definition substar (u : T) (V : ITYPE T) (M : STS V u) :
           STS (V * u) ---> STS V :=
 subst (fun t (x : opt u V t) => match x with
         | none => M
         | some _ v => Var v
         end).

Notation "M [*:= N ]" := (substar N M) (at level 50).

(**  FUSION LAWS *)
(**  a boring section, don't read it *)

Hint Extern 1 (_ = _) => f_equal : fin.

Lemma _shift_eq u V W (f g : V ---> STS W)
     (H : forall t x, f t x = g t x) t (x : opt u V t) :
          x >- f = x >- g.
Proof.
  intros u V W f g H t v.
  destruct v;
  fin.
Qed.

Hint Resolve _shift_eq : fin.
Hint Rewrite _shift_eq : fin.

Instance shift_oid u V W :
  Proper (equiv ==> equiv) (@_shift u V W).
Proof.
  unfold Proper;
  red; fin.
Qed.

Lemma _lshift_eq l (V W:ITYPE T) (f g : V ---> STS W)
    (H : forall t x, f t x = g t x) t (x : V ** l t) :
       x >>-- f = x >>-- g.
Proof.
  induction l; fin.
Qed.

Hint Resolve _lshift_eq : fin.
Hint Rewrite _lshift_eq : fin.

Instance _lshift_oid l V W :
    Proper (equiv ==> equiv) (@_lshift l V W).
Proof.
  unfold Proper;
  red; fin.
Qed.

Lemma shift_var u (V : ITYPE T) t (x : opt u V t) :
       x >- @Var _ = Var x .
Proof.
  simpl.
  intros u V t x;
  induction x;
  fin.
Qed.

Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.

Lemma shift_l_var l V t (x : V ** l t) :
      x >>-- @Var _ = Var x .
Proof.
  intro l;
  induction l;
  simpl;
  intros;
  auto.
  transitivity (_lshift (Var (V:= opt a V)) x);
  fin.
Qed.

Lemma var_lift_shift (u : T) V W (f : V ---> W) t (x : opt u V t) :
     Var (^f _ x) = x >- (f ;; @Var _ ).
Proof.
  intros u V W f t x;
  induction x; fin.
Qed.

Hint Resolve var_lift_shift : fin.

Lemma var_lift_shift_l (l : [T]) V W (f : V ---> W) t x :
       Var ((f ^^ l) t x)  =  x >>-- (f ;; @Var _ ) .
Proof.
  intro l;
  induction l;
  simpl in *;
  intros;
  auto.
  assert (H:=var_lift_shift).
  transitivity (x >>-- (^f ;; @Var _ ));
  fin.
Qed.

Lemma shift_lift u V W X (f : V ---> W)
         (g : W ---> STS X) t (x : opt u V t) :
      (^f _ x) >- g = x >- (f ;; g).
Proof.
  intros u V W X f g t x.
  induction x; fin.
Qed.

Hint Resolve shift_lift var_lift_shift_l : fin.
Hint Rewrite shift_lift : fin.

Lemma shift_lift_list l V W X (f : V ---> W) (g : W ---> STS X) t x:
        (f ^^ l t x) >>-- g =  x >>-- (f ;; g).
Proof.
  intro l;
  induction l;
  simpl;
  auto.

  intros V W X f g t x.
  simpl in IHl.
  rewrite IHl.
  simpl.
  apply _lshift_eq.
  fin.
Qed.

Lemma subst_eq V t (x : STS V t)
      W (f g : V ---> STS W)
       (H : forall t x, f t x = g t x):  x >== f = x >== g.
Proof.
  assert (H:=@STSind
      (fun V t x => forall W (f g : V ---> STS W)
              (H:f == g), x >== f = x >== g)
      (fun V l (v : STS_list V l) =>
               forall W (f g : V ---> STS W)(H:f == g),
           v >>== f = v >>== g) ).
  apply H;
  fin.
Qed.

Hint Resolve subst_eq shift_l_var
  var_lift_shift_l _lshift_eq : fin.
Hint Rewrite subst_eq shift_l_var var_lift_shift_l : fin.

Obligation Tactic := unfold Proper; red; fin.

Program Instance subst_oid V W :
 Proper (equiv ==> equiv (Setoid:=mor_oid (STS V) (STS W)))
                (@subst V W).

Lemma subst_var (V : ITYPE T) :
    forall t (v : STS V t), v >== (@Var V) = v .
Proof.
  assert (H:=@STSind
      (fun V t (v : STS V t) =>  v >== (Var (V:=V)) = v)
      (fun V l (v : STS_list V l) => v >>== (Var (V:=V)) = v)).
  simpl in *.
  apply H;
  simpl;
  clear H;
  auto.

  fin.

  intros V b bs s H v H1.
  rewrite <- H at 2.
  fin.
Qed.

Lemma subst_eq_rename V t (v : STS V t) W (f : V ---> W)  :
     v //- f  = v >== f ;; Var (V:=W).
Proof.
  assert (H:=@STSind
    (fun V t (v : STS V t) => forall W (f : V ---> W),
       v //- f = v >== (f;;Var (V:=W)))
    (fun V l (v : STS_list V l) => forall W (f : V ---> W),
         v //-- f = v >>== (f ;; Var (V:=W))) ).
  simpl in *.
  apply H;
  simpl;
  auto;
  clear H.

  fin.

  intros V b bs v H
     x H' W f.
  rewrite H'.
  rewrite H.
  apply constr_eq; auto.
  apply subst_eq.
  fin.
Qed.

Lemma rename_shift a V W X (f : V ---> STS W) (g : W ---> X) t
       (x : opt a V t) :
    (x >- f) //- ^g = x >- (f ;; rename g).
Proof.
  intros a V W X f g t x.
  induction x;
  simpl;
  auto.
  unfold inj.
  assert (H3 := preserve_comp (Func := rename_func)).
  simpl in H3.
  rewrite <- H3.
  rewrite <- H3.
  apply f_equal.
  auto.
Qed.

Hint Rewrite rename_shift shift_lift_list : fin.
Hint Resolve rename_shift shift_lift_list : fin.

Lemma rename_shift_list (l : [T]) V t (x : V ** l t)
              W X (f : V ---> STS W)
                    (g : W ---> X) :
      x >>-- f //-  g ^^ l =
      x >>-- (f ;; rename g).
Proof.
  intro l;
  induction l;
  simpl;
  auto.

  intros V t x W X f g.
  rewrite IHl.
  apply _lshift_eq.
  clear x t.
  simpl; intros t x.
  assert (H:=rename_shift).
  fin.
Qed.

Hint Resolve rename_shift_list : fin.
Hint Rewrite rename_shift_list : fin.

Lemma rename_subst V t (v : STS V t) W X (f : V ---> STS W)
      (g : W ---> X) :
      (v >== f) //- g  = v >== (f ;; rename g).
Proof.
  assert (H:=@STSind
    (fun V t (v : STS V t) => forall W X (f : V ---> STS W)
                                         (g : W ---> X),
      (v >== f) //- g = v >== (f ;; rename g))
    (fun V l (v : STS_list V l) => forall W X
              (f : V ---> STS W) (g : W ---> X),
      (v >>== f) //-- g = v >>== (f ;; rename g))).
  apply H;
  simpl;
  auto;
  clear H.

  intros V t i s H
      W X f g.
  rewrite H.
  auto.

  intros V b bs s H v
     H' W X f g.
  rewrite H'.
  rewrite H.
  apply constr_eq; auto.
  apply subst_eq; fin.
Qed.

Lemma subst_rename V t (v : STS V t) W X (f : V ---> W)
      (g : W ---> STS X) :
      v //- f >== g = v >== (f ;; g).
Proof.
  assert (H:=@STSind
    (fun V t (v : STS V t) => forall W X (f : V ---> W)
                                         (g : W ---> STS X),
      v //- f >== g = v >== (f ;; g))
    (fun V l (v : STS_list V l) => forall W X
              (f : V ---> W) (g : W ---> STS X),
      v //-- f >>== g = v >>== (f ;; g))).
  apply H;
  simpl;
  auto;
  clear H.

  fin.

  intros V b bs s H v
     H' W X f g.
  rewrite H'.
  rewrite H.
  assert (H2:= shift_lift_list (l:=fst b)).
  fin.
Qed.

Lemma rename_substar V u t (v : STS (opt u V) t) W (f : V ---> W) N:
     v [*:= N] //- f = (v //- ^f) [*:= N //- f ].
Proof.
  intros.
  unfold substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  intros t0 x;
  destruct x;
  simpl; auto.
Qed.

Hint Rewrite rename_subst rename_subst : fin.

Lemma subst_shift_shift (u:T) V (t:T)(v : opt u V t)
         W X (f: V ---> STS W) (g: W ---> STS X):
    (v >- f) >== (_shift g)  =
             v >- (f ;; subst g).
Proof.
  intros u V t v.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
  unfold inj.
  rewrite subst_rename.
  fin.
Qed.

Hint Resolve subst_shift_shift : fin.
Hint Rewrite subst_shift_shift : fin.

Lemma subst_shift_shift_list (l : [T]) V t (v : V ** l t)
         W X (f: V ---> STS W) (g: W ---> STS X):
    v >>--f >== (_lshift g) =
             v >>-- (f ;; subst g).
Proof.
  intro l;
  induction l;
  simpl;
  auto.

  intros V t v W X
     f g.
  rewrite IHl.
  apply _lshift_eq.
  fin.
Qed.

Hint Rewrite subst_shift_shift_list : fin.
Hint Resolve subst_shift_shift_list : fin.

Lemma subst_subst V t (v : STS V t) W X (f : V ---> STS W)
             (g : W ---> STS X) :
     v >== f >== g = v >== f;; subst g.
Proof.
  assert (H:=@STSind
    (fun (V : T -> Type) (t : T) (v : STS V t) => forall (W X : T -> Type)
          (f : V ---> STS W) (g : W ---> STS X),
        v >== f >== g = v >== (f;; subst g))
   (fun (V : T -> Type) l (v : STS_list V l) =>
       forall (W X : T -> Type)
          (f : V ---> STS W) (g : W ---> STS X),
        v >>== f >>== g = v >>== (f;; subst g) )).
  apply H;
  simpl;
  auto;
  clear H.

  fin.

  intros V b bs s H
     s0 H' W X f g.
  rewrite H'.
  rewrite H.
  apply constr_eq;
  auto.
  assert (H2:= subst_shift_shift_list (l:=fst b)).
  simpl in *.
  fin.
Qed.

Hint Resolve subst_var subst_subst : fin.
Hint Rewrite subst_subst : fin.

Lemma lift_rename V t (s : STS V t) W (f : V ---> W) :
          s >== (f ;; @Var _) = s //- f.
Proof.
  assert (H:=@STSind
    (fun V t s => forall W f,
       subst (f ;; Var (V:=W)) s =
               rename  f s)
    (fun V l s => forall W f,
        list_subst s (f ;; Var (V:=W)) =
             list_rename s f)).
  apply H;
  simpl;
  auto;
  clear H.

  fin.

  intros V b bs s
       H x H1 W f.
  rewrite H1.
  rewrite <- H.
  apply constr_eq;
  auto.
  apply subst_eq.
  fin.
Qed.

(** END OF FUSION LAWS *)

(** STS is a monad *)

Obligation Tactic := fin.

Program Instance STS_monad :
     Monad_struct (ITYPE T) STS := {
  weta := Var;
  kleisli := subst
}.

Canonical Structure STSM := Build_Monad STS_monad.

(** as said before, STS_list is actually the same as
    prod_mod_glue STS_monad. we give a module morphism translation *)

Fixpoint STSl_f_pm l V (x : prod_mod STSM l V)
         : STS_list V l :=
    match x in prod_mod_c _ _ l return STS_list V l with
    | TTT =>  TT V
    | CONSTR b bs e el => constr e (STSl_f_pm el)
    end.

Fixpoint pm_f_STSl l V (v : STS_list V l) :
       prod_mod STSM l V :=
 match v in STS_list _ l return prod_mod STSM l V with
 | TT => TTT _ _
 | constr b bs elem elems =>
        CONSTR elem (pm_f_STSl elems)
 end.

Lemma one_way l V (v : STS_list V l) :
    STSl_f_pm (pm_f_STSl v) = v.
Proof.
  intros l V v.
  induction v;
  fin.
Qed.

Lemma or_another l V (v : prod_mod STSM l V) :
       pm_f_STSl (STSl_f_pm v) = v.
Proof.
  intros l V v;
  induction v;
  fin.
Qed.

(** we now establish some more properties, which will help in the future

    in particular the mentioned equalities:
    - rename = lift
    - _shift = shift
*)

Lemma list_subst_eq V l (v : STS_list V l) W
       (f g : V ---> STS W) (H : f == g) :
          v >>== f =  v >>== g.
Proof.
  assert (H:=@STSlistind
      (fun V t x => forall W (f g : V ---> STS W)
              (H:f == g), x >== f = x >== g)
      (fun V l (v : STS_list V l) =>
               forall W (f g : V ---> STS W)(H:f == g),
           v >>== f = v >>== g) ).
  apply H;
  fin.
Qed.

(** we establish some equalities *)

Hint Rewrite subst_eq_rename : fin.

(** shift = opt_inj STS *)

Notation "x >>- f" := (shift f x) (at level 50).
Notation "x >-- f" := (lshift f x) (at level 50).

Existing Instance STS_monad.

Lemma _shift_shift_eq a V W (f : V ---> STS W) t (x : opt a V t) :
        x >>- f = x >- f.
Proof.
  intros a V W f t x.
  destruct x;
  simpl;
  auto.
  unfold lift, inj.
  fin.
Qed.

Hint Resolve _shift_shift_eq : fin.

Lemma _lshift_lshift_eq (l : [T]) V
     (t : T)(x : V ** l t) W (f : V ---> STS W):
       x >-- f = x >>-- f.
Proof.
  induction l;
  simpl in *;
  intros;
  try rewrite IHl;
  fin.
Qed.

(**   rename = lift *)

Lemma lift_rename2 V t (s : STS V t) W (f : V ---> W):
        lift f t s = s //- f.
Proof.
  fin.
Qed.

(** STSl_f_pm ;; list_subst = mkleisli ;; STSl_f_pm *)

Hint Resolve _lshift_lshift_eq : fin.

Notation "v >>>= f" :=
  (mkleisli (Module_struct := prod_mod STSM _) f v) (at level 67).

Lemma sts_list_subst l V (v : prod_mod STSM l V)
       W (f : V ---> STS W):
  STSl_f_pm  (v >>>= f) = (STSl_f_pm v) >>== f.
Proof.
  intros l V v;
  induction v;
  fin.
Qed.

(** we define the Representation Structure, i.e. for every arity
    a module morphism *)

Obligation Tactic := fin; try apply f_equal;
                          try apply sts_list_subst.

Notation "y [( s )]" := ((ITFIB_MOD _ s) y) (at level 40).

Program Instance STS_arity_rep (t : T) (i : sig_index (S t)) :
  Module_Hom_struct
       (S := prod_mod STSM (sig i))
       (T := STSM [(t)])
       (fun V  X => Build (STSl_f_pm X)).

(**  STS has a structure as a representation of Sig *)

Canonical Structure STSrepr (t : T) : Repr_t S STSM t :=
       fun i => Build_Module_Hom (STS_arity_rep t i).

Canonical Structure STSRepr : REPRESENTATION S :=
       Build_Representation (fun t => @STSrepr t).

(** now INITIALITY *)

Section initiality.

Variable R : REPRESENTATION S.

(** the initial morphism STS -> R *)

Fixpoint init V t (v : STS V t) : R V t :=
        match v in STS _ t return R V t with
        | Var t v => weta (Monad_struct := R) V t v
        | Build  t i X => repr R i V (init_list X)
        end
with
 init_list l (V : ITYPE T) (s : STS_list V l) : prod_mod R l V :=
    match s in STS_list _ l return prod_mod R l V with
    | TT => TTT _ _
    | constr b bs elem elems =>
         CONSTR (init elem) (init_list elems)
    end.

(** now for init to be a morphism of monads we need to establish
    commutativity with substitution

    the following lead towards this goal
*)

(** init commutes with lift/rename *)

Lemma init_lift V t x W (f : V ---> W) :
   init (x //- f) = lift f t (init x).
Proof.
  assert (H:=@STSind
    (fun V t (x : STS V t) => forall W (f : V ---> W),
        init (x //- f) = lift f t (init x))
    (fun V l (s : STS_list V l) => forall
                 W (f : V ---> W),
         (init_list (s //-- f)) =
            mlift (prod_mod R l) f (init_list s))).
  apply H;
  simpl;
  auto;
  clear H.

  intros.
  assert (H:=lift_weta R).
  simpl in *.
  auto.

  intros.
  rewrite H.
  unfold mlift, lift.
  assert (H':=mod_hom_mkl (Module_Hom_struct:=repr R i)).
  simpl in *.
  auto.

  intros.
  rewrite H0.
  unfold mlift, lift.
  simpl.
  apply CONSTR_eq;
  simpl; auto.
  rewrite H.
  unfold lift.
  apply (kleisli_oid (Monad_struct :=R)).
  assert (H2:= lshift_weta_f).
  simpl in *.
  auto.
Qed.

(** init commutes with shift and lshift *)

Lemma init_shift a V W (f : V ---> STS W) :
   forall (t : T) (x : opt a V t),
  init (x >>- f) = x >>- (f ;; @init _).
Proof.
  intros a V W f t x.
  induction x;
  simpl;
  try rewrite <- init_lift;
  fin.
Qed.

Hint Rewrite init_shift : fin.

Lemma init_lshift (l : list T) V W
      (f : V ---> STS W) t (x : V ** l t) :
     init (x >-- f) = x >-- (f ;; @init _).
Proof.
  intro l;
  induction l;
  simpl in *;
  auto.
  intros V W f t x.
  rewrite IHl.
  assert (H:= lshift_eq).
  simpl in H.
  apply H.
  fin.
Qed.

Hint Rewrite init_lshift : fin.

(** init is a morphism of monads *)

Lemma init_kleisli V t (v : STS V t) W (f : V ---> STS W) :
  init (v >== f) =
  kleisli (f ;; @init _ ) t (init v).
Proof.
  assert (H:= @STSind
     (fun X t (v : STS X t) =>
         forall Y (f : X ---> STS Y),
      init (v >== f) =
      kleisli (Monad_struct := R)
            (f ;; @init _) t (init v))

     (fun X l (s : STS_list X l) => forall Y (f : X ---> STS Y),
           init_list (s >>== f) =
           mkleisli (Module_struct := prod_mod  R l)
              (f ;; @init _ )
                    (init_list s))).
  apply H;
  simpl;
  auto;
  clear H.

  assert (H':= eta_kl (Monad_struct := R)).
  simpl in H'.
  intros.
  rewrite H'.
  auto.

  intros V t i s H2 Y f .
  rewrite H2.
  assert (H:= mod_hom_mkl (Module_Hom_struct := repr R i)).
  simpl in *.
  rewrite H.
  auto.

  intros V b bs v H' s H
      Y f.
  apply CONSTR_eq;
  simpl;
  auto.
  rewrite H'.
  destruct b as [t l];
  simpl in *.
  apply (kleisli_oid (Monad_struct := R)) .
  intros t0 x.
  rewrite <- _lshift_lshift_eq.
  fin.
Qed.

Hint Rewrite init_kleisli CONSTR_eq: fin.
Hint Resolve init_kleisli CONSTR_eq: fin.

Obligation Tactic := fin.

Program Instance init_monadic : Monad_Hom_struct (P:=STSM) init.

Canonical Structure init_mon := Build_Monad_Hom init_monadic.

(** init is not only a monad morphism, but even a morphism of
    representations *)

(** prod_ind_mod_mor INIT = init_list (up to STSl_f_pm) *)

Lemma prod_mor_eq_init_list t (i : sig_index (S t)) V
       (x : prod_mod_c STS V (sig i)) :
  Prod_mor_c init_mon (*init*) x = init_list (STSl_f_pm x).
Proof.
  induction x;
  fin.
Qed.

Hint Rewrite prod_mor_eq_init_list : fin.

Obligation Tactic :=  unfold commute; fin.

Program Instance init_representic : Representation_Hom_s
        (P:=STSRepr) init_mon (*init*).

Definition init_rep := Build_Representation_Hom init_representic.

(** INITIALITY of STSRepr with init *)

Lemma init_unique_prepa V t (v : STS V t)
  (f : Representation_Hom STSRepr R) :
         f V t v = init v.
Proof.
  assert (H:= @STSind
     (fun V t v => forall f : Representation_Hom STSRepr R,
                  f V t v = init v)
     (fun V l v => forall f : Representation_Hom STSRepr R,
         Prod_mor f l V (pm_f_STSl v) = init_list v)).
  apply H;
  simpl;
  auto;
  clear H.
  intros V t v f.
  assert (H:=monad_hom_weta (Monad_Hom_struct := f)).
  simpl in H.
  auto.

  intros V t i s H f.
  assert (H3:=repr_hom f (t:=t) (i:=i)).
  unfold commute in H3.
  simpl in H3.
  assert (H4:= one_way s).
  simpl in *.
  pattern s at 1.
  rewrite <- H4.
  simpl.
(*  rewrite <- H4 at 1.
  rewrite <- (one_way s) at 1.
(*  rewrite <- (one_way (l:=sig i) (V:=V) s) at 1.*)
*)
  rewrite <- H3.
  apply f_equal.
  auto.

  fin.
Qed.

Hint Rewrite init_unique_prepa : fin.

Lemma init_unique :forall f : STSRepr ---> R , f == init_rep.
Proof.
  fin.
Qed.

End initiality.

Hint Rewrite init_unique : fin.

Obligation Tactic := fin.

Program Instance STS_initial : Initial (REPRESENTATION S) := {
  Init := STSRepr ;
  InitMor R := init_rep R }.

End initial_type.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Postorder numbering of a directed graph. *)

Require Import Wellfounded.
Require Import Permutation.
Require Import Mergesort.
Require Import Coqlib.
Require Import Maps.
Require Import Iteration.

(** The graph is presented as a finite map from nodes (of type [positive])
  to the lists of their successors. *)

Definition node: Type := positive.

Definition graph: Type := PTree.t (list node).

(** A sorting function over lists of positives.  While not necessary for
  correctness, we process the successors of a node in increasing order.
  This preserves more of the shape of the original graph and is good for
  our CFG linearization heuristic. *)

Module PositiveOrd.
  Definition t := positive.
  Definition leb (x y: t): bool := if plt y x then false else true.
(*  Infix "<=?" := leb (at level 35). *)
  Theorem leb_total : forall x y, is_true (leb x y) \/ is_true (leb y x).
  Proof.
    unfold leb, is_true; intros.
    destruct (plt x y); auto. destruct (plt y x); auto.
    elim (Plt_strict x). eapply Plt_trans; eauto.
  Qed.
End PositiveOrd.

Module Sort := Mergesort.Sort(PositiveOrd).

(** The traversal is presented as an iteration that modifies the following state. *)

Record state : Type := mkstate {
  gr: graph;                    (**r current graph, without already-visited nodes *)
  wrk: list (node * list node); (**r worklist *)
  map: PTree.t positive;        (**r current mapping node -> postorder number *)
  next: positive                (**r number to use for next numbering *)
}.

Definition init_state (g: graph) (root: node) :=
  match g!root with
  | Some succs =>
     {| gr := PTree.remove root g;
        wrk := (root, Sort.sort succs) :: nil;
        map := PTree.empty positive;
        next := 1%positive |}
  | None =>
     {| gr := g;
        wrk := nil;
        map := PTree.empty positive;
        next := 1%positive |}
  end.

Definition transition (s: state) : PTree.t positive + state :=
  match s.(wrk) with
  | nil =>                              (**r empty worklist, we are done *)
      inl _ s.(map)
  | (x, nil) :: l =>                    (**r all successors of [x] are numbered; number [x] itself *)
      inr _ {| gr := s.(gr);
               wrk := l;
               map := PTree.set x s.(next) s.(map);
               next := Psucc s.(next) |}
  | (x, y :: succs_x) :: l =>           (**r consider [y], the next unnumbered successor of [x] *)
      match s.(gr)!y with
      | None =>                         (**r [y] is already numbered: discard from worklist *)
          inr _ {| gr := s.(gr);
                   wrk := (x, succs_x) :: l;
                   map := s.(map);
                   next := s.(next) |}
      | Some succs_y =>                 (**r push [y] on the worklist *)
          inr _ {| gr := PTree.remove y s.(gr);
                   wrk := (y, Sort.sort succs_y) :: (x, succs_x) :: l;
                   map := s.(map);
                   next := s.(next) |}
      end
  end.

Section POSTORDER.

Variable ginit: graph.
Variable root: node.

Inductive invariant (s: state) : Prop :=
  Invariant
    (* current graph is a subset of ginit *)
    (SUB: forall x y, s.(gr)!x = Some y -> ginit!x = Some y)
    (* root is not in current graph *)
    (ROOT: s.(gr)!root = None)
    (* mapped nodes have their numbers below next *)
    (BELOW: forall x y, s.(map)!x = Some y -> Plt y s.(next))
    (* mapping is injective *)
    (INJ: forall x1 x2 y, s.(map)!x1 = Some y -> s.(map)!x2 = Some y -> x1 = x2)
    (* nodes not yet visited have no number *)
    (REM: forall x y, s.(gr)!x = Some y -> s.(map)!x = None)
    (* black nodes have no white son *)
    (COLOR: forall x succs n y,
            ginit!x = Some succs -> s.(map)!x = Some n ->
            In y succs -> s.(gr)!y = None)
    (* worklist is well-formed *)
    (WKLIST: forall x l, In (x, l) s.(wrk) ->
             s.(gr)!x = None /\
             exists l', ginit!x = Some l'
                    /\ forall y, In y l' -> ~In y l -> s.(gr)!y = None)
    (* all grey nodes are on the worklist *)
    (GREY: forall x, ginit!x <> None -> s.(gr)!x = None -> s.(map)!x = None ->
           exists l, In (x,l) s.(wrk)).

Inductive postcondition (map: PTree.t positive) : Prop :=
  Postcondition
    (INJ: forall x1 x2 y, map!x1 = Some y -> map!x2 = Some y -> x1 = x2)
    (ROOT: ginit!root <> None -> map!root <> None)
    (SUCCS: forall x succs y, ginit!x = Some succs -> map!x <> None -> In y succs -> ginit!y <> None -> map!y <> None).

Remark In_sort:
  forall x l, In x l <-> In x (Sort.sort l).
Proof.
  intros; split; intros.
  apply Permutation_in with l. apply Sort.Permuted_sort. auto.
  apply Permutation_in with (Sort.sort l). apply Permutation_sym. apply Sort.Permuted_sort. auto.
Qed.

Lemma transition_spec:
  forall s, invariant s ->
  match transition s with inr s' => invariant s' | inl m => postcondition m end.
Proof.
  intros. inv H. unfold transition. destruct (wrk s) as [ | [x succ_x] l].
  (* finished *)
  constructor; intros.
  eauto.
  caseEq (s.(map)!root); intros. congruence. exploit GREY; eauto. intros [? ?]; contradiction.
  destruct (s.(map)!x) as []_eqn; try congruence.
  destruct (s.(map)!y) as []_eqn; try congruence.
  exploit COLOR; eauto. intros. exploit GREY; eauto. intros [? ?]; contradiction.
  (* not finished *)
  destruct succ_x as [ | y succ_x ].
  (* all children of x were traversed *)
  constructor; simpl; intros.
  (* sub *)
  eauto.
  (* root *)
  eauto.
  (* below *)
  rewrite PTree.gsspec in H. destruct (peq x0 x). inv H.
  apply Plt_succ.
  apply Plt_trans_succ. eauto.
  (* inj *)
  rewrite PTree.gsspec in H. rewrite PTree.gsspec in H0.
  destruct (peq x1 x); destruct (peq x2 x); subst.
  auto.
  inv H. exploit BELOW; eauto. intros. eelim Plt_strict; eauto.
  inv H0. exploit BELOW; eauto. intros. eelim Plt_strict; eauto.
  eauto.
  (* rem *)
  intros. rewrite PTree.gso; eauto. red; intros; subst x0.
  exploit (WKLIST x nil); auto with coqlib. intros [A B]. congruence.
  (* color *)
  rewrite PTree.gsspec in H0. destruct (peq x0 x).
  inv H0.  exploit (WKLIST x nil); auto with coqlib.
  intros [A [l' [B C]]].
  assert (l' = succs) by congruence. subst l'.
  apply C; auto.
  eauto.
  (* wklist *)
  apply WKLIST. auto with coqlib.
  (* grey *)
  rewrite PTree.gsspec in H1. destruct (peq x0 x). inv H1.
  exploit GREY; eauto. intros [l' A]. simpl in A; destruct A.
  congruence.
  exists l'; auto.

  (* children y needs traversing *)
  destruct ((gr s)!y) as [ succs_y | ]_eqn.
  (* y has children *)
  constructor; simpl; intros.
  (* sub *)
  rewrite PTree.grspec in H. destruct (PTree.elt_eq x0 y); eauto. inv H.
  (* root *)
  rewrite PTree.gro. auto. congruence.
  (* below *)
  eauto.
  (* inj *)
  eauto.
  (* rem *)
  rewrite PTree.grspec in H. destruct (PTree.elt_eq x0 y); eauto. inv H.
  (* color *)
  rewrite PTree.grspec. destruct (PTree.elt_eq y0 y); eauto.
  (* wklist *)
  destruct H.
  inv H. split. apply PTree.grs. exists succs_y; split. eauto.
  intros. rewrite In_sort in H. tauto.
  destruct H.
  inv H. exploit WKLIST; eauto with coqlib. intros [A [l' [B C]]].
  split. rewrite PTree.grspec. destruct (PTree.elt_eq x0 y); auto.
  exists l'; split. auto. intros. rewrite PTree.grspec. destruct (PTree.elt_eq y0 y); auto.
  apply C; auto. simpl. intuition congruence.
  exploit (WKLIST x0 l0); eauto with coqlib. intros [A [l' [B C]]].
  split. rewrite PTree.grspec. destruct (PTree.elt_eq x0 y); auto.
  exists l'; split; auto. intros.
  rewrite PTree.grspec. destruct (PTree.elt_eq y0 y); auto.
  (* grey *)
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq x0 y) in H0.
  subst. exists (Sort.sort succs_y); auto with coqlib.
  exploit GREY; eauto. simpl. intros [l1 A]. destruct A.
  inv H2. exists succ_x; auto.
  exists l1; auto.

  (* y has no children *)
  constructor; simpl; intros; eauto.
  (* wklist *)
  destruct H. inv H.
  exploit (WKLIST x0); eauto with coqlib. intros [A [l' [B C]]].
  split. auto. exists l'; split. auto.
  intros. destruct (peq y y0). congruence. apply C; auto. simpl. intuition congruence.
  eapply WKLIST; eauto with coqlib.
  (* grey *)
  exploit GREY; eauto. intros [l1 A]. simpl in A. destruct A.
  inv H2. exists succ_x; auto.
  exists l1; auto.
Qed.

Lemma initial_state_spec:
  invariant (init_state ginit root).
Proof.
  unfold init_state. destruct (ginit!root) as [succs|]_eqn.
  (* root has succs *)
  constructor; simpl; intros.
  (* sub *)
  rewrite PTree.grspec in H. destruct (PTree.elt_eq x root). inv H. auto.
  (* root *)
  apply PTree.grs.
  (* below *)
  rewrite PTree.gempty in H; inv H.
  (* inj *)
  rewrite PTree.gempty in H; inv H.
  (* rem *)
  apply PTree.gempty.
  (* color *)
  rewrite PTree.gempty in H0; inv H0.
  (* wklist *)
  destruct H; inv H.
  split. apply PTree.grs. exists succs; split; auto.
  intros. rewrite In_sort in H. intuition.
  (* grey *)
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq x root).
  subst. exists (Sort.sort succs); auto.
  contradiction.

  (* root has no succs *)
  constructor; simpl; intros.
  (* sub *)
  auto.
  (* root *)
  auto.
  (* below *)
  rewrite PTree.gempty in H; inv H.
  (* inj *)
  rewrite PTree.gempty in H; inv H.
  (* rem *)
  apply PTree.gempty.
  (* color *)
  rewrite PTree.gempty in H0; inv H0.
  (* wklist *)
  contradiction.
  (* grey *)
  contradiction.

Qed.

(** Termination criterion. *)

Fixpoint size_worklist (w: list (positive * list positive)) : nat :=
  match w with
  | nil => 0%nat
  | (x, succs) :: w' => (S (List.length succs) + size_worklist w')%nat
  end.

Definition lt_state (s1 s2: state) : Prop :=
  lex_ord lt lt (PTree_Properties.cardinal s1.(gr), size_worklist s1.(wrk))
                (PTree_Properties.cardinal s2.(gr), size_worklist s2.(wrk)).

Lemma lt_state_wf: well_founded lt_state.
Proof.
  set (f := fun s => (PTree_Properties.cardinal s.(gr), size_worklist s.(wrk))).
  change (well_founded (fun s1 s2 => lex_ord lt lt (f s1) (f s2))).
  apply wf_inverse_image.
  apply wf_lex_ord.
  apply lt_wf. apply lt_wf.
Qed.

Lemma transition_decreases:
  forall s s', transition s = inr _ s' -> lt_state s' s.
Proof.
  unfold transition, lt_state; intros.
  destruct (wrk s) as [ | [x succs] l].
  discriminate.
  destruct succs as [ | y succs ].
  inv H. simpl. apply lex_ord_right. omega.
  destruct ((gr s)!y) as [succs'|]_eqn.
  inv H. simpl. apply lex_ord_left. eapply PTree_Properties.cardinal_remove; eauto.
  inv H. simpl. apply lex_ord_right. omega.
Qed.

End POSTORDER.

Definition postorder (g: graph) (root: node) :=
  WfIter.iterate _ _ transition lt_state lt_state_wf transition_decreases (init_state g root).

Inductive reachable (g: graph) (root: positive) : positive -> Prop :=
  | reachable_root:
      reachable g root root
  | reachable_succ: forall x succs y,
      reachable g root x -> g!x = Some succs -> In y succs ->
      reachable g root y.

Theorem postorder_correct:
  forall g root,
  let m := postorder g root in
  (forall x1 x2 y, m!x1 = Some y -> m!x2 = Some y -> x1 = x2)
  /\ (forall x, reachable g root x -> g!x <> None -> m!x <> None).
Proof.
  intros.
  assert (postcondition g root m).
    unfold m. unfold postorder.
    apply WfIter.iterate_prop with (P := invariant g root).
    apply transition_spec.
    apply initial_state_spec.
  inv H.
  split. auto.
  induction 1; intros.
  (* root case *)
  apply ROOT; auto.
  (* succ case *)
  eapply SUCCS; eauto. apply IHreachable. congruence.
Qed.


From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst.
From MetaCoq.PCUIC Require TemplateToPCUIC PCUICToTemplate.

From MetaCoq.Template Require Import config monad_utils utils TemplateMonad Universes.
From MetaCoq.Template Require Ast.
Import MCMonadNotation.

Require Import List String Relation_Operators.
Import ListNotations.

From Local Require Import non_uniform.

Definition clift0 (n : nat) (t : context_decl) : context_decl :=
  {| decl_name := t.(decl_name);
     decl_body := match t.(decl_body) with
                   | Some q => Some (lift0 n q)
                   | None => None
                  end;
     decl_type := lift0 n t.(decl_type)
  |}.

Definition subterms_for_constructor
           (refi : inductive)
           (ref   : term) (* we need the term for exactly this inductive just for the substition *)
           (ntypes : nat) (* number of types in the mutual inductive *)
           (npars : nat) (* number of parameters in the type *)
           (nind : nat) (* number of proper indeces in the type *)
           (ct    : term) (* type of the constructor *)
           (ncons : nat) (* index of the constructor in the inductive *)
           (nargs : nat) (* number of arguments in this constructor *)
                  : list (nat * term * nat)
  := let indrel := (ntypes - inductive_ind refi - 1) in
    let '(ctx, ap) := decompose_prod_assum [] ct in
    (*    ^ now ctx is a reversed list of assumptions and definitions *)
    let len := List.length ctx in
    let params := List.skipn (len - npars) (ctx) in
    let inds := List.skipn npars (snd (decompose_app ap)) in
    (* d is a list of occurences of subterms in arguments to the constructor *)
    let d :=List.concat (
           (* so this i represents distance from return object to `t` *)
              mapi (fun i t =>
                      let '(ctx, ar) := decompose_prod_assum [] (decl_type t)
                      in let p := (indrel + (len - i - 1) + List.length (ctx))
                      in let (f, s) := decompose_app ar
                      in match f with
                         | tRel j => if Nat.eqb p j
                                    then [(i, ctx, s)]
                                    else []
                         | _ => []
                         end) ctx) in
    let '(ctx_sbst, _) := decompose_prod_assum [] (subst1 ref indrel ct) in
    let construct_cons :=
        fun (* index of a subterm in this constructor *)
          (i: nat)
          (* these are arguments for the function
             that is a parameter of the constructor
             and if applied fully returns something of the needed type *)
          (ctx': context)
          (* these are arguments of the type of the subterm *)
          (args' : list term) =>
          let len' := List.length ctx' in
          let ctxl' := (map (clift0 (2 + i)) ctx') in
          it_mkProd_or_LetIn
             (ctxl' ++ ctx_sbst)
             (mkApps (tRel (len + len'))
                   ((map (lift0 (len' + len - npars))
                         (to_extended_list params)) ++
                    (map (lift (1 + i + len') len') (List.skipn npars args')) ++
                    (map (lift0 len') inds) ++
                    [mkApps (tRel (i + len'))
                          (to_extended_list ctxl');
                     mkApps (tConstruct refi ncons [])
                         (map (lift0 len') (to_extended_list ctx_sbst))])) in
    mapi (fun i '(n, c, a) => (i, construct_cons n c a, len + List.length c)) d.

Definition nAnon := mkBindAnn nAnon Relevant.

Definition subterm_for_ind
           (refi : inductive)
           (ref   : term)
           (allparams : nat)
           (ntypes : nat) (* number of types in the mutual inductive *)
           (ind   : one_inductive_body)
                  : one_inductive_body
  := let (pai, _) := decompose_prod_assum [] ind.(ind_type) in
    let sort := (tSort (Universe.of_levels (inl PropLevel.lProp))) in
    let npars := getParamCount ind allparams in
    let pars := List.skipn (List.length pai - npars) pai in
    let inds := List.firstn (List.length pai - npars) pai in
    let ninds := List.length inds in
    let aptype1 :=
        mkApps ref ((map (lift0 (2 * ninds)) (to_extended_list pars)) ++
                    (map (lift0 ninds) (to_extended_list inds))) in
    let aptype2 :=
        mkApps ref ((map (lift0 (1 + 2 * ninds)) (to_extended_list pars)) ++
                    (map (lift0 1) (to_extended_list inds))) in
    let renamer name i := (name ++ "_subterm" ++ (string_of_nat i))%string in
    {| ind_name := (ind.(ind_name) ++ "_direct_subterm")%string;
       ind_type  := it_mkProd_or_LetIn
                      pars
                   (it_mkProd_or_LetIn
                      (inds)
                   (it_mkProd_or_LetIn
                      (map (clift0 (ninds)) inds)
                   (it_mkProd_or_LetIn
                       [mkdecl nAnon None aptype2; mkdecl nAnon None aptype1]
                       sort)));
       ind_kelim := IntoPropSProp;
       ind_ctors :=List.concat
                     (mapi (fun n '(id', ct, k) => (
                       map (fun '(si, st, sk) => (renamer id' si, st, sk))
                       (subterms_for_constructor refi ref ntypes npars ninds ct n k)))
                       ind.(ind_ctors));
      ind_projs := [];
    ind_relevance := Relevant |}.

Definition direct_subterm_for_mutual_ind
            (mind : mutual_inductive_body)
            (ind0 : inductive) (* internal metacoq representation of inductive, part of tInd *)
            (ref  : term) (* reference term for the inductive type, like (tInd {| inductive_mind := "Coq.Init.Datatypes.nat"; inductive_ind := 0 |} []) *)
                  : option mutual_inductive_body
  := let i0 := inductive_ind ind0 in
    let ntypes := List.length (ind_bodies mind) in
    b <- List.nth_error mind.(ind_bodies) i0 ;;
    ret {|
        ind_finite := BasicAst.Finite;
        ind_npars := 0;
        ind_universes := ind_universes mind;
        ind_params := [];
        ind_bodies := [subterm_for_ind ind0 ref mind.(ind_npars) ntypes b];
        ind_variance := None
      |}.

Definition subterm (t : Ast.term)
  : TemplateMonad unit
  := match t with
    | Ast.tInd ind0 _ =>
      decl <- tmQuoteInductive (inductive_mind ind0);;
      tmPrint decl;;
      match (subterm.direct_subterm_for_mutual_ind
               (TemplateToPCUIC.trans_minductive_body decl)
               ind0
               (TemplateToPCUIC.trans t)) with
      | None =>
        tmPrint t;;
        @tmFail unit "Coulnd't construct a subterm"
      | Some d =>
        v <- tmEval lazy (PCUICToTemplate.trans_minductive_body d);;
        tmPrint v;;
        tmMkInductive' v
      end
    | _ =>
      tmPrint t;;
      @tmFail unit " is not an inductive"
    end.