(** * Synthesis.CP : Simplification of Boolean expressions.  *)
Require Import Common DList Core ZArith.
Require BDD Seq.

(** In this compilation pass, we implement boolean simplification
    using BDDs.  Every boolean value is tagged with an abstraction of
    its runtime value, and when two declared variables have equivalent
    values, we do not introduce a binder for the second one. This
    transformation is similar to CSE, except that we use semantic
    common sub-expression elimination.

    Note that we simply get rid of equivalent definitions. We could go
one step further: given a program, compute the BDD of the Boolean
expressions that appear, and use this BDD to construct the RTL code. *)

Section t.

  Variable Phi : state.
  Variable Var : type -> Type.

  (* Maybe we have a pointer *)
  Definition sval := option BDD.expr.

  Notation V := (fun t => Var t * sval)%type.

  (* The symbolic values *)
  Inductive bexpr :=
  | Lift : BDD.expr  -> bexpr
  | Ite : forall (c l r : BDD.expr), bexpr
  | And : forall (a b : BDD.expr), bexpr
  | Or : forall (a b : BDD.expr), bexpr
  | Xor : forall (a b : BDD.expr), bexpr
  | Not : forall (a : BDD.expr), bexpr.

  (* bang := lift Lift *)
  Notation bang x := (do e <- x; (Some (Lift e))).
  Notation "!!" := (None).

  Require Import RTL.
  Definition cp_expr t (e : expr Phi V t) : (expr Phi Var t) * (option bexpr) :=
    match e with
            | Einput t v => (Einput _ _ _ v, !!)
            | Evar t x =>
                match t as ty return V ty -> (expr Phi Var ty) * (option bexpr) with
                  | Tbool => fun y => (Evar (fst y), bang (snd y))
                  | t => fun y  => (Evar (fst y), !!) end x
            | Eread t v =>  (Eread v, !!)
            | Eread_rf n t v adr => (Eread_rf v (fst adr), !!)
            | Eandb a b => (Eandb _ _ (fst a) (fst b),
                           (do a <- snd a; do b <- snd b; Some (And a b)))
            | Eorb a b =>  (Eorb  _ _ (fst a) (fst b),
                           do a <- snd a; do b <- snd b; Some (Or a b))
            | Exorb a b => (Exorb _ _ (fst a) (fst b),
                           do a <- snd a; do b <- snd b; Some (Xor a b))
            | Enegb a   => (Enegb _ _ (fst a),
                           do a <- snd a; Some (Not a))
            | Eeq t a b => (Eeq _ _ t (fst a) (fst b), !!)
            | Elt n a b => (Elt _ _ n (fst a) (fst b), !!)
            | Ele n a b => (Ele _ _ n (fst a) (fst b), !!)
            | Eadd n a b => (Eadd _ _ n (fst a) (fst b), !!)
            | Esub n a b => (Esub _ _ n (fst a) (fst b), !!)
            | Elow n m a => (Elow _ _ n m (fst a), !!)
            | Ehigh n m a => (Ehigh _ _ n m (fst a), !!)
            | EcombineLH n m a b => (EcombineLH _ _ n m (fst a) (fst b), !!)
            | Econstant t x =>
                match t as ty return constant ty -> (expr Phi Var ty * option bexpr) with
                  | Tbool => fun c => if ( c : bool)
                                    then (Econstant c, Some (Lift BDD.T))
                                    else (Econstant c, Some (Lift BDD.F))
                  | t => fun c => (Econstant c, !!) end x
            | Emux ty c l r =>
                (match snd c with
                   | Some BDD.T => (Evar (fst l))
                   | Some BDD.F => (Evar (fst r))
                   |  _ => Emux (fst c) (fst l) (fst r) end
                 ,
                 match ty as t return V t -> V t  -> option bexpr with
                   | Tbool => fun l r =>
                               (do c <- (snd c);
                                do l <- (snd l);
                                do r <- (snd r);
                                Some (Ite c l r))
                   | _ => fun _ _ => !! end l r)
            | Efst l t v => (Efst (fst v) , !!)
            | Esnd l t v => (Esnd (fst v) , !!)
            | Enth l t m v => (Enth m (fst v), !!)
            | Etuple l dl => (Etuple (DList.map (fun _ x => fst x) dl), !!)
          end.

  Record Env := mk
    {
      Ebdd : BDD.BDD;

      (* An association list that maps pointers in the BDD to variables *)
      Eassoc: list (BDD.expr * Var Tbool);

      (* The denotation of the variables of the bdd (i.e, the uninterpreted booleans) *)
      Evalues: list (Var Tbool);

      Enext: nat
    }.

  Definition empty : Env := mk BDD.empty [] [] 0.

  Definition add_bdd (Gamma: Env) (b:bexpr ): option (BDD.expr * Env) :=
    match b with
      | Lift x => Some (x, Gamma)
      | Ite c l r =>
          do v, bdd <- BDD.ite (Ebdd Gamma) (Enext Gamma) c l r;
          Some (v, mk bdd (Eassoc Gamma) (Evalues Gamma) (Enext Gamma))
      | And a b =>
          do  r,bdd <- BDD.andb (Ebdd Gamma) (Enext Gamma) a b;
          Some (r, mk bdd (Eassoc Gamma) (Evalues Gamma) (Enext Gamma))
      | Or a b =>
          do  r,bdd <- BDD.orb (Ebdd Gamma) (Enext Gamma) a b;
          Some (r, mk bdd (Eassoc Gamma) (Evalues Gamma) (Enext Gamma))
      | Xor a b =>
          do r,bdd  <- BDD.xorb (Ebdd Gamma) (Enext Gamma) a b;
          Some (r, mk bdd (Eassoc Gamma) (Evalues Gamma) (Enext Gamma))
      | Not a =>
          do r,bdd <- BDD.negb (Ebdd Gamma) (Enext Gamma) a;
          Some (r, mk bdd (Eassoc Gamma) (Evalues Gamma) (Enext Gamma))
    end.

  Definition lookup (Gamma: Env) (b: BDD.expr) : option (Var Tbool) :=
    BDD.assoc BDD.expr_eqb b (Eassoc Gamma).

  Definition incr Gamma v :=
    let n := (Enext Gamma) in
    let (r, bdd) := BDD.mk_var (Ebdd Gamma) n in
      (r, mk bdd (Eassoc Gamma) (Evalues Gamma ++ [v]) (S n)).

  Definition add_env (Gamma: Env) (v:Var Tbool) (b:BDD.expr): Env :=
    mk (Ebdd Gamma) (List.app (Eassoc Gamma) [(b,v)]) (Evalues Gamma) (Enext Gamma).

  (* Unfortunately, multiple reads from the same state elements cannot be shared *)
  Fixpoint cp_telescope {A} (Gamma: Env) (T : telescope Phi V A) : telescope Phi Var A :=
    match T with
      | & x => & x
      | telescope_bind arg b cont =>
        let (e,sv) := cp_expr arg b in
        match arg return
              (Var arg * sval -> telescope Phi V A) ->
              expr Phi Var arg -> telescope Phi Var A
        with
          | Tbool =>
            match sv with
              | None =>
                fun cont e =>
                  (
                    k :- e;
                    let (ptr, Gamma) := incr Gamma k in
                    cp_telescope Gamma (cont (k, Some ptr))
                  )
              | Some v =>
                fun cont e =>
                  match add_bdd Gamma v with
                    | Some (ptr, Gamma) =>
                      (* the symbolic value correspond to a pointer in the bdd *)
                      match lookup Gamma ptr with
                        | None => (* this pointer does not correspond to a
                                 value. We bind this value, and add it
                                 to the environment*)
                          (k :- e;
                           let Gamma := add_env Gamma k ptr in
                           cp_telescope  Gamma (cont (k, Some ptr)))
                        | Some old =>
                          (* This pointer was already mapped to a value. No need to bind a new value *)
                          cp_telescope Gamma (cont (old, (Some ptr)))
                      end
                    | None =>
                      (* adding to the bdd failed. This should not happen, but is safe *)
                      k :- e; cp_telescope Gamma (cont (k,None))
                  end
            end
          | _ => fun cont e =>
                  k :- e; cp_telescope Gamma (cont (k, None))
        end cont e
    end.

  Definition cp_effects (eff: effects Phi V) : effects Phi Var :=
    DList.map
         (fun (a : mem) (x : (option ∘ effect V) a) =>
            match x with
              | Some x0 =>
                  match x0 in (effect _ s) return ((option ∘ effect Var) s) with
                    | effect_reg_write t x1 x2 =>
                        Some (effect_reg_write Var t (fst x1) (fst x2))
                    | effect_regfile_write n t x1 x2 x3 =>
                        Some (effect_regfile_write Var n t (fst x1) (fst x2) (fst x3))
                  end
              | None => None
            end) eff.

  Definition cp_block  t (b : block Phi V t) : block Phi Var t :=
    (* let b := ( _ :- @Econstant  _ _ Tbool true ; *)
    (*            _ :- @Econstant  _ _ Tbool false ; *)
    (*            b) in  *)
    k :-- cp_telescope empty b;
   match k with (v,g,e) =>
                   & (fst v, fst g, cp_effects  e)
    end.
End t.
Arguments Ebdd {Var} e.
Arguments Evalues {Var} e.
Arguments Eassoc {Var} e.
Arguments Enext {Var} e.

Notation V := (fun t => eval_type t * sval)%type.

Definition value (E: Env eval_type) (e : BDD.expr) v :=
  BDD.pvalue  (Evalues E) (Ebdd E) e v.

Inductive bvalue (E: Env eval_type) : bexpr -> bool -> Type :=
|bvalue_Lift: forall x vx, value E x vx ->
                     bvalue E (Lift x) vx
|bvalue_Ite: forall c vc, value E c vc ->
              forall l vl, value E l vl ->
              forall r vr, value E r vr ->
                     bvalue E (Ite c l r) (if vc then vl else vr)
|bvalue_And: forall a va, value E a va ->
            forall b vb, value E b vb ->
                   bvalue E (And a b) (va && vb)
|bvalue_Or: forall a va, value E a va ->
           forall b vb, value E b vb ->
                   bvalue E (Or a b) (va || vb)
|bvalue_XOr: forall a va, value E a va ->
                     forall b vb, value E b vb ->
                  bvalue E (Xor a b) (xorb va vb)
|bvalue_Not: forall a va, value E a va ->
                      bvalue E (Not a) (negb va).

Notation "G |= x -- y" := (In _ _ _ x y G) (no associativity, at level 71).

(* Recall that V t is defined as  eval_type t * sval, and sval = option BDD.expr.
   We have G |= x -- (v, Some e) when x = v and BDD.value e v
 *)

Record inv (G: Gamma eval_type V) (E: Env eval_type) :=
  {
    inv_1 : forall t (x : eval_type t) y, G |= x -- y -> x = fst y;
    inv_2 : forall (x: eval_type Tbool) x' e , G |= x -- (x', Some e) ->
                                      value E e x;
    inv_path : forall  (x: eval_type B) x' e, G |= x -- (x',Some e) ->
                        BDD.path (Ebdd E) e;
    inv_bdd_wf : BDD.wf  (Ebdd E);
    inv_next_2 : (Enext E) = List.length (Evalues E) ;
    inv_assoc : forall x (y: BDD.expr), Seq.In (y,x) (Eassoc E) -> G |= x -- (x,Some y)
  }.

Arguments inv_1 {G E} _ t x y _.
Arguments inv_2 {G E} _ x x' e _.
Arguments inv_path {G E} _ x x' e _.
Arguments inv_bdd_wf {G E} _.
Arguments inv_next_2 {G E} _.
Arguments inv_assoc {G E} _ x y _.

Notation R := (fun G t x y => In _ _ t x y G).

Ltac d :=
  repeat
    match goal with
          | x: (eval_type _ * sval)%type,
               H: _ |= _ -- ?x' |- _ => constr_eq x x'; destruct x
          | H: context [snd ?x] |- _ => simpl in H
          | H: ?x = Some _ |- _ => subst
        end.

Hint Unfold value.

Lemma cp_expr_correct Phi st :
  forall e1 r1,
    eval_expr Phi st B e1 = r1 ->
    forall G (env : Env eval_type) e2,
      expr_equiv _ _ Phi (R G) B e1 e2 ->
      inv G env ->
      forall sv, snd (cp_expr Phi _ B  e2) = Some sv ->
            bvalue env sv r1.
Proof.
  destruct 1; inversion 1; injectT;  try solve [destruct t; simpl; auto]; intros INV sv; simpl; try discriminate.
  - intros; simpl_do. d. constructor; eapply inv_2; eassumption.
  - intros; simpl_do. d. constructor; eapply inv_2; eassumption.
  - intros; simpl_do. d. constructor; eapply inv_2; eassumption.
  - intros; simpl_do. d. constructor; eapply inv_2; eassumption.
  - destruct c; simpl; intros H; inject H; eauto. constructor. eauto. constructor. eauto.
  - intros; simpl_do. d. constructor; eapply inv_2; eassumption.
Qed.

Lemma cp_effects_correct (Phi : state) st Delta G e  (Hg : inv G e):
  forall e1 e2
  (H : effects_equiv eval_type V Phi (RTL.R eval_type V G) e1 e2),
   eval_effects Phi st e1 Delta =
   eval_effects Phi st (cp_effects Phi eval_type e2) Delta.
Proof.
  intros e1 e2 H.
  apply DList.map3_map.
  eapply DList.pointwise_map; [| apply H];
  clear H; simpl in *; intros.
  inversion X; injectT; unfold RTL.R in *;
  repeat (match goal with
            | |- ?x = ?x  => reflexivity
            | |- context [match ?x with _=> _ end] =>
              case_eq x; intros
            | H' : In _ _ _ ?x ?y _ |- _ =>
              rewrite (inv_1 Hg _ _ _ H')
            | H : context [fst ?x] |- _ => progress (simpl in H)
            | H : ?x = ?x |- _ => clear H
            | H : ?y = ?x, H' : ?x = ?y |- _ => clear H'
            | x : (_ * _)%type |- _ =>  destruct x; simpl; subst
          end); simpl.
Qed.

Lemma inv_cons_None G E t e f:
  inv G E ->
  e = f ->
  inv (cons eval_type V t e (f, None) G) E.
Proof.
  intros Hinv Heq; subst.
  econstructor.
  + intros ty x y.  inversion 1; injectT.  reflexivity.
    apply Hinv; auto.

  + intros x x' e H. inversion H; injectT. discriminate. eapply inv_2; eassumption.
  + intros x x' e H. inversion H; injectT. congruence.  eapply inv_path; eauto.
  + apply Hinv.
  + intros. apply Hinv.
  + intros. apply In_skip. eapply inv_assoc; eauto.
Qed.

Lemma cp_expr_correct_2 Phi st G env (Hg : inv G env) t:
  forall e1 e2, expr_equiv eval_type V Phi (RTL.R eval_type V G) t e1 e2 ->
           forall svo e, cp_expr Phi eval_type t e2 = (e,svo) ->
                           eval_expr Phi st t e1 = eval_expr Phi st t e.
Proof.
  Ltac crush :=
    repeat (match goal with
      | H: (_,_) = (_,_) |- _ => inject H
      | Hg : inv _ _ ,  H : In _ _ _ ?x ?y _ |- context [?x] =>
        rewrite (inv_1 Hg _ _ _ H)
      | H : DList.T [] |- _ => DList.inversion
      | H : DList.T (_ :: _) |- _  => DList.inversion
      | H : DList.pointwise _ ( _ :: _) _ _ |- _ => apply DList.inversion_pointwise in H; destruct H
    end); try reflexivity; try f_equal.
  intros e1. destruct e1; intros e2 H; inversion H; injectT; simpl; intros; unfold RTL.R in *; crush.
  - destruct ty; crush. destruct c; crush.
  - clear H.
    destruct c2. simpl.  destruct s; simpl. destruct e3; simpl.

    Ltac save Hg :=
      repeat match goal with
        |  H : _ |= _ -- _ |- _ =>
           pose proof (inv_1 Hg _ _ _ H);
           pose proof (inv_2 Hg _ _ _ H);
                    clear H
      end.
    save Hg. simpl in *; subst. inversion H0; reflexivity.
    save Hg. simpl in *; subst. inversion H0. reflexivity.
    reflexivity.
    reflexivity.
  - simpl. clear H.
    induction l; repeat DList.inversion;simpl; intuition.
    + crush; eauto.

Qed.
Hint Resolve inv_bdd_wf.

Lemma  incr_inv G E (INV : inv G E) ptr E' e :
  forall (H : incr eval_type E e = (ptr, E')),
    inv (cons eval_type V B e (e, Some ptr) G) E'.
Proof.
  intros H; unfold incr in H.
  destruct (BDD.mk_var (Ebdd E) (Enext E)) as [r bdd] eqn: Heq.
  inject H.
  constructor.
  intros.
  - d. inversion X; injectT. inject H2. reflexivity.
    apply INV. auto.
  - intros x x' e'. inversion 1; injectT. clear X.
    unfold value. inject H0. simpl.
    eapply BDD.mk_var_pcorrect; eauto.
    erewrite <- inv_next_2; eauto.
    unfold value. simpl.
    eapply BDD.pvalue_env_snoc. eapply inv_2 in X0; eauto. eapply BDD.mk_var_incr in Heq; eauto.

  - intros x x' e'. inversion 1; injectT. clear X.
    inject H0. simpl.
    eapply BDD.mk_var_path; eauto.
    simpl.
    eapply inv_path in X0;eauto. eapply BDD.mk_var_incr in Heq; eauto.
  - simpl. eapply BDD.mk_var_incr in Heq; eauto.
  - simpl. rewrite List.app_length. simpl. erewrite inv_next_2;eauto. rewrite plus_comm. reflexivity.
  - simpl. intros x y H. apply In_skip. apply INV. auto.
Qed.

Lemma lookup_in E ptr x:
  lookup eval_type E ptr = Some x ->
  Seq.In (ptr,x) (Eassoc E).
Proof.
  unfold lookup. induction (Eassoc E). simpl. discriminate.
  simpl. destruct a.
  destruct (BDD.expr_eqb ptr e) eqn: Heq.
  intros H; inject H.
  apply BDD.expr_eqb_correct in Heq; subst.
  apply Seq.In_cons.

  intros H. right. auto.
Qed.

Lemma add_bdd_correct G E E' (INV: inv G E) sv v ptr:
  bvalue E sv v ->
  add_bdd eval_type E sv = Some (ptr, E') ->
  (value E' ptr v * inv G E' )%type.
Proof.
  destruct sv; simpl; intros H H'; simpl_do; inversion H; injectT.

  - split; eauto.
  - refine (let (Hv, Hi) := BDD.ite_pcorrect (Ebdd E) (inv_bdd_wf INV  : BDD.wf (Ebdd E))
                                      _ _ _ c l r _ H0 _ H4 _ H6 _ H7 in _ ).
    split; eauto.
    Lemma inv_update_bdd G E bdd' (Hincr: BDD.incr (Ebdd E) bdd')
    : inv G E ->
      inv G
          {| Ebdd := bdd';
             Eassoc := Eassoc E;
             Evalues := Evalues E;
             Enext := Enext E|}.
      Proof.
        intros INV. constructor; try apply INV.
        simpl. intros. unfold value. simpl. eapply BDD.pvalue_incr; eauto. apply (inv_2 INV) in X; apply X.
        intros. simpl. eapply BDD.incr_path. eapply (inv_path INV) in X; apply X.
        simpl. apply Hincr. apply INV.
      Qed.
      apply inv_update_bdd; auto.

  - refine (let (Hv,Hi) := BDD.andb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _ _ x0 H0 va H3 vb H5 in _).
    split; eauto using inv_update_bdd.
  - refine (let (Hv,Hi) := BDD.orb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _ _ x0 H0 va H3 vb H5 in _).
    split; auto using inv_update_bdd.
  - refine (let (Hv,Hi) := BDD.xorb_pcorrect (Evalues E) (Ebdd E)  (inv_bdd_wf INV) _ _ _ _ x0 H0 va H3 vb H5 in _).
    split; auto using inv_update_bdd.
  - refine (let (Hv,Hi) := BDD.negb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _  x0 H0 va H2 in _).
    split; auto using inv_update_bdd.
Qed.

Lemma add_bdd_correct_2 G E E' (INV: inv G E) sv v ptr:
  bvalue E sv v ->
  add_bdd eval_type E sv = Some (ptr, E') ->
  forall x vx,
    value E x vx -> value E' x vx.
Proof.
  destruct sv; simpl; intros H H'; simpl_do; inversion H; injectT; clear H; auto.
  - refine (let (Hv, Hi) := BDD.ite_pcorrect (Ebdd E) (inv_bdd_wf INV : BDD.wf (Ebdd E))
                                      _ _ _ c l r _ H0 _ H5 _ H7 _ H8 in _ ).
    eapply BDD.pvalue_incr. eauto.  simpl. eauto.

  - refine (let (Hv,Hi) := BDD.andb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _ _ x0 H0 va H4 vb H6 in _).
    eauto using BDD.pvalue_incr.
  - refine (let (Hv,Hi) := BDD.orb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _ _ x0 H0 va H4 vb H6 in _).
    eauto using BDD.pvalue_incr.
  - refine (let (Hv,Hi) := BDD.xorb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _ _ x0 H0 va H4 vb H6 in _).
    eauto using BDD.pvalue_incr.
  - refine (let (Hv,Hi) := BDD.negb_pcorrect (Evalues E) (Ebdd E) (inv_bdd_wf INV) _ _ _  x0 H0 va H2 in _).
    eauto using BDD.pvalue_incr.
Qed.

Lemma inv_cons_lookup_Some G E (INV : inv G E) E2 sv ptr old v:
  add_bdd eval_type E sv = Some (ptr, E2) ->
  lookup eval_type E2 ptr = Some old ->
  bvalue E sv v ->
  inv (cons eval_type V B v (old, Some ptr) G) E2.
Proof.
  intros.
  constructor.
  -intros.  d. inversion X; injectT. inject H5. clear X.
   simpl.

   apply lookup_in in H0.

   destruct (add_bdd_correct _ _ _ INV _ _ _ H1 H) as [Hv INV2].
   apply (inv_assoc INV2) in H0.
   apply (inv_2 INV2) in H0.
   unfold value in *.
   eapply BDD.pvalue_inj; eauto.
   apply INV; auto.
  - intros x x' e.

    inversion 1; injectT.
    + clear X. inject H3. eapply add_bdd_correct in H; eauto.  intuition.
    + eapply add_bdd_correct_2; eauto.
      eapply inv_2 in X0; eauto.
  - intros x x' e. inversion 1; injectT.  inject H3.
    eapply add_bdd_correct in H; eauto.  destruct H as [Hv H'].
    eapply BDD.path_of_pvalue; eauto.

    eapply (inv_path).  2: eapply X0.
    eapply add_bdd_correct in H; eauto.  destruct H as [Hv H']. auto.
  - exact (let (_,H) := @add_bdd_correct _ _ _ INV _ _ _ H1 H in
           @inv_bdd_wf _ _ H).
  -  eapply add_bdd_correct in H; eauto.  destruct H as [Hv H']. apply H'.
  - intros.  eapply add_bdd_correct in H; eauto.  destruct H as [Hv H'].
    apply In_skip. apply H'. eauto.
Qed.

Lemma inv_cons_lookup_None G E (INV : inv G E) E2 sv ptr X:
  add_bdd eval_type E sv = Some (ptr, E2) ->
  lookup eval_type E2 ptr = None ->
  bvalue E sv X ->
  inv (cons eval_type V B X (X, Some ptr) G) (add_env eval_type E2 X ptr).
Proof.
  intros.
  constructor.
  -intros.  d. inversion X0; injectT. inject H5. reflexivity.
   eapply inv_1; eauto.
  - intros x x' e. inversion 1; injectT. inject H3.
    destruct (add_bdd_correct _ _ _ INV _ _ _ H1 H) as [Hv INV2].
    unfold add_env.
    unfold value. simpl. unfold value in Hv. apply Hv.
    unfold value. simpl.
    eapply inv_2 in X1.
    apply X1.     destruct (add_bdd_correct _ _ _ INV _ _ _ H1 H) as [Hv INV2].  eauto.
  - intros x x' e. inversion 1; injectT.  inject H3.
    eapply add_bdd_correct in H; eauto.  destruct H as [Hv H'].
    eapply BDD.path_of_pvalue; eauto.

    simpl.
    eapply (inv_path). 2: eapply X1.
    eapply add_bdd_correct in H; eauto.  simpl. destruct H as [Hv H']. auto.
  - exact (let (_,H) := @add_bdd_correct _ _ _ INV _ _ _ H1 H in
           @inv_bdd_wf _ _ H).
  -  eapply add_bdd_correct in H; eauto.  destruct H as [Hv H']. apply H'.
  - intros.
    simpl in X0.
    apply Seq.In_app in X0.
    eapply add_bdd_correct in H; eauto.  destruct H as [Hv H'].
    destruct X0.
    apply In_skip.
    apply H'.  auto.
    inversion i; subst.
    apply In_ok. reflexivity. reflexivity.
    inversion H2.
Qed.

Lemma cp_telescope_correct (Phi: state) st t  Delta:
       forall (b : RTL.block Phi eval_type t)
         (b': RTL.block Phi V t)
         (G : Gamma eval_type V),
         block_equiv eval_type V Phi t G b b' ->
       forall e,
       inv  G e
     ->
   eval_telescope Phi st
     (fun x : eval_type t * bool * effects Phi eval_type =>
      let (y, e0) := x in
      let (p, g) := y in check g; Some (p, eval_effects Phi st e0 Delta)) b =
   eval_telescope Phi st
     (fun x : eval_type t * bool * effects Phi eval_type =>
      let (y, e0) := x in
      let (p, g) := y in check g; Some (p, eval_effects Phi st e0 Delta))
     (k :-- cp_telescope Phi eval_type e b';
      (let (p, e0) := k in
       let (v, g) := p in & (fst v, fst g, cp_effects Phi eval_type e0))).
Proof.
  Ltac crush ::=
    repeat match goal with
             | H: (_,_) = (_,_) |- _ => injection H; clear H; intros; subst
             | HG : inv ?G ?e , H : In _ _ _ ?x ?y _ |- context [?x] =>
               rewrite (inv_1 HG _ _ _ H)
             | H : DList.T [] |- _ => DList.inversion
             | H : DList.T (_ :: _) |- _  => DList.inversion
             | H : DList.pointwise _ ( _ :: _) _ _ |- _ => apply DList.inversion_pointwise in H; destruct H
             | |- Some _ = Some _ => f_equal
             | |- (_,_) = (_,_) => f_equal
             | |- context [eval_type _] => simpl eval_type
           end; try reflexivity.

  induction 1 as [G v1 v2 g1 g2 e1 e2 Hv Hg He| G a e1 e2 k1 k2 He Hk IH]; simpl; intros E INV.
  - crush.
    match goal with
      |- context [(if ?x then _ else _) = (if ?y then _ else _)] =>
      let H := fresh in
      assert (H : x = y)  by reflexivity;
      subst; clear H; destruct x
    end; f_equal; f_equal. eapply cp_effects_correct; eauto.
  - destruct (cp_expr Phi eval_type a e2) as [binding [sv | ]]eqn: Heq; destruct a;
    try (apply IH; apply inv_cons_None; eauto using cp_expr_correct_2 ).

    {
       destruct (add_bdd eval_type E sv) as [[ptr E2] | ]eqn:Heq2; [|apply IH].
       destruct (lookup eval_type E2 ptr) as [old | ] eqn:Heq3; apply IH.
       clear IH.
       pose proof (cp_expr_correct_2 _ st _ _ INV _ _ _ He _ _ Heq).
       rewrite H.
       pose proof (cp_expr_correct _ _ _ _ H _ _ _ He INV sv). rewrite Heq in H0. simpl in H0.
       specialize (H0 eq_refl).
       eapply inv_cons_lookup_Some; eauto.
       pose proof (cp_expr_correct_2 _ st _ _ INV _ _ _ He _ _ Heq).
       rewrite H.
       pose proof (cp_expr_correct _ _ _ _ H _ _ _ He INV sv). simpl in H0.
       rewrite Heq in H0. simpl in H0. specialize (H0 eq_refl).

       eapply inv_cons_lookup_None; eauto.
       apply inv_cons_None; eauto using cp_expr_correct_2.
    }
    {
      simpl.
      destruct (incr eval_type E (eval_expr Phi st B binding)) as [ptr E'] eqn: Hincr.
      apply IH; clear IH.
      eapply cp_expr_correct_2 in Heq; eauto.
      rewrite Heq; clear Heq.
      revert Hincr.
      generalize (eval_expr Phi st B binding).
      intros e H.
      eapply incr_inv; eauto.
    }

Qed.

Lemma Gamma_inv_empty : inv  (nil _ _ ) (empty eval_type).
Proof.
  econstructor.
  - intros. inversion X.
  - intros. inversion X.
  - intros. inversion X.
  - intros. apply BDD.wf_empty.
  - simpl. reflexivity.
  - simpl. intros.  inversion H.
Qed.

Theorem cp_correct Phi st t (b : Block Phi t) Delta : WF Phi t b ->
  eval_block Phi st t (b _) Delta = eval_block Phi st t (cp_block Phi eval_type t (b _)) Delta.
Proof.
  intros.
  eapply cp_telescope_correct; eauto using Gamma_inv_empty.
Qed.

Definition Compile Phi t (b : Block Phi t) : Block Phi t :=
  fun V => cp_block Phi V t (b _).

Theorem Compile_correct Phi t b (Hwf : WF Phi t b) st :
  Next Phi st t (Compile Phi t b) =  Next Phi st t b.
Proof.
  unfold Next. intros. unfold Compile. symmetry. rewrite cp_correct; auto.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
From Equations Require Import Equations.

Require Export SystemFR.ErasedRec.
Require Export SystemFR.ErasedNat.

Require Export SystemFR.FVLemmasLists.
Require Export SystemFR.WFLemmasLists.

Require Export SystemFR.StrictPositivityPush.
Require Export SystemFR.StrictPositivityPull.
Require Export SystemFR.StrictPositivitySubst.

Require Export SystemFR.BaseTypeLemmas.
Require Export SystemFR.BaseTypeSyntaxLemmas.

Require Import Psatz.

Opaque reducible_values.
Opaque strictly_positive.
Opaque makeFresh.

Lemma non_empty_nat:
  forall ρ, non_empty ρ T_nat.
Proof.
  unfold non_empty; intros; exists zero; repeat step || simp_red.
Qed.

Ltac t_instantiate_reducible3 :=
  match goal with
  | H1: [ _ ⊨ ?v : _ ]v, H3: forall a, _ -> _ -> _ |- _ =>
    poseNew (Mark (v, H3) "t_instantiate_reducible");
    unshelve epose proof (H3 v _ H1)
  end.

(** Rules for unfold **)

Lemma reducible_values_unfold_gen:
  forall T0 Ts ρ v X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    pfv T0 term_var = nil ->
    pfv Ts term_var = nil ->
    valid_interpretation ρ ->
    [ ρ ⊨ v : intersect T0 Ts ]v ->
    [ ρ ⊨ v : topen 0 Ts (intersect T0 Ts) ]v.
Proof.
  unfold intersect in *; repeat step.
  apply strictly_positive_push_forall2 with X;
    repeat match goal with
           | H: [ _ ⊨ _ : T_forall _ _ ]v |- _ => simp reducible_values in H
           | H: [ _ ⊨ _ : T_rec _ _ _ ]v |- _  => simp reducible_values in H
           | H1: [ _ ⊨ ?v : T_nat ]v, H3: forall a, _ -> _ -> _ |- _ =>
             poseNew (Mark (v,H3) "t_instantiate_reducible");
             unshelve epose proof (H3 (succ v) _ _ _ _)
           | _ => step || (rewrite open_none in * by steps) || apply reducible_values_succ || list_utils
           end;
      eauto using non_empty_nat;
      eauto with erased;
      try solve [ t_closing ];
      eauto 3 using smallstep_succ_zero with exfalso.

  apply reducible_values_subst_head in H23;
    repeat step || t_invert_star || list_utils ||
           (rewrite (is_erased_term_tfv v') in * by eauto with erased);
      eauto with twf wf erased fv values.

  lazymatch goal with
  | H: ?v1 ~>* ?v2 |- _ =>
    unshelve epose proof (star_smallstep_value v1 v2 H _); clear H2
  end;
    repeat step || list_utils;
    eauto with values.
Qed.

Lemma reducible_unfold_gen:
  forall T0 Ts ρ t X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    pfv T0 term_var = nil ->
    pfv Ts term_var = nil ->
    valid_interpretation ρ ->
    [ ρ ⊨ t : intersect T0 Ts ] ->
    [ ρ ⊨ t : topen 0 Ts (intersect T0 Ts) ].
Proof.
  unfold reduces_to; steps.
  exists v; repeat step || apply star_unfold_fold;
    try solve [ t_closing ];
    eauto using reducible_values_unfold_gen.
Qed.

Lemma open_reducible_unfold_gen:
  forall T0 Ts Θ Γ t X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    subset (fv T0) (support Γ) ->
    subset (fv Ts) (support Γ) ->
    [ Θ; Γ ⊨ t : intersect T0 Ts ] ->
    [ Θ; Γ ⊨ t : topen 0 Ts (intersect T0 Ts) ].
Proof.
  unfold open_reducible;
    repeat step || rewrite substitute_topen;
    eauto with twf.

  apply reducible_unfold_gen with
    (makeFresh (
      pfv (psubstitute Ts lterms term_var) type_var ::
      pfv Ts type_var ::
      nil
    )); steps;
    eauto with wf;
    eauto with fv;
    eauto with twf;
    eauto with erased;
    try finisher.

  rewrite substitute_topen2;
    repeat step;
    eauto with twf.

  apply strictly_positive_subst;
    repeat step || apply is_erased_type_topen; eauto with twf; eauto with fv.
  eapply strictly_positive_rename_one; eauto;
    repeat step; try finisher.
Qed.

(** Rules for unfold_in **)

Lemma reducible_unfold_in_gen:
  forall T0 Ts ρ t1 t2 X T,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    pfv T0 term_var = nil ->
    pfv Ts term_var = nil ->
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : intersect T0 Ts ] ->
    (forall v,
      [ t1 ≡ v ] ->
      [ ρ ⊨ v : topen 0 Ts (intersect T0 Ts) ]v ->
      [ ρ ⊨ open 0 t2 v : T ]) ->
    [ ρ ⊨ app (notype_lambda t2) t1 : T ].
Proof.
  intros.
  match goal with
  | H:[ _ ⊨ _ : intersect _ _ ] |- _ => unfold reduces_to in H
  end; steps.

  eapply star_backstep_reducible; eauto with cbvlemmas values;
    repeat step || list_utils;
    eauto with wf twf fv erased.

  eapply backstep_reducible; eauto with smallstep values;
    repeat step || list_utils;
    eauto with wf twf fv erased;
    try t_closing.

  apply_any;
    eauto using reducible_values_unfold_gen;
    eauto using equivalent_star.
Qed.

Lemma open_reducible_unfold_in_gen:
  forall T0 Ts Θ Γ t1 t2 X T p y,
    ~(p ∈ Θ) ->
    ~(p ∈ pfv_context Γ term_var) ->
    ~(p ∈ support Γ) ->
    ~(p ∈ fv t1) ->
    ~(p ∈ fv t2) ->
    ~(p ∈ fv T0) ->
    ~(p ∈ fv Ts) ->
    ~(p ∈ fv T) ->
    ~(y ∈ Θ) ->
    ~(y ∈ pfv_context Γ term_var) ->
    ~(y ∈ support Γ) ->
    ~(y ∈ fv t1) ->
    ~(y ∈ fv t2) ->
    ~(y ∈ fv T0) ->
    ~(y ∈ fv Ts) ->
    ~(y ∈ fv T) ->
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    wf t1 0 ->
    wf t2 0 ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    subset (pfv t1 term_var) (support Γ) ->
    subset (pfv t2 term_var) (support Γ) ->
    ~(p = y) ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    subset (fv T0) (support Γ) ->
    subset (fv Ts) (support Γ) ->
    [ Θ; Γ ⊨ t1 : intersect T0 Ts ] ->
    [ Θ; (p, T_equiv t1 (fvar y term_var)) :: (y, topen 0 Ts (intersect T0 Ts)) :: Γ ⊨
      open 0 t2 (fvar y term_var) : T ] ->
    [ Θ; Γ ⊨ app (notype_lambda t2) t1 : T ].
Proof.
  unfold open_reducible;
    repeat step || rewrite substitute_topen;
    eauto with twf.

  apply reducible_unfold_in_gen with
    (psubstitute T0 lterms term_var)
    (psubstitute Ts lterms term_var)
    (makeFresh (
      pfv (psubstitute Ts lterms term_var) type_var ::
      pfv Ts type_var ::
      nil
    )); steps;
    eauto with wf;
    eauto with twf;
    eauto with erased;
    eauto with fv;
    try finisher.

  - rewrite substitute_topen2;
      repeat step;
      eauto with twf.

    apply strictly_positive_subst;
      repeat step || apply is_erased_type_topen; eauto with twf; eauto with fv.
    eapply strictly_positive_rename_one; eauto;
      repeat step; try finisher.

  - unshelve epose proof (H33 ρ ((p, uu) :: (y,v) :: lterms) _ _ _);
      repeat match goal with
             | |- [ _ ⊨ _ : T_equiv _ _ ]v => simp reducible_values
             | _ => step || list_utils || nodup || apply SatCons || t_substitutions || fv_open
             end;
        t_closer.
Qed.

(** Fold Rules **)

Lemma reducible_values_fold_gen:
  forall T0 Ts ρ v X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    pfv T0 term_var = nil ->
    pfv Ts term_var = nil ->
    valid_interpretation ρ ->
    (forall v,
        [ ρ ⊨ v : topen 0 Ts (T_rec zero T0 Ts) ]v ->
        [ ρ ⊨ v : T0 ]v) ->
    [ ρ ⊨ v : topen 0 Ts (intersect T0 Ts) ]v ->
    [ ρ ⊨ v : intersect T0 Ts ]v.
Proof.
  unfold intersect in *; repeat step.
  simp reducible_values; repeat step || (rewrite open_none in * by steps); try solve [ t_closing ].

  unshelve epose proof
           (strictly_positive_pull_forall _ _ _ _ _ X _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H11) as HH;
    repeat step || list_utils; eauto using non_empty_nat;
      eauto with wf.

  simp_red_nat.
  t_invert_nat_value; repeat step || simp_red;
    try solve [ t_closing ];
    eauto with smallstep.
  - (* case a = 0, we use the decreasing property *)
    left; repeat step || apply_any.
    unshelve epose proof (HH zero _);
      repeat step || simp_red || rewrite open_none in * by steps.
  - (* case a = n+1 *)
    right; exists v0, (makeFresh (
                     support ρ ::
                     pfv v0 type_var ::
                     pfv T0 type_var ::
                     pfv Ts type_var ::
                     (X :: nil) ::
                     nil));
    repeat step;
    try finisher.

    apply reducible_values_subst_head2;
      repeat step || list_utils;
      try finisher;
      eauto with wf twf.

    unshelve epose proof (HH v0 _); repeat step || simp_red || rewrite open_none in * by steps.
Qed.

Lemma reducible_fold_gen:
  forall T0 Ts ρ t X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    pfv T0 term_var = nil ->
    pfv Ts term_var = nil ->
    valid_interpretation ρ ->
    (forall v,
        [ ρ ⊨ v : topen 0 Ts (T_rec zero T0 Ts) ]v ->
        [ ρ ⊨ v : T0 ]v) ->
    [ ρ ⊨ t : topen 0 Ts (intersect T0 Ts) ] ->
    [ ρ ⊨ t : intersect T0 Ts ].
Proof.
  unfold reduces_to;
    repeat step.
  exists v; repeat step;
    try solve [ t_closing ];
    eauto using reducible_values_fold_gen;
    eauto with cbvlemmas.
Qed.

Lemma open_reducible_fold_gen:
  forall T0 Ts Θ Γ t X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    subset (fv T0) (support Γ) ->
    subset (fv Ts) (support Γ) ->
    (forall ρ l,
        valid_interpretation ρ ->
        satisfies (reducible_values ρ) Γ l ->
        support ρ = Θ ->
        (forall v,
            [ ρ ⊨ v : topen 0 (psubstitute Ts l term_var)
                              (T_rec zero
                                     (psubstitute T0 l term_var)
                                     (psubstitute Ts l term_var)) ]v ->
            [ ρ ⊨ v : psubstitute T0 l term_var ]v)) ->
    [ Θ; Γ ⊨ t : topen 0 Ts (intersect T0 Ts) ] ->
    [ Θ; Γ ⊨ t : intersect T0 Ts ].
Proof.
  unfold open_reducible; steps.
  apply reducible_fold_gen with X;
    repeat step || apply subst_erased_type || t_instantiate_sat4;
    eauto with wf;
    eauto with twf;
    eauto using pfv_in_subst with fv;
    eauto with erased.

  - rewrite substitute_topen2;
      repeat step || apply strictly_positive_subst || apply is_erased_type_topen ||
      eauto with twf;
      eauto with fv.
  - rewrite_anywhere substitute_topen; eauto with twf.
Qed.

Lemma open_reducible_fold_gen2:
  forall T0 Ts Θ Γ t X,
    wf T0 0 ->
    wf Ts 0 ->
    twf T0 0 ->
    twf Ts 1 ->
    ~(X ∈ pfv Ts type_var) ->
    strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil) ->
    is_erased_type T0 ->
    is_erased_type Ts ->
    subset (fv T0) (support Γ) ->
    subset (fv Ts) (support Γ) ->
    base_type X (topen 0 Ts (fvar X type_var)) T0 ->
    [ Θ; Γ ⊨ t : topen 0 Ts (intersect T0 Ts) ] ->
    [ Θ; Γ ⊨ t : intersect T0 Ts ].
Proof.
  intros; apply open_reducible_fold_gen with X; steps.
  apply base_type_approx with X (topen 0 Ts (fvar X type_var))
    (fun v => [ ρ ⊨ v : T_rec zero (psubstitute T0 l term_var) (psubstitute Ts l term_var) ]v) ;
    repeat step || apply reducibility_is_candidate || list_utils;
    eauto with wf fv;
    eauto with erased.

  rewrite <- substitute_topen2; steps; eauto with twf.
  apply reducible_values_subst_head2;
    repeat step || list_utils || apply reducibility_is_candidate ||
           rewrite fv_subst_different_tag in * by (steps; eauto with fv);
    eauto with fv wf twf erased;
    eauto using reducibility_is_candidate.
Qed.


(** ***************************************************************

Contents :

  - Definition of the category of algebras of a monad

  - The free-forgetful adjunction between a category C and the
    category of algebras of a monad on C

  - For monads S, T on C: lifting of T to a monad on the category
    of S-algebras

******************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.Derivative.

Local Open Scope cat.

Ltac rewrite_cbn x := let H := fresh in (set (H := x); cbn in H; rewrite H; clear H).
Ltac rewrite_cbn_inv x := let H := fresh in (set (H := x); cbn in H; rewrite <- H; clear H).

Section Algebras.

Context {C : category} (T : Monad C).

(** Definition of an algebra of a monad T *)

Section Algebra_def.

Definition Algebra_data : UU := ∑ X : C, T X --> X.

Coercion Alg_carrier (X : Algebra_data) : C := pr1 X.

Definition Alg_map (X : Algebra_data) : T X --> X := pr2 X.

Definition Algebra_laws (X : Algebra_data) : UU
  := (η T X · Alg_map X = identity X)
   × (μ T X · Alg_map X = #T (Alg_map X) · Alg_map X).

Definition Algebra : UU := ∑ X : Algebra_data, Algebra_laws X.

Coercion Algebra_data_from_Algebra (X : Algebra) : Algebra_data := pr1 X.

Definition Algebra_idlaw (X : Algebra) : η T X · Alg_map X = identity X
  := pr1 (pr2 X).

Definition Algebra_multlaw (X : Algebra) : μ T X · Alg_map X = #T (Alg_map X) · Alg_map X
  := pr2 (pr2 X).

Definition free_Algebra (X : C) : Algebra.
Proof.
  use tpair.
  - exists (T X).
    exact (μ T X).
  - abstract (split;
              [apply Monad_law1 |
               apply pathsinv0;
               apply Monad_law3]).
Defined.

End Algebra_def.

(** Data for the category of algebras of the monad T, following FunctorAlgebras.v *)

Section Algebra_precategory_data.

Definition is_Algebra_mor {X Y : Algebra} (f : X --> Y) : UU
  := Alg_map X · f = #T f · Alg_map Y.

Definition Algebra_mor (X Y : Algebra) : UU
  := ∑ f : X --> Y, is_Algebra_mor f.

Coercion mor_from_Algebra_mor {X Y : Algebra} (f : Algebra_mor X Y)
  : X --> Y := pr1 f.

Definition Algebra_mor_commutes {X Y : Algebra} (f : Algebra_mor X Y)
  : Alg_map X · f = #T f · Alg_map Y := pr2 f.

Definition Algebra_mor_id (X : Algebra) : Algebra_mor X X.
Proof.
  exists (identity X).
  abstract (unfold is_Algebra_mor;
            rewrite functor_id, id_right, id_left;
            apply idpath).
Defined.

Definition Algebra_mor_comp (X Y Z : Algebra) (f : Algebra_mor X Y) (g : Algebra_mor Y Z)
  : Algebra_mor X Z.
Proof.
  exists (f · g).
  abstract (unfold is_Algebra_mor;
            rewrite assoc;
            rewrite Algebra_mor_commutes;
            rewrite <- assoc;
            rewrite Algebra_mor_commutes;
            rewrite functor_comp, assoc;
            apply idpath).
Defined.

Definition precategory_Alg_ob_mor : precategory_ob_mor
  := (Algebra,, Algebra_mor).

Definition precategory_Alg_data : precategory_data
  := (precategory_Alg_ob_mor,, Algebra_mor_id,, Algebra_mor_comp).

End Algebra_precategory_data.

End Algebras.

(** Definition of the category MonadAlg of algebras for T. Requires that C is a category. *)

Section Algebra_category.

Context {C : category} (T : Monad C).

Definition Algebra_mor_eq {X Y : Algebra T} {f g : Algebra_mor T X Y}
  : (f : X --> Y) = g ≃ f = g.
Proof.
  apply invweq.
  apply subtypeInjectivity.
  intro h.
  apply homset_property.
Defined.

Lemma is_precategory_precategory_Alg_data : is_precategory (precategory_Alg_data T).
Proof.
  apply make_is_precategory; intros;
  apply Algebra_mor_eq.
  - apply id_left.
  - apply id_right.
  - apply assoc.
  - apply assoc'.
Qed.

Definition MonadAlg_precat : precategory := ( _,, is_precategory_precategory_Alg_data).

Lemma has_homsets_MonadAlg : has_homsets MonadAlg_precat.
Proof.
  intros X Y.
  apply (isofhleveltotal2 2).
  - apply homset_property.
  - intro f.
    apply isasetaprop.
    apply homset_property.
Qed.

Definition MonadAlg: category := MonadAlg_precat ,, has_homsets_MonadAlg.

End Algebra_category.

(** Adjunction between MonadAlg T and C, with right adjoint the forgetful functor
   and left adjoint the free algebra functor. *)

Section Algebra_adjunction.

Context {C : category} (T : Monad C).

Definition forget_Alg_data : functor_data (MonadAlg T) C.
Proof.
  exists (fun X => (X : Algebra T)).
  intros X Y f.
  apply f.
Defined.

(* forgetful functor from MonadAlg T to its underlying category *)

Definition forget_Alg : functor (MonadAlg T) C.
Proof.
  exists forget_Alg_data.
  abstract (split; red; intros; apply idpath).
Defined.

Definition free_Alg_data : functor_data C (MonadAlg T).
Proof.
  exists (free_Algebra T).
  intros X Y f.
  exists (#T f).
  apply pathsinv0.
  apply (nat_trans_ax (μ T)).
Defined.

(* free T-algebra functor on C *)

Definition free_Alg : functor C (MonadAlg T).
Proof.
  exists free_Alg_data.
  abstract (split; red; intros;
            apply subtypePairEquality';
            [ apply functor_id |
              apply homset_property |
              apply functor_comp |
              apply homset_property]).
Defined.

Definition free_forgetful_are_adjoints : are_adjoints free_Alg forget_Alg.
Proof.
  use make_are_adjoints.
  - apply (make_nat_trans _ _ (η T)).
    intros X Y f.
    apply η.
  - use make_nat_trans.
    + intro X.
      exact (Alg_map T (X : Algebra T),, Algebra_multlaw T X).
    + intros X Y f.
      apply Algebra_mor_eq; cbn.
      apply pathsinv0.
      apply f.
  - abstract (split; intro X;
              [apply Algebra_mor_eq; cbn;
               apply Monad_law2 |
               apply Algebra_idlaw]).
Defined.

Definition forget_free_is_T : free_Alg ∙ forget_Alg = T.
Proof.
  apply functor_eq.
  - apply homset_property.
  - apply idpath.
Defined.

Definition Alg_adjunction_monad_eq : Monad_from_adjunction free_forgetful_are_adjoints = T.
Proof.
  apply Monad_eq_raw_data.
  apply idpath.
Defined.

End Algebra_adjunction.

Section Liftings.

Context {C : category} (S T : Monad C).

(** A lifting of (T, η, μ) is a monad (T', η', μ') on (MonadAlg S) which commutes with the
forgetful functor:
<<
                    T'
  (MonadAlg S) ----------> (MonadAlg S)
       |                        |
       | forget_Alg             | forget_Alg
       |                        |
       V                        V
       C ---------------------> C
                    T
>>
and forget_Alg ∙ η = η' ∙ forget_Alg,
    forget_Alg ∙ μ = μ' ∙ forget_Alg.
 *)

Definition lift_eq (T' : Monad (MonadAlg S)) : UU
  := functor_composite_data (forget_Alg S) T  =
      functor_composite_data T' (forget_Alg S).

Definition lift_η_commutes (T' : Monad (MonadAlg S)) (e : lift_eq T') : UU
  := transportf _ e (pre_whisker (forget_Alg S) (η T)) =
     (post_whisker (η T') (forget_Alg S)).

(* forget_Alg S ∙ (T ∙ T) = (T' ∙ T') ∙ forget_Alg S *)
Definition eq2 (T' : Monad (MonadAlg S))(e : lift_eq T')
  : functor_composite_data (forget_Alg S) (functor_composite_data T T) =
  functor_composite_data (functor_composite_data T' T') (forget_Alg S).
Proof.
  apply (pathscomp0 (maponpaths (fun X => functor_composite_data X T) e)).
  exact (maponpaths (functor_composite_data T') e).
Defined.

Definition lift_μ_commutes (T' : Monad (MonadAlg S)) (e : lift_eq T') : UU
  := transportf (fun X => X ⟹ (T' ∙ forget_Alg S)) (eq2 T' e)
                (transportf _ e (pre_whisker (forget_Alg S) (μ T)))  =
     (post_whisker (μ T') (forget_Alg S)).

Definition lifting : UU
  := ∑ T' : Monad (MonadAlg S),
      (∑ e : lift_eq T', (lift_η_commutes T' e) × (lift_μ_commutes T' e)).

(** A distributive law of S over T induces a lifting of T to S-Algebras *)

Section Lifting_from_dist_law.

Context  {a : T ∙ S ⟹ S ∙ T} (l : monad_dist_laws a).

Definition T_on_SAlg : Algebra S -> Algebra S.
Proof.
  intro X.
  use tpair.
  - exists (T X).
    exact (a X · (# T) (Alg_map S X)).
  - abstract (split; cbn;
              [ rewrite assoc;
                rewrite <- functor_id;
                rewrite <- Algebra_idlaw;
                rewrite functor_comp;
                rewrite <- (monad_dist_law1 l);
                apply idpath |
                rewrite 2 assoc;
                rewrite functor_comp;
                rewrite assoc4;
                rewrite_cbn (nat_trans_ax a _ _ (Alg_map S X));
                rewrite_cbn_inv (monad_dist_law4 l X);
                rewrite <- assoc4;
                rewrite <- assoc;
                rewrite <- functor_comp;
                rewrite_cbn (Algebra_multlaw S X);
                rewrite functor_comp;
                apply assoc]).
Defined.

Definition lift_functor : (MonadAlg S) ⟶ (MonadAlg S).
Proof.
  use make_functor.
  - exists T_on_SAlg.
    intros X Y f.
    exists ((# T) (mor_from_Algebra_mor S f)).
    abstract (red; cbn;
              rewrite <- assoc;
              rewrite <- functor_comp;
              rewrite Algebra_mor_commutes;
              rewrite functor_comp;
              rewrite 2 assoc;
              apply cancel_postcomposition;
              apply pathsinv0;
              apply a).
  - abstract (split; red; intros; cbn;
              apply subtypePairEquality';
              [ apply functor_id |
                apply homset_property |
                apply functor_comp |
                apply homset_property]).
Defined.

Definition lift_η : functor_identity (MonadAlg S) ⟹ lift_functor.
Proof.
  use make_nat_trans.
    - intro X. cbn in X.
      exists (η T X).
      abstract (red; cbn;
                rewrite assoc;
                rewrite_cbn (monad_dist_law2 l X);
                apply (nat_trans_ax (η T))).
    - abstract (intros X Y f;
                apply subtypePath;
                cbn;
                [ intro; apply homset_property | apply (nat_trans_ax (η T))]).
Defined.

Definition lift_μ : lift_functor ∙ lift_functor ⟹ lift_functor.
Proof.
  use make_nat_trans.
    - intro X. cbn in X.
      exists (μ T X).
      abstract (red; cbn;
                rewrite functor_comp;
                rewrite <- assoc4;
                rewrite assoc;
                rewrite_cbn_inv (monad_dist_law3 l X);
                rewrite <- assoc;
                rewrite_cbn (nat_trans_ax (μ T) _ _ (Alg_map S X));
                apply assoc).
     - abstract (intros X Y f;
                 apply subtypePath;
                 cbn;
                 [ intro; apply homset_property | apply (nat_trans_ax (μ T))]).
Defined.

Definition lift_monad : Monad (MonadAlg S).
Proof.
  exists ((lift_functor ,, lift_μ) ,, lift_η).
  abstract (split;
            [ split; intro X;
              apply subtypePath;
              [ intro; apply homset_property |
                apply Monad_law1 |
                intro; apply homset_property |
                apply Monad_law2] |
              intro X; apply subtypePath;
              [ intro; apply homset_property |
                apply Monad_law3 ] ]).
Defined.

Definition lifting_from_dist_law : lifting.
Proof.
  exists lift_monad.
  exists (idpath _).
  split.
  - apply nat_trans_eq.
    + apply homset_property.
    + intro X.
      apply idpath.
  - apply nat_trans_eq.
    + apply homset_property.
    + intro X.
      apply idpath.
Defined.

End Lifting_from_dist_law.

(** TODO: Construct distributive law from lifting, show distributive laws are equivalent
          to liftings. *)

End Liftings.


Require Import ZArith.

Require Import FMapInterface.
Require Import FMapPositive.
Require Import FMapList.
Require Import FMapFacts.

Require Import String.
Require Import Ascii.
Require Import List.

Require Import StructTact.StructTactics.
Require Import StructTact.StringOrders.

Import ListNotations.

Set Implicit Arguments.

Module Type VWS.
  Declare Module E : DecidableType.

  Definition key := E.t.
  Hint Transparent key.

  Parameter t : Type -> Type.

  Section Types.
    Variable elt:Type.

    Parameter empty : t elt.
    Parameter add : key -> elt -> t elt -> t elt.
    Parameter find : key -> t elt -> option elt.
    Parameter remove : key -> t elt -> t elt.

    Parameter empty_o : forall x, find x empty = None.
    Parameter add_eq_o : forall m x y e, E.eq x y -> find y (add x e m) = Some e.
    Parameter add_neq_o : forall m x y e, ~ E.eq x y -> find y (add x e m) = find y m.
    Parameter remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None.
    Parameter remove_neq_o : forall m x y, ~ E.eq x y -> find y (remove x m) = find y m.
  End Types.
End VWS.

Module WS_to_VWS (Map : WS) <: VWS.
  Module E := Map.E.
  Module F := Facts Map.
  Definition key := E.t.
  Definition t := Map.t.
  Definition empty := Map.empty.
  Definition add := Map.add.
  Definition find := Map.find.
  Definition remove := Map.remove.
  Definition empty_o := F.empty_o.
  Definition add_eq_o := F.add_eq_o.
  Definition add_neq_o := F.add_neq_o.
  Definition remove_eq_o := F.remove_eq_o.
  Definition remove_neq_o := F.remove_neq_o.
End WS_to_VWS.

Module StringMapList := FMapList.Make string_lex_as_OT_compat.
Module LinearTimeStringMap <: VWS := WS_to_VWS StringMapList.

Module Type IndexedType.
  Parameter t: Type.
  Parameter index: t -> positive.
  Parameter index_inj: forall (x y: t), index x = index y -> x = y.
  Parameter eq: forall (x y: t), {x = y} + {x <> y}.
End IndexedType.

Module IT_to_DT (I : IndexedType) <: DecidableType.
  Definition t := I.t.
  Definition eq := @eq t.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Definition eq_dec := I.eq.
End IT_to_DT.

Module IndexedPositiveMap (X : IndexedType) <: VWS.
  Module E := IT_to_DT X.
  Module M := PositiveMap.
  Module F := Facts M.

  Definition key := X.t.

  Definition t := M.t.

  Definition empty := M.empty.

  Definition add (A : Type) (i : key) (v : A) (m : t A) : t A :=
    M.add (X.index i) v m.

  Definition find (A : Type) (i : key) (m : t A) : option A :=
    M.find (X.index i) m.

  Definition remove (A : Type) (i : key) (m : t A) : t A :=
    M.remove (X.index i) m.

  Lemma empty_o : forall A x, find x (empty A) = None.
  Proof.
   intros.
   unfold find.
   apply F.empty_o.
  Qed.

  Lemma add_eq_o : forall A m x y e, E.eq x y -> @find A y (add x e m) = Some e.
  Proof.
    intros.
    unfold find.
    apply F.add_eq_o.
    rewrite H.
    reflexivity.
   Qed.

  Lemma add_neq_o : forall A m x y e, ~ E.eq x y -> find y (add x e m) = @find A y m.
  Proof.
    intros.
    unfold find.
    apply F.add_neq_o.
    intro H_eq.
    contradict H.
    apply X.index_inj in H_eq.
    assumption.
  Qed.

  Lemma remove_eq_o : forall A m x y, E.eq x y -> @find A y (remove x m) = None.
  Proof.
    intros.
    unfold find.
    apply F.remove_eq_o.
    rewrite H.
    reflexivity.
  Qed.

  Lemma remove_neq_o : forall A m x y, ~ E.eq x y -> find y (remove x m) = @find A y m.
  Proof.
    intros.
    unfold find.
    apply F.remove_neq_o.
    intro H_eq.
    contradict H.
    apply X.index_inj in H_eq.
    assumption.
  Qed.
End IndexedPositiveMap.

Module IndexedString <: IndexedType.
  Definition t := string.
  Definition eq := string_dec.

  Fixpoint positive_of_digits (l : list bool) (p : positive) : positive :=
    match l with
    | [] => p
    | b :: l' => if b then xI (positive_of_digits l' p) else xO (positive_of_digits l' p)
    end.

  Definition list_bool_of_ascii (a : ascii) : list bool :=
    let (a0,a1,a2,a3,a4,a5,a6,a7) := a in
    [a0; a1; a2; a3; a4; a5; a6; a7].

  Fixpoint index (s : string) : positive :=
    match s with
    | EmptyString => 1
    | String a s' => positive_of_digits (list_bool_of_ascii a) (index s')
    end.

  Lemma positive_of_digits_inj :
    forall l l' p p',
      List.length l = List.length l' ->
      positive_of_digits l p = positive_of_digits l' p' ->
      l = l' /\ p = p'.
  Proof.
    induction l; destruct l'; intros; try discriminate; auto.
    simpl in *. do 2 break_match; try discriminate;
      solve [ find_inversion; find_apply_hyp_hyp; break_and; subst; auto ].
  Qed.

  Theorem index_inj :
    forall (x y : t),
      index x = index y ->
      x = y.
  Proof.
    induction x; destruct y; intros.
    - reflexivity.
    - simpl in *. unfold list_bool_of_ascii in *.
      break_let; simpl in * ; repeat break_match; congruence.
    - simpl in *. unfold list_bool_of_ascii in *.
      break_let; simpl in *; repeat break_match; congruence.
    - simpl in *. unfold list_bool_of_ascii in *. repeat break_let.
      find_apply_lem_hyp positive_of_digits_inj.
      + subst. break_and. find_inversion. find_apply_hyp_hyp. subst. reflexivity.
      + reflexivity.
  Qed.
End IndexedString.

Module LogTimeStringMap <: VWS := IndexedPositiveMap IndexedString.


(** This is a very simple monadic language that
 ** can be useful for testing.
 **)
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.Map.FMapPositive.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.CTypes.CTypeUnify.
Require Import MirrorCore.CTypes.TSymOneOf.

Set Implicit Arguments.
Set Strict Implicit.

Inductive typ' : nat -> Type :=
| tyNat : typ' 0
| tyBool : typ' 0
| tyMonad : typ' 1.

Definition typ'_dec n (a : typ' n) : forall b : typ' n, {a = b} + {a <> b}.
refine
  match a as a in typ' n return forall b : typ' n, {a = b} + {a <> b} with
  | tyNat => fun b =>
              match b as b in typ' k return (match k return typ' k -> Type with
                                             | 0 => fun t => {tyNat = t} + {tyNat <> t}
                                             | _ => fun _ => unit end b) with
               | tyNat => left eq_refl
               | tyBool => right _
               | tyMonad => tt
               end
  | tyBool => fun b =>
               match b as b in typ' 0 return {_ = b} + {_ <> b} with
               | tyBool => left eq_refl
               | tyNat => right _
               end
  | tyMonad => fun b =>
               match b as b in typ' 1 return {tyMonad = b} + {tyMonad <> b} with
               | tyMonad => left eq_refl
               end
  end; try (intro H; inversion H).
Defined.

Require Import ExtLib.Structures.Monad.
Require Import McExamples.PolyRewrite.Monads.Monad.
Module TheMonad (M : Monad) (F : Frob M).
  Import M.
  Import F.

    Instance TSym_typ' : TSym typ' :=
    { symbolD n s :=
        match s with
        | tyNat => nat
        | tyBool => bool
        | tyMonad => M
        end
    ; symbol_dec := typ'_dec }.

    Definition typ := ctyp typ'.

    Global Instance RType_typ : RType typ := RType_ctyp _ _.
    Global Instance RTypeOk_typ : @RTypeOk _ RType_typ := RTypeOk_ctyp _ _.

    Inductive func :=
    | Lt | Plus | N : nat -> func | Eq : typ -> func
    | Ex : typ -> func | All : typ -> func
    | And | Or | Impl | Bind : typ -> typ -> func | Ret : typ -> func | Frob : func.

    (* slower version if we don't know how many vars we need *)
    Definition func_unify_slow (a b : func) (s : FMapPositive.pmap typ) : option (FMapPositive.pmap typ) :=
      match a , b with
      | Lt , Lt
      | Plus , Plus
      | Frob, Frob
      | N _ , N _
      | And , And
      | Or , Or
      | Impl , Impl => Some s
      | Ret t , Ret t'
      | Eq t , Eq t'
      | Ex t , Ex t'
      | All t , All t' => ctype_unify_slow _ t t' s
      | Bind a b , Bind a' b'  =>
        match ctype_unify_slow _ a a' s with
        | Some s' => ctype_unify_slow _ b b' s
        | None => None
        end
      | _ , _ => None
      end.

    (* n is how many variables we are trying to discover *)
    Definition func_unify (n : nat) (a b : func) (s : FMapPositive.pmap typ) : option (FMapPositive.pmap typ) :=
      match n with
      | S _ =>
        match a , b with
        | Lt , Lt
        | Plus , Plus
        | Frob, Frob
        | N _ , N _
        | And , And
        | Or , Or
        | Impl , Impl => Some s
        | Ret t , Ret t'
        | Eq t , Eq t'
        | Ex t , Ex t'
        | All t , All t' =>
          match ctype_unify _ n t t' s with
          | Some (s', _) => Some s'
          | _ => None
          end
        | Bind a b , Bind a' b'  =>
          match ctype_unify _ n a a' s with
          | Some (s', S k) =>
            match ctype_unify _ (S k) b b' s' with
            | Some (s'', _) => Some s''
            | _ => None
            end
          | Some (s', 0) => Some s'
          | None => None
          end
        | _ , _ => None
        end
      | 0 => Some s
      end.

    Local Notation "! x" := (@tyBase0 _ x) (at level 0).
    Definition typeof_func (f : func) : option typ :=
      Some match f with
           | Lt => tyArr !tyNat (tyArr !tyNat !tyBool)
           | Plus => tyArr !tyNat (tyArr !tyNat !tyNat)
           | N _ => !tyNat
           | Eq t => tyArr t (tyArr t tyProp)
           | And | Or | Impl => tyArr tyProp (tyArr tyProp tyProp)
           | Ex t | All t => tyArr (tyArr t tyProp) tyProp
           | Bind alpha beta => tyArr (tyBase1 tyMonad alpha) (tyArr (tyArr alpha (tyBase1 tyMonad beta)) (tyBase1 tyMonad beta))
           | Ret alpha => tyArr alpha (tyBase1 tyMonad alpha)
           | Frob => tyArr (tyBase0 tyNat) (tyBase1 tyMonad (tyBase0 tyNat))
           end.

    Definition funcD (f : func)
      : match typeof_func f with
        | None => unit
        | Some t => typD t
        end :=
      match f as f return match typeof_func f with
                          | None => unit
                          | Some t => typD t
                          end
      with
      | Lt => NPeano.Nat.ltb
      | Plus => plus
      | N n => n
      | Eq t => @eq _
      | And => and
      | Or => or
      | Impl => fun (P Q : Prop) => P -> Q
      | All t => fun P => forall x : typD t, P x
      | Ex t => fun P => exists x : typD t, P x
      | Bind a b => bind
      | Ret a => ret
      | Frob => frob
      end.

    Let RelDec_eq_typ : RelDec (@eq typ) := RelDec_Rty _.
    Local Existing Instance RelDec_eq_typ.

    Instance RelDec_eq_func : RelDec (@eq func) :=
      { rel_dec := fun (a b : func) =>
                     match a , b with
                     | Plus , Plus => true
                     | Lt , Lt => true
                     | N a , N b => a ?[ eq ] b
                     | Eq a , Eq b => a ?[ eq ] b
                     | And , And
                     | Impl , Impl
                     | Or , Or => true
                     | All a , All b
                     | Ex a , Ex b => a ?[ eq ] b
                     | Bind a b, Bind a' b' => andb (a ?[eq] a') (b ?[eq] b')
                     | Ret a, Ret a' => a ?[eq] a'
                     | Frob, Frob => true
                     | _ , _ => false
                     end
      }.

    Instance RelDecCorrect_eq_func : RelDec_Correct RelDec_eq_func.
    Proof.
      constructor.
      destruct x; destruct y; simpl;
      try solve [ tauto
                | split; congruence
                | rewrite rel_dec_correct; split; congruence
                ].
      split.
      { intros. apply andb_prop in H. destruct H.
        rewrite rel_dec_correct in H. rewrite rel_dec_correct in H0.
        subst; auto. }
      { intros. inversion H. subst.
        do 2 (rewrite rel_dec_eq_true; [|eauto with typeclass_instances|reflexivity]).
        reflexivity. }
    Qed.

    Instance RSym_func : RSym func :=
      { typeof_sym := typeof_func
        ; symD := funcD
        ; sym_eqb := fun a b => Some (a ?[ eq ] b)
      }.

    Instance RSymOk_func : RSymOk RSym_func.
    { constructor.
      intros. simpl. consider (a ?[ eq ] b); auto. }
    Qed.

End TheMonad.


Require Import Io.All.

Inductive t (E : Effect.t) (A : Type) : Type :=
| Ret : A -> t E A
| Call : forall c, (Effect.answer E c -> t E A) -> t E A
| Choose : t E A -> t E A -> t E A.
Arguments Ret {E A} _.
Arguments Call {E A} _ _.
Arguments Choose {E A} _ _.

Module Eq.
  Inductive t {E A} : Choose.t E A -> Choose.t E A -> Prop :=
  | Ret : forall v, t (Ret v) (Ret v)
  | Call : forall c h1 h2,
    (forall a, t (h1 a) (h2 a)) -> t (Call c h1) (Call c h2)
  | Choose : forall x11 x12 x21 x22,
    t x11 x12 -> t x21 x22 -> t (Choose x11 x21) (Choose x12 x22).

  Fixpoint reflexivity {E A} (x : Choose.t E A) : t x x.
    destruct x as [v | c h | x1 x2].
    - apply Ret.
    - apply Call; intro a; apply reflexivity.
    - apply Choose; apply reflexivity.
  Qed.
End Eq.

Fixpoint map {E A B} (x : t E A) (f : A -> B) : t E B :=
  match x with
  | Ret v => Ret (f v)
  | Call c h => Call c (fun a => map (h a) f)
  | Choose x1 x2 => Choose (map x1 f) (map x2 f)
  end.

(*Fixpoint map_compose {E A B C} (x : t E A) (f : A -> B) (g : B -> C)
  {struct x} : map (map x f) g = map x (fun x => g (f x)).
Admitted.
(*  destruct x; simpl.
  - reflexivity.
  - apply f_equal.
    rewrite (map_compose _ _ _ _ (t0 a).
Qed.*)*)

Fixpoint bind {E A B} (x : t E A) (f : A -> t E B) : t E B :=
  match x with
  | Ret v => f v
  | Call c h => Call c (fun a => bind (h a) f)
  | Choose x1 x2 => Choose (bind x1 f) (bind x2 f)
  end.

Fixpoint map_eq_bind_ret {E A B} (x : t E A) (f : A -> B) {struct x}
  : Eq.t (map x f) (bind x (fun v_x => Ret (f v_x))).
  destruct x as [v | c h | x1 x2]; simpl.
  - apply Eq.Ret.
  - apply Eq.Call; intro a; apply map_eq_bind_ret.
  - apply Eq.Choose; apply map_eq_bind_ret.
Qed.

Fixpoint join_left_aux {E A B} (x : t E A) (y : t E B)
  (join_right : forall A, t E A -> t E (A * B)) : t E (A * B) :=
  match x with
  | Ret v => map y (fun y => (v, y))
  | Call c h =>
    Call c (fun a =>
      Choose (join_left_aux (h a) y join_right) (join_right _ (h a)))
  | Choose x1 x2 =>
    Choose (join_left_aux x1 y join_right) (join_left_aux x2 y join_right)
  end.

Fixpoint join_right {E A B} (x : t E A) (y : t E B) : t E (A * B) :=
  match y with
  | Ret v => map x (fun x => (x, v))
  | Call c h =>
    Call c (fun a =>
      Choose (join_left_aux x (h a) (fun _ x => join_right x (h a)))
        (join_right x (h a)))
  | Choose y1 y2 => Choose (join_right x y1) (join_right x y2)
  end.

Definition join_left {E A B} (x : t E A) (y : t E B) : t E (A * B) :=
  join_left_aux x y (fun _ x => join_right x y).

Definition join {E A B} (x : t E A) (y : t E B) : t E (A * B) :=
  Choose (join_left x y) (join_right x y).


Require Import Tactics.
Require Import Syntax.
Require Import Relation.
Require Import Subst.
Require Import SimpSub.

Section object.

Arguments operator {object}.
Arguments term {object}.
Arguments row {object}.

Variable object : Type.

Inductive canon : forall {a}, @operator object a -> Prop :=
| canon_univ           : canon (oper_univ _)
| canon_cty            : canon (oper_cty _)
| canon_con            : canon (oper_con _)
| canon_karrow         : canon (oper_karrow _)
| canon_arrow          : canon (oper_arrow _)
| canon_pi             : canon (oper_pi _)
| canon_clam           : canon (oper_clam _)
| canon_capp           : canon (oper_capp _)
| canon_ctlam          : canon (oper_ctlam _)
| canon_ctapp          : canon (oper_ctapp _)
| canon_lam            : canon (oper_lam _)
| canon_intersect      : canon (oper_intersect _)
| canon_fut            : canon (oper_fut _)
| canon_cnext          : canon (oper_cnext _)
| canon_cprev          : canon (oper_cprev _)
| canon_next           : canon (oper_next _)
| canon_rec            : canon (oper_rec _)
| canon_equal          : canon (oper_equal _)
| canon_triv           : canon (oper_triv _)
| canon_eqtype         : canon (oper_eqtype _)
| canon_subtype        : canon (oper_subtype _)
| canon_kunit          : canon (oper_kuniv _)
| canon_all            : canon (oper_all _)
| canon_alltp          : canon (oper_alltp _)
| canon_exist          : canon (oper_exist _)
| canon_mu             : canon (oper_mu _)
| canon_ispositive     : canon (oper_ispositive _)
| canon_isnegative     : canon (oper_isnegative _)
| canon_voidtp         : canon (oper_voidtp _)
| canon_unittp         : canon (oper_unittp _)
| canon_cunit          : canon (oper_cunit _)
| canon_booltp         : canon (oper_booltp _)
| canon_btrue          : canon (oper_btrue _)
| canon_bfalse         : canon (oper_bfalse _)
| canon_prod           : canon (oper_prod _)
| canon_sigma          : canon (oper_sigma _)
| canon_cpair          : canon (oper_cpair _)
| canon_cpi1           : canon (oper_cpi1 _)
| canon_cpi2           : canon (oper_cpi2 _)
| canon_ppair          : canon (oper_ppair _)
| canon_set            : canon (oper_set _)
| canon_quotient       : canon (oper_quotient _)
| canon_guard          : canon (oper_guard _)
| canon_wt             : canon (oper_wt _)
| canon_ext {x}        : canon (oper_ext _ x)
| canon_extt {x}       : canon (oper_extt _ x)
.

Inductive value : term -> Prop :=
| value_i {a t r} :
    canon t
    -> value (oper a t r)
.

Inductive step : @term object -> term -> Prop :=
| step_app1 {m1 m1' m2} :
    step m1 m1'
    -> step (app m1 m2) (app m1' m2)

| step_app2 {m1 m2} :
    step (app (lam m1) m2) (subst1 m2 m1)

| step_prev1 {m m'} :
    step m m'
    -> step (prev m) (prev m')

| step_prev2 {m} :
    step (prev (next m)) m

| step_bite1 {m1 m1' m2 m3} :
    step m1 m1'
    -> step (bite m1 m2 m3) (bite m1' m2 m3)

| step_bite2 {m1 m2} :
    step (bite btrue m1 m2) m1

| step_bite3 {m1 m2} :
    step (bite bfalse m1 m2) m2

| step_ppi11 {m m'} :
    step m m'
    -> step (ppi1 m) (ppi1 m')

| step_ppi12 {m1 m2} :
    step (ppi1 (ppair m1 m2)) m1

| step_ppi21 {m m'} :
    step m m'
    -> step (ppi2 m) (ppi2 m')

| step_ppi22 {m1 m2} :
    step (ppi2 (ppair m1 m2)) m2
.

Definition eval m v :=
  star step m v
  /\ value v.

Lemma eval_value :
  forall v, value v -> eval v v.
Proof.
intros v H.
split; eauto using star_refl.
Qed.

Lemma determinism_value :
  forall m m',
    value m
    -> step m m'
    -> False.
Proof.
intros m m' Hval Hstep.
invertc Hval; [].
intros a t r Hcanon <-.
revert r Hstep.
cases Hcanon;
intros; invert Hstep; done.
Qed.

Lemma determinism_step :
  forall m1 m2 m2',
    step m1 m2
    -> step m1 m2'
    -> m2 = m2'.
Proof.
intros m1 m2 m2' Hstep Hstep'.
revert m2' Hstep'.
induct Hstep.

(* app1 *)
{
intros m1 m1' m2 Hstep1 IH n Hstep.
invert Hstep.
  {
  intros m1'' Hstep1' <-.
  f_equal; auto.
  }

  {
  intros m3 <-.
  invert Hstep1.
  }
}

(* app2 *)
{
intros m1 m2 m2' Hstep.
invert Hstep.
  {
  intros m3 Hstep' _.
  invert Hstep'.
  }

  {
  intros <-.
  reflexivity.
  }
}

(* prev1 *)
{
intros m1 m1' Hstep1 IH n Hstep.
invert Hstep.
  {
  intros m2 Hstep' <-.
  f_equal; auto.
  }

  {
  intros <-.
  invert Hstep1.
  }
}

(* prev2 *)
{
intros m1 n Hstep.
invert Hstep.
  {
  intros m2 Hstep' <-.
  invert Hstep'.
  }

  {
  intros <-.
  reflexivity.
  }
}

(* ite1 *)
{
intros m1 m1' m2 m3 Hstep1 IH n Hstep.
invertc Hstep.
  {
  intros m1'' Hstep <-.
  f_equal; auto.
  }

  {
  intros <- <-.
  invert Hstep1.
  }

  {
  intros <- <-.
  invert Hstep1.
  }
}

(* ite2 *)
{
intros m1 m2 n Hstep.
invertc Hstep; auto.
intros m1' Hstep <-.
invert Hstep.
}

(* ite3 *)
{
intros m1 m2 n Hstep.
invertc Hstep; auto.
intros m1' Hstep <-.
invert Hstep.
}

(* ppi11 *)
{
intros m m' Hstep1 IH n Hstep.
invertc Hstep.
  {
  intros m'' Hstep <-.
  f_equal; auto.
  }

  {
  intros n' <-.
  invert Hstep1.
  }
}

(* ppi12 *)
{
intros m1 m2 n Hstep.
invertc Hstep; auto.
intros m1' Hstep <-.
invert Hstep.
}

(* ppi21 *)
{
intros m m' Hstep1 IH n Hstep.
invertc Hstep.
  {
  intros m'' Hstep <-.
  f_equal; auto.
  }

  {
  intros n' <-.
  invert Hstep1.
  }
}

(* ppi22 *)
{
intros m1 m2 n Hstep.
invertc Hstep; auto.
intros m1' Hstep <-.
invert Hstep.
}
Qed.

Lemma eval_first_step :
  forall m m' v,
    step m m'
    -> eval m v
    -> eval m' v.
Proof.
intros m m' v Hstep Heval.
destruct Heval as (Hsteps & Hval).
invert Hsteps.
- intros <-.
  exfalso.
  eapply determinism_value; eauto.

- intros m'' Hstep' Hsteps'.
  so (determinism_step _#3 Hstep Hstep').
  subst m''.
  split; auto.
Qed.

Definition normal (m : term) : Prop :=
  forall n, step m n -> False.

Definition normalize m n :=
  star step m n
  /\ normal n.

Lemma var_normal :
  forall i, normal (var i).
Proof.
intros i.
intros m Hstep.
invert Hstep; done.
Qed.

Lemma value_normal :
  forall v, value v -> normal v.
Proof.
intros v Hval.
intros m Hstep.
eapply determinism_value; eauto.
Qed.

Lemma eval_normalize :
  forall m v, eval m v -> normalize m v.
Proof.
intros m v (Hsteps & Hval).
split; auto; [].
apply value_normal; auto.
Qed.

Lemma normalize_normal :
  forall n, normal n -> normalize n n.
Proof.
intros n H.
exact (conj (star_refl _) H).
Qed.

Lemma determinism :
  forall m n n',
    normalize m n
    -> normalize m n'
    -> n = n'.
Proof.
intros m n n' (Hsteps & Hnorm) (Hsteps' & Hnorm').
revert n' Hnorm Hnorm' Hsteps'.
induct Hsteps.

(* refl *)
{
intros m n Hnorm _ Hsteps.
invert Hsteps; auto; [].
intros m' Hstep _.
exfalso.
eapply Hnorm; eauto.
}

(* step *)
{
intros m1 m2 n Hm1m2 Hm2n IH n' Hnorm Hnorm' Hm1n'.
invert Hm1n'.
- intros <-.
  exfalso.
  eapply Hnorm'; eauto.

- intros m2' Hm1m2' Hm2'n'.
  so (determinism_step _#3 Hm1m2 Hm1m2'); subst m2'.
  apply IH; auto; done.
}
Qed.

Lemma determinism_eval :
  forall m v v',
    eval m v
    -> eval m v'
    -> v = v'.
Proof.
intros m v v' H H'.
eapply determinism; eauto using eval_normalize.
Qed.

Lemma determinism_normal :
  forall m n, normal m -> star step m n -> m = n.
Proof.
intros m n Hnorm Hsteps.
invert Hsteps; auto.
intros n' Hstep _.
exfalso.
eapply Hnorm; eauto.
Qed.

Lemma determinism_normal_value :
  forall m n, value m -> star step m n -> m = n.
Proof.
intros m n Hval Hsteps.
eapply determinism_normal; eauto.
apply value_normal; auto.
Qed.

Lemma subst_step :
  forall s m m',
    step m m'
    -> step (subst s m) (subst s m').
Proof.
intros s m m' H.
revert s.
induct H; intros; simpsub; eauto using step;
try (relquest; [eauto using step | simpsub; reflexivity]; done).
Qed.

Lemma subst_steps :
  forall s m m',
    star step m m'
    -> star step (subst s m) (subst s m').
Proof.
intros s m m' H.
induct H; eauto using star_refl, star_step, subst_step.
Qed.

Lemma subst_value :
  forall s v,
    value v
    -> value (subst s v).
Proof.
intros s v H.
invertc H; [].
intros a t r Hcanon <-.
simpsub.
apply value_i; auto.
Qed.

Lemma subst_eval :
  forall s m v,
    eval m v
    -> eval (subst s m) (subst s v).
Proof.
intros s m v (Hsteps & Hval).
split.
- apply subst_steps; auto.

- apply subst_value; auto.
Qed.

Hint Constructors canon : dynamic.

Lemma value_univ : forall {m1}, value (univ m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cty : forall {m1}, value (cty m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_con : forall {m1 m2}, value (con m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_karrow : forall {m1 m2}, value (karrow m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_arrow : forall {m1 m2}, value (arrow m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_pi : forall {m1 m2}, value (pi m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_clam : forall {m1 m2}, value (clam m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_capp : forall {m1 m2}, value (capp m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_ctlam : forall {m1 m2 m3}, value (ctlam m1 m2 m3).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_ctapp : forall {m1 m2}, value (ctapp m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_lam : forall {m1}, value (lam m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_intersect : forall {m1 m2}, value (intersect m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_fut : forall {m1}, value (fut m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cnext : forall {m1}, value (cnext m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cprev : forall {m1}, value (cprev m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_next : forall {m1}, value (next m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_rec : forall {m1}, value (rec m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_equal : forall {m1 m2 m3}, value (equal m1 m2 m3).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_triv : value triv.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_eqtype : forall {m1 m2}, value (eqtype m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_subtype : forall {m1 m2}, value (subtype m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_kuniv : forall {m1}, value (kuniv m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_all : forall {m1 m2 m3}, value (all m1 m2 m3).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_alltp : forall {m1}, value (alltp m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_exist : forall {m1 m2 m3}, value (exist m1 m2 m3).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_mu : forall {m1}, value (mu m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_ispositive : forall {m1}, value (ispositive m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_isnegative : forall {m1}, value (isnegative m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_voidtp : value voidtp.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_unittp : value unittp.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cunit : value cunit.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_booltp : value booltp.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_btrue : value btrue.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_bfalse : value bfalse.
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_prod : forall {m1 m2}, value (prod m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_sigma : forall {m1 m2}, value (sigma m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cpair : forall {m1 m2}, value (cpair m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cpi1 : forall {m1}, value (cpi1 m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_cpi2 : forall {m1}, value (cpi2 m1).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_ppair : forall {m1 m2}, value (ppair m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_set : forall {m1 m2}, value (set m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_quotient : forall {m1 m2}, value (quotient m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_guard : forall {m1 m2}, value (guard m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_wt : forall {m1 m2}, value (wt m1 m2).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_ext : forall {x}, value (ext x).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

Lemma value_extt : forall {x}, value (extt x).
Proof.
intros; apply value_i; eauto with dynamic.
Qed.

End object.

Arguments value {object}.
Arguments step {object}.
Arguments eval {object}.
Arguments normal {object}.
Arguments normalize {object}.

Arguments value_univ {object m1}.
Arguments value_cty {object m1}.
Arguments value_con {object m1 m2}.
Arguments value_karrow {object m1 m2}.
Arguments value_arrow {object m1 m2}.
Arguments value_pi {object m1 m2}.
Arguments value_clam {object m1 m2}.
Arguments value_capp {object m1 m2}.
Arguments value_ctlam {object m1 m2 m3}.
Arguments value_ctapp {object m1 m2}.
Arguments value_lam {object m1}.
Arguments value_intersect {object m1 m2}.
Arguments value_fut {object m1}.
Arguments value_cnext {object m1}.
Arguments value_cprev {object m1}.
Arguments value_next {object m1}.
Arguments value_rec {object m1}.
Arguments value_equal {object m1 m2 m3}.
Arguments value_triv {object}.
Arguments value_eqtype {object m1 m2}.
Arguments value_subtype {object m1 m2}.
Arguments value_kuniv {object m1}.
Arguments value_all {object m1 m2 m3}.
Arguments value_alltp {object m1}.
Arguments value_exist {object m1 m2 m3}.
Arguments value_mu {object m1}.
Arguments value_ispositive {object m1}.
Arguments value_isnegative {object m1}.
Arguments value_voidtp {object}.
Arguments value_unittp {object}.
Arguments value_cunit {object}.
Arguments value_booltp {object}.
Arguments value_btrue {object}.
Arguments value_bfalse {object}.
Arguments value_prod {object m1 m2}.
Arguments value_sigma {object m1 m2}.
Arguments value_cpair {object m1 m2}.
Arguments value_cpi1 {object m1}.
Arguments value_cpi2 {object m1}.
Arguments value_ppair {object m1 m2}.
Arguments value_set {object m1 m2}.
Arguments value_quotient {object m1 m2}.
Arguments value_guard {object m1 m2}.
Arguments value_wt {object m1 m2}.
Arguments value_ext {object x}.
Arguments value_extt {object x}.

Hint Constructors canon : dynamic.

Hint Resolve value_univ value_cty value_con value_karrow value_arrow value_pi value_clam value_capp value_ctlam value_ctapp value_lam value_intersect value_fut value_cnext value_cprev value_next value_rec value_equal value_triv value_eqtype value_subtype value_kuniv value_all value_alltp value_exist value_mu value_ispositive value_isnegative value_voidtp value_unittp value_cunit value_booltp value_btrue value_bfalse value_prod value_sigma value_cpair value_cpi1 value_cpi2 value_ppair value_set value_quotient value_guard value_wt value_ext value_extt : dynamic.

Hint Resolve var_normal value_normal : dynamic.
Hint Resolve eval_normalize eval_value : dynamic.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Named Require Import Core Elab Matches VSubst.
Import Core.Notations.

Require Coq.derive.Derive.

Definition forall_def : lang :=
  {[l/subst
  [:| "G" : #"env",
      "A" : #"ty" (#"tyext" "G")
      -----------------------------------------------
      #"all" "A" : #"ty" "G"
  ];
  [:| "G" : #"env",
       "B" : #"ty" (#"tyext" "G"),
       "e" : #"exp" (#"tyext" "G") "B"
       -----------------------------------------------
       #"Lambda" "e" : #"val" "G" (#"all" "B")
  ];
  [:| "G" : #"env",
       "B" : #"ty" (#"tyext" "G"),
       "e" : #"exp" "G" (#"all" "B"),
       "A" : #"ty" "G"
       -----------------------------------------------
       #"@" "e" "A" : #"exp" "G" (#"ty_subst" (#"tysnoc" #"id" "A") "B")
  ];
  [:= "G" : #"env",
      "B" : #"ty" (#"tyext" "G"),
      "e" : #"exp" (#"tyext" "G") "B",
      "A" : #"ty" "G"
      ----------------------------------------------- ("all-beta")
      #"@" (#"ret" (#"Lambda" "e")) "A"
      = #"exp_subst" (#"tysnoc" #"id" "A") "e"
      : #"exp" "G" (#"ty_subst" (#"tysnoc" #"id" "A") "B")
  ]
  ]}.
(*
  1. add unif vars
  2. generate sort eqns at each con
  3. simplify eqns:
     a. for injective constrs, apply congruence if possible
     b. for x = e/e = x, move to 'evar' map

Ltac algo:
-as existing, but leave all sort eqns unprocessed
-apply refl if concrete
- apply congruence if evar
- once fixed, reduce both sides

 *)

    Ltac split_sub s :=
           lazymatch s with
           | {{e #"cmp" {?G1} {?G2} {?G3} {?s1} {?s2} }} =>
               lazymatch s1 with
               | con "cmp" _ =>
                   lazymatch split_sub s1 with
                   | (?s11, ?G1', ?s12) =>
                       constr:((s11, G1', {{e #"cmp" {G1'} {G2} {G3} {s12} {s2} }}))
                   end
               | _ =>
                   lazymatch s2 with
                   | con "cmp" _ =>
                       lazymatch split_sub s2 with
                       | (?s21, ?G2', ?s22) =>
                           constr:(({{e #"cmp" {G1} {G2'} {G2} {s1} {s21} }}, G2', s22))
                       end
                   | _ => constr:((s1, G2, s2))
                   end
               end
           end.

         (*TODO: is this too optimistic in the non-ground case for s, s'?*)
         Ltac align_subs G_out s G_out' s' e e' :=
           first [ lazymatch split_sub s with
                   | (?s1, ?G12, ?s2) =>
                       lazymatch split_sub s' with
                       | (?s1', ?G12', ?s2') =>
                           unify s1 s1'; align_subs G_out s2 G_out' s2' e e'
                       end
                       || unify s1 s';
                       let x := constr:({{e #"ty_subst" {G12} {G_out} {s2} {e} }}) in
                       unify x e'
                   end
                 | lazymatch split_sub s' with
                   | (?s1', ?G12', ?s2') =>
                       unify s s1';
                       let x := constr:({{e #"ty_subst" {G12'} {G_out'} {s2'} {e'} }}) in
                       unify e x
                   end
                 | unify s s'; unify e e'].
         Ltac elab_ty_subst :=
         match goal with
         | |- eq_term _ _ _ {{e #"ty_subst" {?G1} {?G2} {?s} {?e} }}
                {{e #"ty_subst" {_} {?G2'} {?s'} {?e'} }} =>
             align_subs G2 s G2' s' e e'
         end.

       Create HintDb injective_con discriminated.

       Variant for_db {A} (a : A) : Prop := inst_for_db.

       Hint Resolve (inst_for_db "ext") : injective_con.
       Hint Resolve (inst_for_db "->") : injective_con.
       Hint Resolve (inst_for_db "tyext") : injective_con.
       Hint Resolve (inst_for_db "all") : injective_con.

         (*TODO: better way to avoid polluting namespace?*)
       Ltac is_injective n :=
         let H' := fresh in
         assert (for_db n) as H' by (typeclasses eauto 1 with injective_con);
         [clear H'].

       Ltac shelve_break_elab_term :=
  cbn-[nth_tail];
   lazymatch goal with
   | |- elab_term _ _ ?e ?ee ?t =>
         tryif (is_evar e; is_evar ee) then shelve else eapply elab_term_conv ;
          [ (eapply elab_term_var; [ solve_in ]) || (eapply elab_term_by; [ solve_in | break_down_elab_args ])
          | sort_cong; shelve ]
   end with
        (*elab_args -> list elab_term; should never fail.
        returns goals for explicit terms,
        shelves goals for implicit terms *)
        break_down_elab_args :=
    (eapply elab_args_cons_ex'; [solve_len_eq |repeat shelve_break_elab_term | break_down_elab_args])
    || (eapply elab_args_cons_im; [break_down_elab_args | shelve (*TODO: what to run here?*)])
    || eapply elab_args_nil.

       Ltac try_cong :=
                lazymatch goal with
                | |- eq_term _ _ _ (con ?n ?s1) (con ?n ?s2) =>
                    tryif is_injective n
                    then eapply term_con_congruence;
                         [solve_in | sort_cong | assumption
                         | repeat (eapply eq_args_cons || eapply eq_args_nil)];
                         cbn -[nth_tail]
                    else fail
                end.

       Ltac process_eq := lazymatch goal with
           | |- eq_term _ _ _ ?e1 ?e2 =>
               (*unconstrained evars*)
               tryif (is_evar e1 + is_evar e2) then (eapply eq_term_refl; [shelve])
               else tryif has_evar e1 + has_evar e2 then try_cong else by_reduction
                                   end.

       Ltac is_goal_ground :=
         let g := match goal with |- ?g => g end in
         is_ground g.
       Ltac try_break_elab_term ::=
  cbn-[nth_tail];
   lazymatch goal with
   | |- elab_term _ _ ?e ?ee ?t =>
         tryif (is_evar e; is_evar ee) then shelve else eapply elab_term_conv ;
          [ (eapply elab_term_var; [ solve_in ]) ||
              (eapply elab_term_by; [ solve_in | Matches.break_down_elab_args ])
          | try (sort_cong; repeat process_eq_term) ]
   end;try (is_goal_ground; by_reduction).

Derive forall_lang
       SuchThat (elab_lang_ext (tyext++exp_subst++value_subst) forall_def forall_lang)
       As forall_lang_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve forall_lang_wf : elab_pfs.


Require Import List String FunctionalExtensionality Ensembles
        Common.ilist ADTNotation.StringBound Program
        QueryStructure.Notations
        Heading Tuple.

(* A relation schema is a heading for the tuples of the
   relation and constraints on the members
   (usually functional dependencies). *)

Record Schema :=
  { schemaHeading : Heading;
    schemaConstraints: option (@Tuple schemaHeading
                               -> @Tuple schemaHeading
                               -> Prop)
  }.

Class HeadingHint :=
  { headingHint :> Heading }.

(* A notation for functional dependencies. *)
Definition tupleAgree
           {h : Heading}
           (tup1 tup2 : @Tuple h) attrlist :=
  forall attr,
    List.In attr attrlist ->
    tup1 attr = tup2 attr.

Definition AttributeList {hHint : HeadingHint}
  := list (Attributes headingHint).

Notation "[ attr1 ; .. ; attr2 ] " :=
  (cons (@Build_BoundedIndex _ _ attr1%string _)
        .. (cons
                 (@Build_BoundedIndex _ _ attr2%string _) nil) ..)
  : SchemaConstraints_scope.

Definition FunctionalDependency_P
           (hHint : Heading)
:  list (Attributes hHint)
   -> list (Attributes hHint)
   -> @Tuple hHint
   -> @Tuple hHint
   -> Prop :=
  fun attrlist1 attrlist2 tup1 tup2 =>
    tupleAgree tup1 tup2 attrlist2 ->
    tupleAgree tup1 tup2 attrlist1.

Notation "'attributes' attrlist1 'depend' 'on' attrlist2 " :=
  ((@FunctionalDependency_P headingHint : list BoundedString -> _)
     (attrlist1%SchemaConstraints : list BoundedString)
     (attrlist2%SchemaConstraints : list BoundedString))
  : SchemaConstraints_scope.

(* Notations for Schemas. *)

Notation "'schema' headings 'where' constraints" :=
  {| schemaHeading := headings%Heading;
     schemaConstraints :=
       @Some (@Tuple headings%Heading
              -> @Tuple headings%Heading
              -> Prop) (let hHint := {|headingHint := headings%Heading |} in
                        constraints%SchemaConstraints) |} : Schema_scope.

Notation "'schema' headings" :=
  {| schemaHeading := headings%Heading;
     schemaConstraints := None |} : Schema_scope.