From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.
From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Reals.Reals. Import Rdefinitions. Import RIneq.
From Coq Require Import ZArith.Zdiv.
From Coq Require Import ZArith.Int.
From Coq Require Import ZArith.Znat.
From Coq Require Import Setoids.Setoid.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Classes.Morphisms.

Set Warnings "-deprecate-hint-without-locality,-deprecated".

Import ListNotations.

From ATL Require Import ATL Tactics Div Common.

Generalizable All Variables.

Ltac consistent_shape :=
  repeat
    match goal with
    | |- context[ length ((_ :: _) _[_])] =>erewrite get_length by eassumption
    | |- _ = ?e => is_evar e; reflexivity
    | |- forall _, _ => intros
    | |- consistent ?E _ =>
      match type of E with
      | R => apply all_R_consistent
      end
    | |- consistent (trunc_r _ _) _ =>
      eapply @consistent_trunc_r
    | |- consistent (trunc_l _ _) _ =>
      eapply @consistent_trunc_l
    | |- consistent (pad_r _ _) _ =>
      eapply @consistent_pad_r
    | |- consistent (pad_l _ _) _ =>
      eapply @consistent_pad_l
    | |- consistent (flatten _) _  =>
      eapply @consistent_flatten
    | |- consistent (tile _ _) _ =>
      eapply @consistent_tile
    | |- consistent (transpose _) _ =>
      eapply @consistent_transpose
    | |- consistent (flatten_trunc _ _) _ =>
      eapply @consistent_flatten_trunc
    | |- consistent (_ <++> _) _ =>
      eapply @consistent_concat
    | |- consistent (let_binding _ _) _ =>
      apply @consistent_let
    | |- consistent (|[ _ ]| _) _ =>
      apply @consistent_iverson
    | |- consistent (_ _[_]) _ =>
      eapply @consistent_get
    | |- consistent (GEN [ _ < Z.of_nat _ ] _) _ =>
      apply @consistent_gen
    | |- consistent (GEN [ _ < _ ] _) _ =>
      apply @consistent_gen'
    | |- consistent (GEN [ _ <= _ < _ ] _) _ =>
      apply @consistent_genr
    | |- consistent (SUM [ _ < _ ] _) _ =>
      apply @consistent_sum
    | |- consistent (SUM [ _ <= _ < _ ] _) _ =>
      apply @consistent_sumr
    | |- consistent (_ <+> _) _ => eapply @consistent_bin
    | |- consistent _ _ => eassumption
    end.

(* Like repeat but fails if tactic doesn't succeed at least once *)

Tactic Notation "rep" tactic(t) := t; repeat t.

Ltac ttt e :=
    let t := fresh "t" in
    let t' := fresh "t'" in
    match e with
    | context[ (GEN [ _ < ?V ] _) _[?I] ] =>
      first [
          (assert (0 <= I)%Z as t by (auto + lia); clear t)
        |
        (destruct (0 <=? I)%Z eqn:t;
         [ apply Zle_bool_imp_le in t | apply Z.leb_gt in t])
        ];
      first [
          (assert (I < V)%Z as t' by (auto + lia); clear t')
        |
        (destruct (I <? V)%Z eqn:t';
         [ apply Z.ltb_lt in t' | apply Z.ltb_ge in t'])
        (*let t'_type := type of t' in try ttt t'_type*)
        ]
    | context[ ?V _[?I] ] =>
      first [
          (assert (0 <= I)%Z as t by (auto + lia); clear t)
        |
        (destruct (0 <=? I)%Z eqn:t;
         [ apply Zle_bool_imp_le in t | apply Z.leb_gt in t])
        ];
      first [
          (assert (I < Z.of_nat (length V))%Z as t' by (auto + lia); clear t')
        |
        (destruct (I <? Z.of_nat (length V))%Z eqn:t';
         [ apply Z.ltb_lt in t' | apply Z.ltb_ge in t'])
        ]
    end.

Hint Extern 0 (0 < length (_ :: _)) => simpl; lia : crunch.
Hint Rewrite iverson_bin_distr @collapse_iverson : reds.
Hint Rewrite andb_false_r andb_false_l : reds.

Ltac red_get :=
  repeat
    (match goal with
     | H : (?I < 0)%Z |- _ =>
       repeat rewrite (get_neg_null I) by auto with crunch;
       rep rewrite (@get_gen_neg_null _ _ _ I) by auto with crunch;
       assert (I < 0 /\ True)%Z by auto; clear H
     | H : (Z.of_nat ?V <= ?I)%Z |- _ =>
       repeat rewrite (get_gen_null I) by auto with crunch;
       rep rewrite (get_znlt_null I) by auto with crunch;
       assert (Z.of_nat V <= I /\ True)%Z by auto; clear H
     | H : (0 <= ?I)%Z |- _ =>
       rep rewrite (@get_gen_some _ _ I) by (auto with crunch + (subst; auto with crunch));
       assert (0 <= I /\ True)%Z by auto; clear H
     | H : (?I < ?V)%Z |- _ =>
       rep rewrite (@get_gen_some _ _ I) by auto with crunch;
       assert (I < V /\ True)%Z by auto; clear H
     | H : (0 <= ?I)%Z, H' : (?I < ?V)%Z |- _ =>
       rep rewrite (@get_gen_some _ _ I) by auto with crunch;
       assert (0 <= I /\ True)%Z by auto; clear H;
       assert (I < V /\ True)%Z by auto; clear H'
     end;
     try match goal with |- context [ ((_ :: _) _[0]) ] =>
                         try rewrite get_0_cons
         end;
     try match goal with |- context [ length ((_ :: _) _[_]) ] =>
                         try erewrite get_length by eassumption
         end;
     autorewrite with crunch);
  repeat
    match goal with
    | H : _ /\ True |- _ =>
      destruct H as [ ? triv ]; clear triv
    end.

Ltac reduce_all_get' :=
    match goal with
    | |- GEN [ _ < _ ] _ = _ =>
     try match goal with |- context [ length ((_ :: _) _[_]) ] =>
                         try erewrite get_length by eassumption
         end;
      apply gen_eq_bound; intros;
      reduce_all_get'
    | |- SUM [ _ < _ ] _ = _ =>
     try match goal with |- context [ length ((_ :: _) _[_]) ] =>
                         try erewrite get_length by eassumption
         end;
      apply sum_eq_bound; intros;
      reduce_all_get'
    | |- (|[ _ ]| _) = _ =>
     try match goal with |- context [ length ((_ :: _) _[_]) ] =>
                         try erewrite get_length by eassumption
         end;
      apply iverson_weak;
      reduce_all_get'
    | |- ?l <+> ?r = _ =>
      try match goal with |- context [ length ((_ :: _) _[_]) ] =>
                          try erewrite get_length by eassumption
          end;
      let hypl := fresh "hyp" in
      let lefteq := fresh "lefteq" in
      let tl := type of l in
      let hypr := fresh "hyp" in
      let righteq := fresh "righteq" in
      evar (lefteq : tl);
      evar (righteq : tl);
      assert (l = ?lefteq) as hypl by (reduce_all_get');
      assert (r = ?righteq) as hypr by (reduce_all_get');
      rewrite hypl; subst lefteq;
      rewrite hypr; subst righteq
    | |- ?G =>
      first
        [ ttt G;
          [ red_get; autorewrite with reds crunch; first [ reflexivity | lia ]
          | red_get; autorewrite with reds crunch; first [ reflexivity | lia ]]
        | red_get; autorewrite with reds crunch; subst; reflexivity ]
    end.

Ltac reduce_all_gets :=
  etransitivity; [ rep reduce_all_get' | ]; lazy beta.

(* Rewrite Automation *)

Ltac hook s := idtac.

Ltac b_abstract val :=
  let v := fresh "v" in
  match goal with
  | [ |- context[ (|[ _ ]| ?A) = _ ] ] =>
    set (v:=A); pattern val in v; subst v
  | [ |- context[ ?A = _ ] ] =>
    set (v:=A); pattern val in v; subst v
  end.

Ltac protect :=
  match goal with
  | [ |- ?A ] => first [ has_evar A | eauto with crunch ]
  end.

Ltac lift_evar :=
  let Ht := fresh "Ht" in
  match goal with
  | [ |- _ = ?A ] => has_evar A;
                     remember A eqn:Ht
  end.

Ltac drop_evar :=
  repeat match goal with
  | [ H : ?A = ?B |- _ ] =>
    has_evar B;
    match goal with
    | [ |- _ = A ] => rewrite H
    end
         end.

Inductive DiveAction := RW | RWREV | LET | WRAPID.

Ltac bind pat :=
  lift_evar;
  let pat := open_constr:(pat) in
  let T :=  match type of pat with ?T -> _ => T end in
  let e := fresh "e" in
  evar (e : T);
  let ee := fresh "e" in
  remember ?e as ee;
  let appd := open_constr:(pat ?e) in
  let app := eval lazy beta in appd in
  match goal with |- context[?G] => unify app G; hook string:("success") end;
  let x := fresh "x" in
                               (*
  let idlet := constr:(tlet x := ee in x) in
  let applet' := constr:(pat idlet) in
  let applet := eval lazy beta in applet' in
      replace app with applet; subst ee; [ | try reflexivity ]; drop_evar.
                                *)
  let applet' := constr:(tlet x := ee in pat x) in
  let applet := eval lazy beta in applet' in
      replace app with applet; subst ee; [ | try reflexivity ]; drop_evar.

Ltac propnorm :=
  repeat match goal with
         | |- _ -> _ => intros
         | |- _ /\ _ => split
         | H : _ \/ _ |- _ => destruct H
         | H : _ /\ _ |- _ => destruct H
         end.

Ltac wrap_id rule V K' :=
  try lift_evar;
  let K := open_constr:(K') in
  let V' := open_constr:(V) in
  lazymatch type of K with
  | unit => erewrite <- (rule _ _ V')
  | _ => erewrite <- (rule _ _ V' K)
  end;
  autorewrite with crunch; propnorm; consistent_shape; try reflexivity;
  (solve
   [ try drop_evar; try reflexivity
   | consistent_shape; subst; eauto with crunch typeclass_instances
   | eauto with crunch typeclass_instances
   | autorewrite with crunch; eauto with crunch typeclass_instances ]).

Ltac use_rewrite rule pat n' i' v' :=
  try lift_evar;
  let n := open_constr:(n') in
  let i := open_constr:(i') in
  let v := open_constr:(v') in
  lazymatch type of v with
  | unit =>
    lazymatch type of n with
    | unit =>
      lazymatch type of i with
      | unit =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule; hook string:("b erw")
        | _ => erewrite rule with (body:=opat); hook string:("erw body")
        end
      | _ =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (I:=i); hook string:("b erw")
        | _ => erewrite rule with (body:=opat) (I:=i); hook string:("erw body")
        end
      end
    | _ =>
      lazymatch type of i with
      | unit =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (N:=n); hook string:("b erw")
        | _ => erewrite rule with (body:=opat) (N:=n); hook string:("erw body")
        end
      | _ =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (N:=n) (I:=i); hook string:("b erw")
        | _ => erewrite rule with (body:=opat) (N:=n) (I:=i);
               hook string:("erw body")
        end
      end
    end
  | _ =>
    lazymatch type of n with
    | unit =>
      lazymatch type of i with
      | unit =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (V:=v); hook string:("b erw")
        | _ => erewrite rule with (V:=v) (body:=opat); hook string:("erw body")
        end
      | _ =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (I:=i); hook string:("b erw")
        | _ => erewrite rule with (body:=opat) (V:=v) (I:=i);
               hook string:("erw body")   end
      end
    | _ =>
      lazymatch type of i with
      | unit =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (N:=n); hook string:("b erw")
        | _ => erewrite rule with (V:=v) (body:=opat) (N:=n);
               hook string:("erw body")
        end
      | _ =>
        let opat := open_constr:(pat) in
        lazymatch type of opat with
        | unit => erewrite rule with (V:=v) (N:=n) (I:=i);
                  hook string:("b erw")
        | _ => erewrite rule with (body:=opat) (N:=n) (I:=i) (V:=v);
               hook string:("erw body")
        end
      end
    end
  end;
  autorewrite with crunch; propnorm; consistent_shape;
  solve [ try drop_evar; try reflexivity
        | consistent_shape; subst; eauto with crunch typeclass_instances
        | eauto with crunch typeclass_instances
        | autorewrite with crunch; eauto with crunch typeclass_instances].

Ltac use_rewrite_rev rule pat n' i' :=
  try lift_evar;
  let n := open_constr:(n') in
  let i := open_constr:(i') in
  lazymatch type of n with
  | unit =>
    lazymatch type of i with
    | unit =>
      let opat := open_constr:(pat) in
      lazymatch type of opat with
      | unit => erewrite <- rule; hook string:("b erw")
      | _ => erewrite <- rule with (body:=opat); hook string:("erw body")
      end
    | _ =>
      let opat := open_constr:(pat) in
      lazymatch type of opat with
      | unit => erewrite <- rule with (I:=i); hook string:("b erw")
      | _ => erewrite <- rule with (body:=opat) (I:=i); hook string:("erw body")   end
    end
  | _ =>
     lazymatch type of i with
    | unit =>
      let opat := open_constr:(pat) in
      lazymatch type of opat with
      | unit => erewrite <- rule with (N:=n); hook string:("b erw")
      | _ => erewrite <- rule with (body:=opat) (N:=n); hook string:("erw body")
      end
    | _ =>
      let opat := open_constr:(pat) in
      lazymatch type of opat with
      | unit => erewrite <- rule with (N:=n) (I:=i); hook string:("b erw")
      | _ => erewrite <- rule with (body:=opat) (N:=n) (I:=i);
             hook string:("erw body")
      end
    end
  end;
    autorewrite with crunch; propnorm; consistent_shape;
  solve [ try drop_evar; try reflexivity
        | consistent_shape; subst; eauto with crunch typeclass_instances
        | eauto with crunch typeclass_instances
        | autorewrite with crunch; eauto with crunch typeclass_instances].

Ltac dispatch action rule pat N I V :=
  lazymatch action with
  | RW => use_rewrite rule pat N I V
  | RWREV => use_rewrite_rev rule pat N I
  | LET => bind pat
  | WRAPID => wrap_id rule pat N
  end.

Ltac dive_topdown action rule pat N I V :=
  dispatch action rule pat N I V +
  lazymatch goal with
  | |- let_binding ?x ?f = _ =>
    first [
    let tx := type of x in
    let ex := fresh "ex" in
    let Hx := fresh "Hx" in
    (evar (ex : tx);
    assert (x = ex) as Hx by
          (dive_topdown action rule pat N I V;
           try reflexivity;
           solve [ lazy beta; eta_red; autorewrite with crunch; protect ]);
    subst ex;
    rewrite Hx) |
    eapply let_extensionality;
    [ subst; consistent_shape | intros; dive_topdown action rule pat N I V ]]
  | |- flatten _ = _ =>
    apply flatten_eq;
    dive_topdown action rule pat N I V
  | |- transpose _ = _ =>
    apply transpose_eq;
    dive_topdown action rule pat N I V
  | |- tile _ _ = _ =>
    apply tile_eq;
    dive_topdown action rule pat N I V
  | |- flatten_trunc _ _ = _ =>
    apply flatten_trunc_eq;
    [ dive_topdown action rule pat N I V | ]
  | |- gen _ _ = _ =>
    hook string:("gen");
    let i := fresh "i" in
    apply gen_eq_bound; intros i ? ?;
    dive_topdown action rule pat N I V
  | |- genr _ _ _ = _ =>
    hook string:("genr");
    let i := fresh "i" in
    apply genr_eq_bound; intros;
    dive_topdown action rule pat N I V
  | |- sum _ _ = _ =>
    hook string:("sum");
    let i := fresh "i" in
    apply sum_eq_bound; intros i ? ?;
    dive_topdown action rule pat N I V
  | |- get _ _ = _ =>
    hook string:("get");
    apply get_eq_index;
    dive_topdown action rule pat N I V
  | |- (_ * _)%R = _ =>
    hook string:("mul");
    first
    [
    (hook string:("left of mul");
     apply Rmult_eq_compat_r;
     dive_topdown action rule pat N I V)
    |
    (hook string:("right of mul");
     apply Rmult_eq_compat_l;
     dive_topdown action rule pat N I V) ]
  | |- (_ <+> _) = _ =>
    hook string:("bin");
    first
    [
    (hook string:("left of bin");
     apply bin_eq_l;
     dive_topdown action rule pat N I V)
    |
    (hook string:("right of bin");
     apply bin_eq_r;
     dive_topdown action rule pat N I V) ]
  | |- (_ <++> _) = _ =>
    hook string:("concat");
    first
    [
    (apply concat_eq_l;
     dive_topdown action rule pat N I V)
    |
    (apply concat_eq_r;
     dive_topdown action rule pat N I V) ]
  | |- (|[ _ ]| _) = _ =>
    first
      [
    (hook string:("guard in");
     eapply iverson_in; propnorm; unbool_hyp;
     autorewrite with crunch;
     [ dive_topdown action rule pat N I V |
       subst; consistent_shape | subst; consistent_shape ]) ]
  end.

Ltac dive action rule pat N I V :=
  lazymatch goal with
  | |- let_binding ?x ?f = _ =>
    first [
        eapply let_extensionality;
    [ subst; consistent_shape | intros; dive action rule pat N I V ] |
    let tx := type of x in
    let ex := fresh "ex" in
    let Hx := fresh "Hx" in
    (evar (ex : tx);
    assert (x = ex) as Hx by
          (dive action rule pat N I V;
           try reflexivity;
           solve [ lazy beta; eta_red; autorewrite with crunch; protect ]);
    subst ex;
    rewrite Hx)
    ]
  | |- flatten _ = _ =>
    apply flatten_eq;
    dive action rule pat N I V
  | |- transpose _ = _ =>
    apply transpose_eq;
    dive action rule pat N I V
  | |- tile _ _ = _ =>
    apply tile_eq;
    dive action rule pat N I V
  | |- flatten_trunc _ _ = _ =>
    apply flatten_trunc_eq;
    [ dive action rule pat N I V | ]
  | |- gen _ _ = _ =>
    hook string:("gen");
    let i := fresh "i" in
    apply gen_eq_bound; intros i ? ?;
    dive action rule pat N I V
  | |- genr _ _ _ = _ =>
    hook string:("genr");
    apply genr_eq_bound; intros;
    dive action rule pat N I V
  | |- sum _ _ = _ =>
    hook string:("sum");
    let i := fresh "i" in
    apply sum_eq_bound; intros i ? ?;
    dive action rule pat N I V
  | |- get _ _ = _ =>
    hook string:("get");
    apply get_eq_index;
    dive action rule pat N I V
  | |- (_ * _)%R = _ =>
    hook string:("mul");
    first
    [
    (hook string:("left of mul");
     apply Rmult_eq_compat_r;
     dive action rule pat N I V)
    |
    (hook string:("right of mul");
     apply Rmult_eq_compat_l;
     dive action rule pat N I V) ]
  | |- (_ <+> _) = _ =>
    hook string:("bin");
    first
    [
    (hook string:("left of bin");
     apply bin_eq_l;
     dive action rule pat N I V)
    |
    (hook string:("right of bin");
     apply bin_eq_r;
     dive action rule pat N I V) ]
  | |- (_ <++> _) = _ =>
    hook string:("concat");
    first
    [
    (apply concat_eq_l;
     dive action rule pat N I V)
    |
    (apply concat_eq_r;
     dive action rule pat N I V) ]
  | |- (|[ _ ]| _) = _ =>
    first
      [
    (hook string:("guard in");
     eapply iverson_in; propnorm; unbool_hyp;
     autorewrite with crunch;
     [ dive action rule pat N I V | subst; consistent_shape | subst; consistent_shape ]) ]
  end +
  dispatch action rule pat N I V.

Ltac solve_for_index_rec i' :=
  match goal with
  | |- flatten_trunc _ _ = _ =>
    apply @flatten_trunc_eq
  | [ |- sum _ _ = _ ] => hook string:("sum");
    let i := fresh "i" in
    apply sum_eq_bound; intros i ? ?;
      try solve_for_index_rec i
  | [ |- gen _ _ = _ ] => hook string:("gen");
    let i := fresh "i" in
    apply gen_eq_bound; intros i ? ?;
      try solve_for_index_rec i
  | [ |- (|[ _ ]| _) = _ ] => hook string:("guard");
    try solve_for i';
    apply iverson_weak; try solve_for_index_rec i'
  | [ |- tlet _ := _ in _ = _ ] => hook string:("let");
    try solve_for i';
    try (apply tlet_eq_bound; solve_for_index_rec i');
    try (apply tlet_eq_body; solve_for_index_rec i')
  end.

Ltac solve_for_index := etransitivity;
                        [ solve_for_index_rec 0; reflexivity | ]; lazy beta.

Ltac reduce_guard p :=
  hook p;(
  (let H := fresh "H" in
  assert (H : p = true) by
       (unbool; try split;
        try rewrite Z.add_simpl_r;
         try rewrite Nat2Z.inj_mul; try apply mul_add_lt; try lia; protect);
         rewrite H; clear H; simpl andb)
      +
          (match p with (?p1 && ?p2) =>
                        try reduce_guard p1; try reduce_guard p2;
                        first [ rewrite (bool_imp_elim p1 p2) by
                                  (intros; unbool; lia) |
                try rewrite andb_true_l; try rewrite andb_true_r ] end)).

Ltac simpl_guard_rec :=
  match goal with
  | |- let_binding ?x ?f = _ =>
    let tx := type of x in
    let ex := fresh "ex" in
    let Hx := fresh "Hx" in
    try (evar (ex : tx);
    assert (x = ex) as Hx by
          (simpl_guard_rec;
           subst ex;
           try reflexivity;
           solve [ lazy beta; eta_red; autorewrite with crunch; protect ]);
    subst ex;
    rewrite Hx);
    try (eapply let_extensionality;
    [ consistent_shape |
      intros; simpl_guard_rec ])
  | [ |- flatten_trunc _ _ = _ ] =>
    eapply flatten_trunc_eq; [simpl_guard_rec | ]
  | [ |- tile _ _ = _ ] =>
    eapply tile_eq; simpl_guard_rec
  | [ |- transpose _ = _ ] =>
    apply transpose_eq; simpl_guard_rec
  | [ |- flatten _ = _ ] =>
    apply flatten_eq; simpl_guard_rec
  | [ |- sum _ _ = _ ] => hook string:("sum");
    apply sum_eq_bound; intros;
      simpl_guard_rec
  | [ |- gen _ _ = _ ] => hook string:("gen");
    apply gen_eq_bound; intros;
    simpl_guard_rec
  | [ |- genr _ _ _ = _ ] => hook string:("gen");
    apply genr_eq_bound; intros;
    simpl_guard_rec
  | [ |- (|[ ?p ]| ?e) = _ ] => hook string:("guard");
    try reduce_guard p;
    try (lift_evar;
         repeat rewrite true_iverson;
         repeat rewrite andb_true_r;
         repeat rewrite andb_true_l;
         drop_evar);
    first [ (eapply iverson_in;
    [ intros; unbool_hyp; simpl_guard_rec; try reflexivity |
      intros; unbool_hyp; split; consistent_shape ]) | simpl_guard_rec ]
  | [ |- (?a <++> ?b) = _ ] =>
    let t := type of a in
    let ae := fresh "ae" in
    let be := fresh "be" in
    let Ha := fresh "Ha" in
    let Hb := fresh "Hb" in
    evar (ae : t);
    evar (be : t);
    assert (a = ?ae) as Ha by (simpl_guard_rec; protect; reflexivity);
    try rewrite Ha;
    assert (b = ?be) as Hb by (simpl_guard_rec; protect; reflexivity);
    try rewrite Hb
  | [ |- (?a <+> ?b) = _ ] =>
    let t := type of a in
    let ae := fresh "ae" in
    let be := fresh "be" in
    let Ha := fresh "Ha" in
    let Hb := fresh "Hb" in
    evar (ae : t);
    evar (be : t);
    assert (a = ?ae) as Ha by (simpl_guard_rec; reflexivity);
    try rewrite Ha;
    assert (b = ?be) as Hb by (simpl_guard_rec; reflexivity);
    try rewrite Hb
  | |- _ = _ => reflexivity
  end.

Ltac simpl_guard := etransitivity;
                    [ simpl_guard_rec; try reflexivity; eauto with crunch |];
                    lazy beta.

Ltac rewrite_action action rule pat N I V :=
  etransitivity;
  [ hook string:("etra");
    first
      [ dive action rule pat N I V;
        hook string:("return from rw") |
        hook string:("in failed");
        try dispatch action rule pat N I V;
        hook string:("tried top")];
    try reflexivity;
    solve [
    lazy beta; eta_red; autorewrite with crunch; protect ] | ]; lazy beta.

Ltac rewrite_action_topdown action rule pat N I V :=
  etransitivity;
  [ hook string:("etra");
    first
      [ dive_topdown action rule pat N I V;
        hook string:("return from rw") |
        hook string:("in failed");
        try dispatch action rule pat N I V;
        hook string:("tried top")];
    try reflexivity;
    solve [
    lazy beta; eta_red; autorewrite with crunch; protect ] | ]; lazy beta.

Tactic Notation "lbind" uconstr(pat) :=
  rewrite_action LET tt pat tt tt tt.

Tactic Notation "rw^" open_constr(rule) :=
  rewrite_action_topdown RW rule tt tt tt tt.

Tactic Notation "rw^" open_constr(rule) "for" uconstr(body) :=
  rewrite_action_topdown RW rule body tt tt tt.

Tactic Notation "rw^" open_constr(rule) "at" uconstr(I) :=
  rewrite_action_topdown RW rule tt tt I tt.

Tactic Notation "rw^" open_constr(rule) "up to" uconstr(N) :=
  rewrite_action_topdown RW rule tt N tt tt.

Tactic Notation "rw^" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) :=
  rewrite_action_topdown RW rule body N tt tt.

Tactic Notation "rw^" open_constr(rule)
       "for" uconstr(body) "at" uconstr(I) :=
  rewrite_action_topdown RW rule body tt I tt.

Tactic Notation "rw^" open_constr(rule)
       "up to" constr(N) "at" constr(I) :=
  rewrite_action_topdown RW rule tt N I tt.

Tactic Notation "rw^" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "at" uconstr(I) :=
  rewrite_action_topdown RW rule body N I tt.

Tactic Notation "rw^<-" open_constr(rule) :=
  rewrite_action_topdown RWREV rule tt tt tt tt.

Tactic Notation "rw^<-" open_constr(rule) "for" uconstr(body) :=
  rewrite_action_topdown RWREV rule body tt tt tt.

Tactic Notation "rw^<-" open_constr(rule) "at" uconstr(I) :=
  rewrite_action_topdown RWREV rule tt tt I tt.

Tactic Notation "rw^<-" open_constr(rule) "up to" uconstr(N) :=
  rewrite_action_topdown RWREV rule tt N tt tt.

Tactic Notation "rw^<-" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) :=
  rewrite_action_topdown RWREV rule body N tt tt.

Tactic Notation "rw^<-" open_constr(rule)
       "for" uconstr(body) "at" uconstr(I) :=
  rewrite_action_topdown RWREV rule body tt I tt.

Tactic Notation "rw^<-" open_constr(rule)
       "up to" constr(N) "at" uconstr(I) :=
  rewrite_action_topdown RWREV rule tt N I tt.

Tactic Notation "rw^<-" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "at" uconstr(I) :=
  rewrite_action_topdown RWREV rule body N I tt.

Tactic Notation "rw" open_constr(rule) :=
  rewrite_action RW rule tt tt tt tt.

Tactic Notation "rw" open_constr(rule) "for" uconstr(body) :=
  rewrite_action RW rule body tt tt tt.

Tactic Notation "rw" open_constr(rule) "at" uconstr(I) :=
  rewrite_action RW rule tt tt I tt.

Tactic Notation "rw" open_constr(rule) "up to" uconstr(N) :=
  rewrite_action RW rule tt N tt tt.

Tactic Notation "rw" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) :=
  rewrite_action RW rule body N tt tt.

Tactic Notation "rw" open_constr(rule)
       "for" uconstr(body) "at" uconstr(I) :=
  rewrite_action RW rule body tt I tt.

Tactic Notation "rw" open_constr(rule)
       "up to" uconstr(N) "at" uconstr(I) :=
  rewrite_action RW rule tt N I tt.

Tactic Notation "rw" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "at" uconstr(I) :=
  rewrite_action RW rule body N I tt.

Tactic Notation "rw<-" open_constr(rule) :=
  rewrite_action RWREV rule tt tt tt tt.

Tactic Notation "rw<-" open_constr(rule) "for" uconstr(body) :=
  rewrite_action RWREV rule body tt tt tt.

Tactic Notation "rw<-" open_constr(rule) "at" uconstr(I) :=
  rewrite_action RWREV rule tt tt I tt.

Tactic Notation "rw<-" open_constr(rule) "up to" uconstr(N) :=
  rewrite_action RWREV rule tt N tt tt.

Tactic Notation "rw<-" open_constr(rule)
       "for" uconstr(body) "upto" uconstr(N) :=
  rewrite_action RWREV rule body N tt tt.

Tactic Notation "rw<-" open_constr(rule)
       "for" uconstr(body) "at" uconstr(I) :=
  rewrite_action RWREV rule body tt I tt.

Tactic Notation "rw<-" open_constr(rule)
       "up to" uconstr(N) "at" uconstr(I) :=
  rewrite_action RWREV rule tt N I tt.

Tactic Notation "rw<-" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "at" uconstr(I) :=
  rewrite_action RWREV rule body N I tt.

Tactic Notation "wrapid^" open_constr(rule) "around" uconstr(body) :=
  rewrite_action_topdown WRAPID rule body constr:(tt) constr:(tt) tt.

Tactic Notation "wrapid^" open_constr(rule) "around" uconstr(body) "with"
  constr(K) :=
  rewrite_action_topdown WRAPID rule body K constr:(tt) tt.

Tactic Notation "wrapid" open_constr(rule) "around" uconstr(body) :=
  rewrite_action WRAPID rule body constr:(tt) constr:(tt) tt.

Tactic Notation "wrapid" open_constr(rule) "around" uconstr(body) "with"
  constr(K) :=
  rewrite_action WRAPID rule body K constr:(tt) tt.

Tactic Notation "inline" reference(rule) := unfold rule;
                                            rw^ @consistent_length;
                                            rw^ Z2Nat.id.

Tactic Notation "rw" open_constr(rule) "around" uconstr(V) :=
  rewrite_action RW rule tt tt tt V.

Tactic Notation "rw" open_constr(rule) "for" uconstr(body) "around" uconstr(V)
  :=
  rewrite_action RW rule body tt tt V.

Tactic Notation "rw" open_constr(rule) "at" uconstr(I) "around" uconstr(V)
  :=
  rewrite_action RW rule tt tt I V.

Tactic Notation "rw" open_constr(rule) "up to" uconstr(N) "around" uconstr(V)
  :=
  rewrite_action RW rule tt N tt V.

Tactic Notation "rw" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "around" uconstr(V) :=
  rewrite_action RW rule body N tt V.

Tactic Notation "rw" open_constr(rule)
       "for" uconstr(body) "at" uconstr(I) "around" uconstr(V) :=
  rewrite_action RW rule body tt I V.

Tactic Notation "rw" open_constr(rule)
       "up to" uconstr(N) "at" uconstr(I) "around" uconstr(V) :=
  rewrite_action RW rule tt N I V.

Tactic Notation "rw" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "at" uconstr(I) "around" uconstr(V)
  :=
  rewrite_action RW rule body N I V.

Tactic Notation "rw<-" open_constr(rule) "around" uconstr(V) :=
  rewrite_action RWREV rule tt tt tt V.

Tactic Notation "rw<-" open_constr(rule) "for" uconstr(body) "around" uconstr(V)
  :=
  rewrite_action RWREV rule body tt tt V.

Tactic Notation "rw<-" open_constr(rule) "at" uconstr(I) "around" uconstr(V) :=
  rewrite_action RWREV rule tt tt I V.

Tactic Notation "rw<-" open_constr(rule) "up to" uconstr(N) "around" uconstr(V)
  :=
  rewrite_action RWREV rule tt N tt V.

Tactic Notation "rw<-" open_constr(rule)
       "for" uconstr(body) "upto" uconstr(N) "around" uconstr(V) :=
  rewrite_action RWREV rule body N tt V.

Tactic Notation "rw<-" open_constr(rule)
       "for" uconstr(body) "at" uconstr(I) "around" uconstr(V) :=
  rewrite_action RWREV rule body tt I V.

Tactic Notation "rw<-" open_constr(rule)
       "up to" uconstr(N) "at" uconstr(I) "around" uconstr(V) :=
  rewrite_action RWREV rule tt N I V.

Tactic Notation "rw<-" open_constr(rule)
       "for" uconstr(body) "up to" uconstr(N) "at" uconstr(I) "around" uconstr(V) :=
  rewrite_action RWREV rule body N I V.


Require Import List.

Require Export Syntax.
Require Import Shared.

(*
================
freeX properties
================
*)

Lemma freeLocs_ctx :
  forall e l ctx,
    is_econtext ctx ->
    In l (freeLocs e) ->
    In l (freeLocs (ctx e)).
Proof with eauto using in_or_app.
  introv Hctx H.
  inv Hctx; simpls...
Qed.

Lemma freeIds_ctx :
  forall e id ctx,
    is_econtext ctx ->
    In id (freeIds e) ->
    In id (freeIds (ctx e)).
Proof with eauto using in_or_app.
  introv Hctx H.
  inv Hctx; simpls...
Qed.

Lemma freeBIds_ctx :
  forall e bid ctx,
    is_econtext ctx ->
    In bid (freeBIds e) ->
    In bid (freeBIds (ctx e)).
Proof with eauto using in_or_app.
  introv Hctx H.
  inv Hctx; simpls...
Qed.

Lemma subst_not_in :
  forall e x v,
    ~ In x (freeVars e) ->
    subst x v e = e.
Proof with eauto using remove_not_in_neq.
  introv HnIn.
  expr_cases(induction e) Case;
    simpls; try solve[rewrite IHe; eauto]...
  + Case "EVar".
    cases_if... contradict HnIn...
  + Case "EApp".
    apply not_in_app in HnIn as [HnIn1 HnIn2]. crush.
  + Case "ESend".
    apply not_in_app in HnIn as [HnIn1 HnIn2]. cases_if.
    - crush.
    - rewrite IHe1... rewrite IHe2...
  + Case "ELam".
    cases_if...
    rewrite IHe...
Qed.

Lemma freeLocs_subst :
  forall e v x,
    freeLocs e = nil ->
    freeLocs v = nil ->
    freeLocs (subst x v e) = nil.
Proof with eauto.
  introv eFree vFree.
  expr_cases(induction e) Case; simpls...
  + Case "EVar".
    cases_if...
  + Case "EApp".
    apply app_eq_nil in eFree as (eFree1 & eFree2).
    rewrite IHe1...
  + Case "ESend".
    apply app_eq_nil in eFree as (eFree1 & eFree2).
    rewrite IHe1...
    cases_if...
  + Case "ELam".
    cases_if...
Qed.

Lemma freeLocs_subst_in :
  forall l x v e,
    In l (freeLocs (subst x v e)) ->
    In l (freeLocs v) \/ In l (freeLocs e).
Proof with eauto using in_or_app.
  introv HIn.
  expr_cases(induction e) Case; simpls...
  + Case "EVar".
    cases_if...
  + Case "EApp".
    apply in_app_or in HIn.
    inv HIn; crush.
  + Case "ESend".
    apply in_app_or in HIn.
    inv HIn; crush.
    cases_if; crush.
  + Case "ELam".
    cases_if...
Qed.

Lemma freeIds_subst_in :
  forall l x v e,
    In l (freeIds (subst x v e)) ->
    In l (freeIds v) \/ In l (freeIds e).
Proof with eauto using in_or_app.
  introv HIn.
  expr_cases(induction e) Case; simpls...
  + Case "EVar".
    cases_if...
  + Case "EApp".
    apply in_app_or in HIn.
    inv HIn; crush.
  + Case "ESend".
    apply in_app_or in HIn.
    inv HIn; crush.
    cases_if; crush.
  + Case "ELam".
    cases_if...
Qed.

Lemma freeBIds_subst_in :
  forall l x v e,
    In l (freeBIds (subst x v e)) ->
    In l (freeBIds v) \/ In l (freeBIds e).
Proof with eauto using in_or_app.
  introv HIn.
  expr_cases(induction e) Case; simpls...
  + Case "EVar".
    cases_if...
  + Case "EApp".
    apply in_app_or in HIn.
    inv HIn; crush.
  + Case "ESend".
    apply in_app_or in HIn.
    inv HIn; crush.
    cases_if; crush.
  + Case "ELam".
    cases_if...
Qed.

(*
===============
Heap properties
===============
*)

Lemma heapLookup_nil :
  forall l,
    heapLookup nil l = None.
Proof with auto.
  intros. destruct l...
Qed.

Lemma heapLookup_not_none :
  forall H id,
    heapLookup H id <> None <->
    exists a, heapLookup H id = Some a.
Proof with eauto.
  intros.
  destruct (heapLookup H id) as [[]|]; crush...
Qed.

Lemma heapLookup_lt :
  forall H id,
    id < length H <->
    exists a, heapLookup H id = Some a.
Proof with auto with arith.
  intros H. induction H; intros.
  + rewrite heapLookup_nil; crush.
  + split.
    - destruct id; simpl.
      * repeat eexists...
      * introv Hlt. apply Lt.lt_S_n in Hlt. apply IHlist...
    - destruct id; simpl...
      intros Hex. apply IHlist in Hex...
Qed.

Corollary heapLookup_lt' :
  forall H id a,
    heapLookup H id = Some a ->
    id < length H.
Proof with eauto.
  introv Hlookup. eapply heapLookup_lt...
Qed.

Hint Resolve heapLookup_lt'.

Corollary LH_lt :
  forall id H L,
    LH H id = Some L ->
    id < length H.
Proof with eauto.
  introv HLH.
  unfolds LH.
  remember (heapLookup H id) as lkp.
  destruct lkp...
Qed.

Hint Resolve LH_lt.

Lemma heapLookup_ge :
  forall H id,
    id >= length H <->
    heapLookup H id = None.
Proof with auto using heapLookup_nil with arith.
  split.
  + gen id.
    induction H; destruct id; crush.
  + gen id.
    induction H; introv Hlookup; destruct id; crush.
    apply IHlist in Hlookup...
Qed.

Lemma heapLookup_snoc :
  forall H id obj,
    id < length H ->
    heapLookup H id = heapLookup (snoc H obj) id.
Proof with auto with arith.
  intros H. induction H; introv Hlt.
  + inv Hlt.
  + simpl. destruct id; crush.
Qed.

Lemma heapLookup_in :
  forall H id a,
    heapLookup H id = Some a ->
    List.In a H.
Proof with auto.
  intros H.
  induction H; introv Hlookup.
  + destruct id; inv Hlookup.
  + destruct id as [| id']; simpls.
    - inv Hlookup...
    - right. apply IHlist with id'...
Qed.

Lemma heapExtend_lookup_len :
  forall H a,
    heapLookup (heapExtend H a) (length H) = Some a.
Proof with auto.
  intros H. induction H; crush.
Qed.

Lemma heapExtend_lookup_nlen :
  forall H a id,
    id <> length H ->
    heapLookup (heapExtend H a) id = heapLookup H id.
Proof with auto using heapLookup_nil.
  intros H. unfold heapExtend.
  induction H; introv Hneq; simpls; destruct id; crush...
Qed.

Lemma heapUpdate_nil :
  forall l a,
    heapUpdate nil l a = nil.
Proof.
  auto.
Qed.

Lemma heapUpdate_length :
  forall H id obj,
    length (heapUpdate H id obj) = length H.
Proof with auto.
  intros. gen id.
  induction H; destruct id; crush.
Qed.

Lemma lookup_heapUpdate_eq :
  forall H id obj,
    id < length H ->
    heapLookup (heapUpdate H id obj) id = Some obj.
Proof with auto.
  introv Hlt. unfolds. gen id.
  induction H as [|obj' H']; intros.
  + inv Hlt.
  + destruct id; crush.
Qed.

Lemma lookup_heapUpdate_neq :
  forall H id1 id2 a,
    id1 <> id2 ->
    heapLookup (heapUpdate H id2 a) id1 = heapLookup H id1.
Proof with auto using heapUpdate_nil.
  unfold heapLookup. intros H id1. gen H.
  induction id1 as [|id1']; introv Hneq.
  + destruct H as [|a' H']...
    destruct id2... contradict Hneq...
  + destruct H as [|a' H'];
    destruct id2; crush.
Qed.

Lemma heapUpdate_in :
  forall a a' H id,
    In a (heapUpdate H id a') ->
    In a H \/ a = a'.
Proof with auto using in_cons, in_eq.
  introv HIn. gen id. induction H; intros.
  + inv HIn.
  + simpls. destruct id.
    - inv HIn...
    - inv HIn as [|HIn']...
      apply IHlist in HIn'.
      inv HIn'...
Qed.

(*
================
Tactics
================
*)

Ltac inv_ctx :=
  match goal with
    | H1 : is_econtext ?ctx, H2 : ?ctx _ = _ |- _ =>
        inv H1; inv H2; eauto
  end.

Ltac heap_rewrite :=
  match goal with
    (* Length rewrites *)
    | H : context[length (heapUpdate _ _ _)] |- _ =>
      rewrite heapUpdate_length in H; try omega; eauto
    | _ : _ |- context[length (heapUpdate _ _ _)] =>
      rewrite heapUpdate_length; try omega; eauto
    | H : context[length (heapExtend _ _)] |- _ =>
      rewrite snoc_length in H;
      try rewrite snoc_length; try omega; eauto
    | _ : _ |- context[length (heapExtend _ _)] =>
      rewrite snoc_length; try omega; eauto

    (* Looking up the updated actor in the heap *)
    | _ : _ |- context[heapLookup (heapUpdate _ ?id _) ?id] =>
      rewrite lookup_heapUpdate_eq;
      try rewrite_and_invert; eauto
    | H : context[heapLookup (heapUpdate _ ?id _) ?id] |- _ =>
      rewrite lookup_heapUpdate_eq in H;
      try rewrite_and_invert; eauto

    (* Not looking up the updated actor in the heap *)
    | _ : ?id1 <> ?id2 |- context[heapLookup (heapUpdate _ ?id1 _) ?id2] =>
      rewrite lookup_heapUpdate_neq;
      try rewrite_and_invert; eauto
    | _ : ?id1 <> ?id2 |- context[heapLookup (heapUpdate _ ?id2 _) ?id1] =>
      rewrite lookup_heapUpdate_neq;
      try rewrite_and_invert; eauto
    | _ : ?id1 <> ?id2,
      H : context[heapLookup (heapUpdate _ ?id1 _) ?id2] |- _ =>
      rewrite lookup_heapUpdate_neq in H;
      try rewrite_and_invert; eauto
    | _ : ?id1 <> ?id2,
      H : context[heapLookup (heapUpdate _ ?id2 _) ?id1] |- _ =>
      rewrite lookup_heapUpdate_neq in H;
      try rewrite_and_invert; eauto

    (* Using the known results of a heap lookup *)
    | H1 : heapLookup ?H ?id = _,
      H2 : context[heapLookup ?H ?id] |- _ =>
      rewrite H1 in H2
    | H1 : heapLookup ?H ?id = _ |- context[heapLookup ?H ?id] =>
      rewrite H1

    (* Looking up the newly added actor *)
    | H1 : context[heapLookup (heapExtend ?H _) (length ?H)] |- _ =>
      rewrite heapExtend_lookup_len in H1; eauto
    | _ : _ |- context[heapLookup (heapExtend ?H _) (length ?H)] =>
      rewrite heapExtend_lookup_len; eauto

    (* Not looking up the newly added actor *)
    | _  : ?id <> length ?H,
      H1 : context[heapLookup (heapExtend ?H _) ?id] |- _ =>
      rewrite heapExtend_lookup_nlen in H1; eauto;
      try solve[assert (id < length H); eauto; omega]
    | _  : ?id <> length ?H,
      _ : _ |- context[heapLookup (heapExtend ?H _) ?id] =>
      rewrite heapExtend_lookup_nlen; eauto;
      try solve[assert (id < length H); eauto; omega]
    | _  : ?id < length ?H,
      H1 : context[heapLookup (heapExtend ?H _) ?id] |- _ =>
      rewrite heapExtend_lookup_nlen in H1; eauto; try omega
    | _  : ?id < length ?H,
      _ : _ |- context[heapLookup (heapExtend ?H _) ?id] =>
      rewrite heapExtend_lookup_nlen; eauto; try omega

    (* Absurd lookup *)
    | _ : context[heapLookup ?H (length ?H)] |- _ =>
      assert (length H < length H); eauto; omega

    | _ =>
      fail 1 "Found no heap relations to rewrite"
  end.

Tactic Notation "heap_case_core" :=
  unfolds LH;
  unfolds conv;
  (* Repeat heap_rewrite, but don't branch *)
  repeat let n := numgoals in
         repeat heap_rewrite;
         let n' := numgoals in
         guard n' = n;
         repeat inv_eq.

Tactic Notation "heap_case" ident(id1) ident(id2) :=
  destruct (id_eq_dec id1 id2); subst;
  heap_case_core.

Tactic Notation "heap_case'" ident(id1) constr(len) :=
  destruct (id_eq_dec id1 len); subst;
  heap_case_core.

Tactic Notation "hauto'" int(n) :=
  do n
  (match goal with
    (* heapUpdate in conclusion *)
    | _ : _ |- context[heapLookup (heapUpdate _ ?id1 _) ?id2] =>
      heap_case id1 id2
    | _ : _ |- context[LH (heapUpdate _ ?id1 _) ?id2] =>
      heap_case id1 id2
    | _ : _ |- context[conv (heapUpdate _ ?id1 _) ?id2] =>
      heap_case id1 id2

    (* heapUpdate in premise *)
    | _ : context[heapLookup (heapUpdate _ ?id1 _) ?id2] |- _ =>
      heap_case id1 id2
    | _ : context[LH (heapUpdate _ ?id1 _) ?id2] |- _ =>
      heap_case id1 id2
    | _ : context[conv (heapUpdate _ ?id1 _) ?id2] |- _ =>
      heap_case id1 id2

    (* heapExtend in conclusion *)
    | _ : _ |- context[heapLookup (heapExtend ?H _) ?id] =>
      heap_case' id (length H)
    | _ : _ |- context[LH (heapExtend ?H _) ?id] =>
      heap_case' id (length H)
    | _ : _ |- context[conv (heapExtend ?H _) ?id] =>
      heap_case' id (length H)

    (* heapExtend in premise *)
    | H1 : context[heapLookup (heapExtend ?H _) ?id] |- _ =>
      heap_case' id (length H)
    | H1 : context[LH (heapExtend ?H _) ?id] |- _ =>
      heap_case' id (length H)
    | H1 : context[conv (heapExtend ?H _) ?id] |- _ =>
      heap_case' id (length H)

    (* try to rewrite *)
    | _ => heap_case_core
  end; eauto).

Tactic Notation "hauto" := hauto' 5.

Ltac destruct_actor a :=
  destruct a as [[[[?l ?L] ?C] ?Q] ?e].

Tactic Notation "find_actor" ident(id) :=
  match goal with
    | Hlt : id < length ?H |- _ =>
      let a := fresh "a" in
      eapply heapLookup_lt in Hlt as [a ?Hlookup]; destruct_actor a
    | _ => fail "No such actor"
  end.


Set Warnings "-notation-overridden".

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.

Require Import Embed.Theory.Functor.Refined.Iso.

Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.
Require Import Embed.Theory.Btree.Leaves.

Require Import Embed.Theory.Btree.Canonical.
Require Import Embed.Theory.Btree.Canonical.Refined.
Require Import Embed.Theory.Btree.Canonical.Refined.Iso.

Require Import Embed.Theory.Utils.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Lemma iso_refined_btree_eq_num_leaves (x y : @btree 1) :
  iso_refined x y -> num_leaves x = num_leaves y.
intro.

pose (H := iso_refined_canonical_btree_eq _ _ (compose_iso_refined
  (compose_iso_refined
    (iso_refined_canonical_btree y)
    X
  )
  (@Equivalence_Symmetric _ iso_refined _ _ _ (iso_refined_canonical_btree x))
)).
repeat (rewrite <- PeanoNat.Nat.sub_1_r in H).
refine (refine_nat_pred_positive _ _ H).

exact (num_leaves_positive _).

exact (num_leaves_positive _).
Qed.

(* Much easier than the other direction: we just use iso_refined_canonical_btree *)
Lemma eq_num_leaves_iso_refined_btree (x y : @btree 1) :
  num_leaves x = num_leaves y -> iso_refined x y.
proper.
pose (Hx := @iso_refined_canonical_btree x A).
pose (Hy := @iso_refined_canonical_btree y A).
rewrite <- H in Hy.
exact (iso_compose (iso_sym Hy) Hx).
Qed.

Theorem iso_refined_num_leaves (x y : @btree 1) :
  iso_refined x y ↔ num_leaves x = num_leaves y.
split.

exact (iso_refined_btree_eq_num_leaves x y).

exact (eq_num_leaves_iso_refined_btree x y).
Defined.

Corollary not_iso_refined_bcons_bnil (x y : @btree 1)
  (pf : @iso_refined btree_Functor (bcons x y) (bnil tt)) : False.
pose (H := iso_refined_btree_eq_num_leaves (bcons x y) (bnil tt) pf).
simpl in H.
destruct (Plus.plus_is_one _ _ H).

destruct a.
destruct (num_leaves_positive x H0).

destruct a.
destruct (num_leaves_positive y H1).
Qed.


(*
 * Copyright (C) BedRock Systems Inc. 2020-2022
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

Require Import bedrock.lang.bi.prelude.
Require Import bedrock.lang.bi.observe.
Require Import iris.proofmode.proofmode.

#[local] Set Primitive Projections.

(** Spec building block: knowledge *)

Class Knowledge {PROP : bi} (P : PROP) : Prop := {
  knowledge_persistent :> Persistent P;
  knowledge_affine     :> Affine P;
}.
Arguments Knowledge {_} _%I.

Ltac solve_knowledge := solve [intros; split; apply _].

Section knowledge.
  Context {PROP : bi}.

  #[global] Instance knowledge_proper : Proper (equiv ==> iff) (@Knowledge PROP).
  Proof.
    intros P1 P2 HP. split; intros []. by split; rewrite -HP. by split; rewrite HP.
  Qed.

  #[global] Instance emp_knowledge : @Knowledge PROP emp.
  Proof. solve_knowledge. Qed.
End knowledge.

(** [KnowledgeN] states that predicate [P] taking [N] arguments is [Knowledge] *)
Notation Knowledge1 P := (∀ a, Knowledge (P a)).
Notation Knowledge2 P := (∀ a, Knowledge1 (P a)).
Notation Knowledge3 P := (∀ a, Knowledge2 (P a)).
Notation Knowledge4 P := (∀ a, Knowledge3 (P a)).
Notation Knowledge5 P := (∀ a, Knowledge4 (P a)).

(**
Persistent ghost state with agreement on one higher-order argument.
Compared to [Knowledge], we

- add [Contractive] and [LaterAgreeF1] to enable agreement lemmas.
*)
Class KnowLaterAgree1 {A : ofe} {PROP} `{!BiInternalEq PROP}
    (R : A -> PROP) : Prop := {
  know_later_agree_1_persistent :> Persistent1 R;
  know_later_agree_1_affine :> Affine1 R;
  know_later_agree_1_contractive :> Contractive R;
  know_later_agree_1_agree :> LaterAgree1 R;
}.
#[global] Hint Mode KnowLaterAgree1 - - - ! : typeclass_instances.

Section know_later_agree.
  Context {A : ofe} `{!BiInternalEq PROP}.
  Context (R : A -> PROP).
  Context `{!knowledge.KnowLaterAgree1 R}.
  #[local] Set Default Proof Using "Type*".
  #[local] Notation PROPO := (bi_ofeO PROP).

  #[global] Instance know_later_agree_1_ne : NonExpansive R.
  Proof. exact: contractive_ne. Qed.
  #[global] Instance know_later_agree_1_proper : Proper (equiv ==> equiv) R.
  Proof. exact: ne_proper. Qed.

  #[global] Instance know_later_agree_1_equivI a1 a2 :
    Observe2 (R a1 ≡@{PROPO} R a2) (R a1) (R a2).
  Proof.
    iIntros "R1 R2". iDestruct (observe_2 (▷ (_ ≡ _)) with "R1 R2") as "#Eq".
    rewrite (f_equivI_contractive R). auto.
  Qed.
End know_later_agree.


Require Import List.
Require Import Arith.

Require Export C.

(** * CU for "Clean Up" *)

Definition cleanup := nat.

Inductive expr : Set :=
| App : var -> vars -> cleanup -> expr
| Constr : constructor -> vars -> cleanup -> expr
| Letrec : list (gen_lambda_form (Expr := expr)) -> expr -> expr
| Case : expr -> list (gen_alt (Expr := expr)) -> expr.

Definition lambda_form := gen_lambda_form (Expr := expr).

Definition alt := gen_alt (Expr := expr).

Definition alts := list alt.

Theorem expr_ind2 :
forall (P : expr -> Prop)
  (APP    : forall x xs cu, P (App x xs cu))
  (CONSTR : forall C xs cu, P (Constr C xs cu))
  (LETREC : forall e lfs
    (EXPR : P e)
    (LF   : forall lf
      (IN : In lf lfs),
      match lf with Lf _ _ _ f => P f end),
    P (Letrec lfs e))
  (CASE   : forall e als
    (EXPR : P e)
    (ALS  : forall al
      (IN : In al als),
      match al with Alt _ f => P f end),
    P (Case e als))
  (e : expr), P e.
Proof.
intros.
revert e.
refine (fix rec (e : expr) : P e := _).
destruct e.
(* App *)
apply APP.
(* Constr *)
apply CONSTR.
(* Letrec *)
apply LETREC.
apply rec.
induction l.
intros; inversion IN.
intros; simpl in IN.
inversion IN.
rewrite <- H; destruct a; apply rec.
apply IHl.
apply H.
(* Case *)
apply CASE.
apply rec.
induction l.
intros; inversion IN.
intros; simpl in IN.
inversion IN.
rewrite <- H; destruct a; apply rec.
apply IHl.
apply H.
Qed.

Hint Resolve eq_nat_dec vars_eq_dec var_eq_dec list_eq_dec.

Lemma length_not_eq :
forall (T : Type) (xs ys : list T)
  (LEN : length xs <> length ys),
  xs <> ys.
Proof with isa.
induction xs; induction ys...
intro; discriminate.
intro; discriminate.
intro.
inversion H; subst.
tauto.
Qed.

Ltac eq_r X := destruct X; [ | let Y := fresh "Y" in
  (right; intro Y; inversion Y; contradiction) ].

Definition expr_eq_dec  : forall a b : expr, {a = b} + {a <> b}.
Proof.
refine (fix rec (a b : expr) {struct a} : {a = b} + {a <> b} := _).
destruct a; destruct b; try (right; intro; discriminate).
(* App *)
eq_r (var_eq_dec v v1).
eq_r (vars_eq_dec v0 v2).
eq_r (eq_nat_dec c c0).
subst; left; reflexivity.
(* Constr *)
eq_r (eq_nat_dec c c1).
eq_r (vars_eq_dec v v0).
eq_r (eq_nat_dec c0 c2).
subst; left; reflexivity.
(* Letrec *)
destruct (eq_nat_dec (length l) (length l0)) as [ LENEQ | NEQ ]; [ |
  apply length_not_eq in NEQ; right; intro H; inversion H; contradiction ].
revert l0 LENEQ.
induction l; intros.
  (* nil *)
induction l0; try discriminate.
assert (EQ := rec a b).
destruct EQ;
[ left; f_equal; assumption
| right; intro H; inversion H; contradiction ].
  (* cons *)
destruct l0; try discriminate.
inversion LENEQ as [ LENEQ2 ].
destruct (IHl l0 LENEQ2) as [ TAILEQ | TAILNEQ ]; [ |
  right; intro H; inversion H; subst; intuition ].
destruct a0.
destruct g.
assert (HEADEQ := rec e e0).
destruct HEADEQ as [ HEADEQ | HEADNEQ ].
eq_r (upd_flag_eq_dec u u0).
eq_r (vars_eq_dec v v0).
eq_r (eq_nat_dec b0 b1).
subst.
left; inversion TAILEQ; subst; f_equal; reflexivity.
right; intro H; inversion H; contradiction.
(* Case *)
destruct (eq_nat_dec (length l) (length l0)) as [ LENEQ | NEQ ]; [ |
  apply length_not_eq in NEQ; right; intro H; inversion H; contradiction ].
revert l0 LENEQ.
induction l; intros.
  (* nil *)
induction l0; try discriminate.
assert (EQ := rec a b).
destruct EQ;
[ left; f_equal; assumption
| right; intro H; inversion H; contradiction ].
  (* cons *)
destruct l0; try discriminate.
inversion LENEQ as [ LENEQ2 ].
destruct (IHl l0 LENEQ2) as [ TAILEQ | TAILNEQ ]; [ |
  right; intro H; inversion H; subst; intuition ].
destruct a0.
destruct g.
assert (HEADEQ := rec e e0).
destruct HEADEQ as [ HEADEQ | HEADNEQ ].
eq_r (eq_nat_dec b0 b1).
subst.
left; inversion TAILEQ; subst; f_equal; reflexivity.
right; intro H; inversion H; contradiction.
Qed.

Definition alt_eq_dec  : forall a b : alt, {a = b} + {a <> b}.
Proof.
decide equality.
apply expr_eq_dec.
Qed.

Definition lf_eq_dec : forall a b : lambda_form, {a = b} + {a <> b}.
Proof.
decide equality.
apply expr_eq_dec.
apply upd_flag_eq_dec.
Qed.

Theorem expr_rec2 :
forall (P : expr -> Set)
  (APP    : forall x xs cu, P (App x xs cu))
  (CONSTR : forall C xs cu, P (Constr C xs cu))
  (LETREC : forall e lfs
    (EXPR : P e)
    (LF   : forall lf
      (IN : In lf lfs),
      match lf with Lf _ _ _ f => P f end),
    P (Letrec lfs e))
  (CASE   : forall e als
    (EXPR : P e)
    (ALS  : forall al
      (IN : In al als),
      match al with Alt _ f => P f end),
    P (Case e als))
  (e : expr), P e.
Proof.
intros.
revert e.
refine (fix rec (e : expr) : P e := _).
destruct e.
(* App *)
apply APP.
(* Constr *)
apply CONSTR.
(* Letrec *)
apply LETREC.
apply rec.
induction l.
intros; inversion IN.
intros; simpl in IN.
destruct (In_dec lf_eq_dec lf l) as [ I | NI ].
apply IHl; apply I.
assert (H : a = lf).
  inversion IN.
  apply H.
  contradiction.
rewrite <- H; destruct a; apply rec.
(* Case *)
apply CASE.
apply rec.
induction l.
intros; inversion IN.
intros; simpl in IN.
destruct (In_dec alt_eq_dec al l) as [ I | NI ].
apply IHl; apply I.
assert (H : a = al).
  inversion IN.
  apply H.
  contradiction.
rewrite <- H; destruct a; apply rec.
Qed.

(* Configurations *)

Definition closure := gen_closure (Expr := expr).

Definition heap := gen_heap (Clo := closure).

Inductive config : Set :=
| Config : heap -> expr -> env -> argstack -> addresses -> config
| Enter : heap -> address -> argstack -> env -> config.

Notation " << a , b , c , d , e >> " := (Config a b c d e) (at level 70).
Notation " << a , b , c , d >> " := (Enter a b c d) (at level 70).

Definition env_from_config (c : config) : env :=
match c with
| Config _ _ e _ _ => e
| Enter _ _ _ e => e
end.

Definition x := << fun x => None, Constr 5 nil (0), nil, nil, nil >>.

Definition make_cons (C : constructor) (addrs : addresses) : closure :=
(Lf_n nil 0 (Constr C (map C_ind (from 0 (length addrs))) 0), addrs).

Definition make_pap (q : address) (addrs : addresses) : closure :=
(Lf_n nil 0 (App (C_ind 0) (map C_ind (from 1 (length addrs))) 0), q::addrs).

Lemma map_env_make :
forall (addrs : addresses) xs,
map_env nil (xs++addrs) (map C_ind (from (length xs) (length addrs))) = Some addrs.
Proof with isa; try discriminate.
intros.
remember (map C_ind (from (length xs) (length addrs))) as ys.
generalize dependent xs; generalize dependent addrs; induction ys...
destruct addrs...
destruct addrs...
remember (map_env nil (xs ++ a0 :: addrs) ys) as MEM; destruct MEM...
inversion Heqys; subst; clear Heqys...
rewrite C.nth_app; repeat f_equal.
assert (hh : map_env nil ((xs ++ a0 :: nil) ++ addrs)
  (map C_ind (from (S (length xs)) (length addrs))) = Some addrs).
apply IHys...
rewrite app_length...
rewrite <- plus_n_Sm; rewrite plus_0_r...
cutrewrite ((xs ++ a0 :: nil) ++ addrs = xs ++ a0 :: addrs) in hh.
rewrite hh in HeqMEM; inversion HeqMEM...
rewrite app_ass...
inversion Heqys; subst; clear Heqys...
assert (hh : map_env nil ((xs ++ a0 :: nil) ++ addrs)
  (map C_ind (from (S (length xs)) (length addrs))) = Some addrs).
apply IHys...
rewrite app_length...
rewrite <- plus_n_Sm; rewrite plus_0_r...
rewrite app_ass in hh...
rewrite hh in HeqMEM; discriminate.
Qed.

Lemma map_env_make_cons :
forall (addrs : addresses),
map_env nil addrs (map C_ind (from 0 (length addrs))) = Some addrs.
Proof with isa.
intro.
apply (map_env_make addrs nil)...
Qed.

Lemma map_env_make_pap :
forall (p : address) (args : addresses),
map_env nil (p :: args) (map C_ind (from 1 (length args))) = Some args.
Proof with isa.
intros.
apply (map_env_make args (p::nil))...
Qed.

Inductive value : Set :=
| Val_con : heap -> constructor -> addresses -> value
| Val_pap : heap -> address -> addresses -> value.

(* Semantics *)

Reserved Notation " a ↓ b " (at level 70, no associativity).

Inductive Sem : config -> (value * env) -> Prop :=

| Cons : forall Gamma C xs sigma clo addrs cleanup
  (MAPENV : map_env sigma clo xs = Some addrs),
  << Gamma, Constr C xs (cleanup), sigma, nil, clo >> ↓ (Val_con Gamma C addrs, (skipn cleanup sigma))

| Accum : forall Gamma x xs sigma args clo p new_args Value cleanup
  (MAPENV  : map_env sigma clo xs = Some new_args)
  (LOOKUP  : look_up sigma clo x = Some p)
  (PREMISE : << Gamma, p, new_args++args, skipn cleanup sigma >> ↓ Value),
  << Gamma, App x xs (cleanup), sigma, args, clo >> ↓ Value

| App1 : forall Gamma p args clovars bind e some_clo sigma
  (ONHEAP : Gamma p = Some (Lf_n clovars bind e, some_clo))
  (LENGTH : bind > length args),
  << Gamma, p, args, sigma >> ↓ (Val_pap Gamma p args, sigma)

| App2 : forall Gamma p args Value e bind clo clovars sigma
  (ONHEAP  : Gamma p = Some (Lf_n clovars bind e, clo))
  (LENGTH  : bind <= length args)
  (PREMISE : << Gamma, e, firstn bind args ++ sigma, skipn bind args, clo >> ↓ Value),
  << Gamma, p, args, sigma >> ↓ Value

| App3 : forall Gamma p C addrs clovars Delta e clo sigma theta
  (ONHEAP  : Gamma p = Some (Lf_u clovars 0 e, clo))
  (PREMISE : << (clog Gamma p), e, sigma, nil, clo >> ↓ (Val_con Delta C addrs, theta)),
  << Gamma, p, nil, sigma >> ↓ (Val_con (set Delta p (make_cons C addrs)) C addrs, theta)

| App4 : forall Gamma p args Value q addrs e clovars clo_e Delta sigma theta
  (ONHEAP1 : Gamma p = Some (Lf_u clovars 0 e, clo_e))
  (LEFT    : << (clog Gamma p), e, sigma, nil, clo_e >> ↓ (Val_pap Delta q addrs, theta))
  (RIGHT   : << set Delta p (make_pap q addrs), q, addrs++args, theta >> ↓ Value),
  << Gamma, p, args, sigma >> ↓ Value

| Let : forall Gamma e lfs sigma current_clo closures Value addrs args
  (LENGTH  : length addrs = length lfs)
  (FRESH   : forall p : address, In p addrs -> Gamma p = None)
  (CLOS    : make_closures (addrs++sigma) current_clo lfs = Some closures)
  (PREMISE : << alloc Gamma addrs closures, e, addrs++sigma, args, current_clo >> ↓ Value),
  << Gamma, Letrec lfs e, sigma, args, current_clo >> ↓ Value

| Case_of : forall Gamma e als sigma clo Value bind Delta e0 C addrs args theta
  (SELECT : nth C als = Some (Alt bind e0))
  (* NO LENGTH !!! *)
  (LEFT   : << Gamma, e, sigma, nil, clo >> ↓ (Val_con Delta C addrs, theta))
  (RIGHT  : << Delta, e0, addrs++theta, args, clo >> ↓ Value),
  << Gamma, Case e als, sigma, args, clo >> ↓ Value

where " a ↓ b " := (Sem a b).


(** This file defines _maps_ of split type-categories. *)

Require Import UniMath.MoreFoundations.All.

Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.

Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.TypeCat.General.

Local Open Scope cat.

(** We base our models on _split type-categories_, i.e. [split_typecat] as defined in [TypeTheory.CwF_TypeCat.TypeCat] following Pitts and van den Berg–Garner.
(Roughly the same as what Hofmann calls CwA’s.) *)

Section morphisms.

(* The definition of a morphism between split typecategories
consists of (modulo ^op):

- a functor F : C -> D
- a natural transformation FTy : Ty C -> Ty D
- a family of isomorphisms ϕ : F(Γ.A) ≃ F(Γ).F_Ty(A)

satisfying triangle:

           ϕ
F (Γ · A) --> F Γ · FTy A
      \         /
       \       /
    F p \     / p
         \   /
          \ /
           V
          F Γ

and a pentagon stating that the following morphisms are equal:

                  F q                        ϕ
F (Γ' ⋆ A⦃f⦄) ----------> F (Γ ⋆ A) ---------------> F Γ ⋆ FTy A

F (Γ' ⋆ A⦃f⦄) ------> F Γ' ⋆ (F A)⦃f⦄ -----> F Γ' ⋆ F A⦃f⦄ ------> F Γ ⋆ FTy A
                 ϕ                       =                     q

*)
Definition typecat_mor_data (C D : split_typecat) : UU
  := ∑ (F : functor C D)
       (FTy : PreShv C ⟦ty C, functor_opp F ∙ ty D⟧),
       (∏ (Γ : C) (A : C Γ), iso (F (Γ ⋆ A)) (F Γ ⋆ pr1 FTy _ A)).

Definition typecat_mor_functor {C D} {F : typecat_mor_data C D}
  : functor C D := pr1 F.
Coercion typecat_mor_functor : typecat_mor_data >-> functor.

Definition typecat_mor_Ty {C D}  (F : typecat_mor_data C D)
  : nat_trans (ty C : functor _ _) (functor_opp F ∙ ty D)
:= pr12 F.

Definition typecat_mor_iso {C D} (F : typecat_mor_data C D)
    {Γ} (A : C Γ)
  : iso (F (Γ ⋆ A)) (F Γ ⋆ typecat_mor_Ty F Γ A)
:= pr22 F Γ A.

Definition typecat_mor_axioms
    {C D : split_typecat} (F : typecat_mor_data C D) : UU
  := (∏ Γ (A : C Γ),
        # F (dpr_typecat A)
        = typecat_mor_iso F A · dpr_typecat (typecat_mor_Ty F _ A))
   × (∏ Γ Γ' (A : C Γ) (f : Γ' --> Γ),
        # F (q_typecat A f) · typecat_mor_iso F A
        = typecat_mor_iso F _
          · comp_ext_compare (nat_trans_ax_pshf (typecat_mor_Ty F) _ _)
          · q_typecat (typecat_mor_Ty F _ A) (# F f)).

Definition typecat_mor (C D : split_typecat) : UU
  := ∑ (F : typecat_mor_data C D), typecat_mor_axioms F.

Definition make_typecat_mor
  {C D : split_typecat}
  (F : functor C D)
  (FTy : PreShv C ⟦ty C, functor_opp F ∙ ty D⟧)
  (ϕ : ∏ (Γ : C) (A : C Γ), iso (F (Γ ⋆ A)) (F Γ ⋆ pr1 FTy _ A))
  (H1 : ∏ Γ (A : C Γ), # F (dpr_typecat A) = ϕ _ A · dpr_typecat (pr1 FTy _ A))
  (H2 : ∏ Γ Γ' (A : C Γ) (σ : Γ' --> Γ),
        # F (q_typecat A σ) · ϕ Γ A =
        ϕ Γ' _ · comp_ext_compare (nat_trans_ax_pshf FTy _ _) ·
          q_typecat (pr1 FTy _ A) (# F σ))
  : typecat_mor C D.
Proof.
  exact ((F,,(FTy,,ϕ)),,(H1,,H2)).
Defined.

Coercion typecat_mor_data_of_typecat_mor {C D} (F : typecat_mor C D)
  : typecat_mor_data C D
:= pr1 F.

Definition typecat_mor_triangle {C D} (F : typecat_mor C D)
    {Γ} (A : C Γ)
  : # F (dpr_typecat A)
    = typecat_mor_iso F A · dpr_typecat (typecat_mor_Ty F _ A)
:= pr1 (pr2 F) Γ A.

Definition typecat_mor_pentagon {C D} (F : typecat_mor C D)
    {Γ Γ'} (A : C Γ) (σ : Γ' --> Γ)
  : # F (q_typecat A σ)
    · typecat_mor_iso F A
  = typecat_mor_iso F _
    · comp_ext_compare (nat_trans_ax_pshf (typecat_mor_Ty F) _ _)
    · q_typecat (typecat_mor_Ty F Γ A) (# F σ)
:= pr2 (pr2 F) Γ Γ' A σ.

Lemma isaprop_typecat_mor_axioms {C D} (F : typecat_mor_data C D) :
  isaprop (typecat_mor_axioms F).
Proof.
  apply isapropdirprod; repeat (apply impred_isaprop; intro); apply homset_property.
Qed.

  Lemma comp_ext_compare_typecat_mor_iso
      {C C' : split_typecat} (F : typecat_mor C C')
      (Γ : C) (A A' : C Γ) (e : A = A')
    : # F (comp_ext_compare e) ;; typecat_mor_iso F A'
      = typecat_mor_iso F A ;; comp_ext_compare (maponpaths _ e).
  Proof.
    destruct e; cbn.
    rewrite functor_id, id_left.
    apply pathsinv0, id_right.
  Qed.

End morphisms.

Section Composition.

  Definition id_typecat (C : split_typecat)
    : typecat_mor C C.
  Proof.
    use make_typecat_mor.
    - (* functor *)
      apply functor_identity.
    - (* naturality *)
      use tpair.
      + intros Γ A; exact A.
      + intros ? ? ?; apply idpath.
    - (* comparison isomorphisms *)
      intros; apply identity_iso.
    - (* axiom [typecat_mor_triangle] *)
      intros; simpl. apply pathsinv0, id_left.
    - (* axiom [typecat_mor_pentagon] *)
      intros; cbn.
      etrans. { apply id_right. }
      apply pathsinv0.
      etrans. { apply maponpaths_2, id_right. }
      apply id_left.
  Defined.

  Definition compose_typecat_data {C C' C'' : split_typecat}
      (F : typecat_mor C C') (F' : typecat_mor C' C'')
    : typecat_mor_data C C''.
  Proof.
    exists (functor_composite F F').
    use tpair.
    - refine (_ ;; _).
      { exact (typecat_mor_Ty F). }
      simple refine (_ ;; _).
      { exact (functor_opp F ∙ (functor_opp F' ∙ ty C'')). }
      { apply pre_whisker, typecat_mor_Ty. }
      (* TODO: the following should exist as a lemma somewhere *)
      use tpair.
      + intros Γ A; exact A.
      + intros ? ? ?; apply idpath.
    - (* [typecat_mor_iso] *)
      intros Γ A; simpl.
      refine (iso_comp _ _).
      2: { apply typecat_mor_iso. }
      apply functor_on_iso, typecat_mor_iso.
  Defined.

  Definition compose_typecat_axioms {C C' C'' : split_typecat}
      (F : typecat_mor C C') (F' : typecat_mor C' C'')
    : typecat_mor_axioms (compose_typecat_data F F').
  Proof.
    split.
    - (* axiom [typecat_mor_triangle] *)
      intros Γ A; cbn.
      etrans. { apply maponpaths, typecat_mor_triangle. }
      etrans. { apply functor_comp. }
      etrans. 2: { apply assoc. }
      apply maponpaths, typecat_mor_triangle.
    - (* axiom [typecat_mor_pentagon] *)
      intros Γ Γ' A f; cbn.
      etrans. { apply assoc. }
      etrans. { apply maponpaths_2.
        etrans. { apply pathsinv0. apply (functor_comp F'). }
        etrans. { apply maponpaths, typecat_mor_pentagon. }
        apply (functor_comp F'). }
      etrans. { apply pathsinv0, assoc. }
      etrans. { apply maponpaths, typecat_mor_pentagon. }
      etrans. { apply maponpaths_2, functor_comp. }
      etrans. { apply assoc. }
      apply maponpaths_2.
      etrans. { apply pathsinv0, assoc. }
      etrans. 2: { apply assoc. }
      apply maponpaths.
      etrans. { apply assoc. }
      etrans. { apply maponpaths_2, comp_ext_compare_typecat_mor_iso. }
      etrans. { apply pathsinv0, assoc. } apply maponpaths.
      etrans. { apply pathsinv0, comp_ext_compare_comp. }
      apply comp_ext_compare_irrelevant.
  Qed.

  Definition compose_typecat {C C' C'' : split_typecat}
      (F : typecat_mor C C') (F' : typecat_mor C' C'')
    : typecat_mor C C''.
  Proof.
    exists (compose_typecat_data F F').
    apply compose_typecat_axioms.
  Defined.

(* TODO: also will need at least [id_left] for the proof of initiality *)

End Composition.

Section Derived_Actions.

  (* Alias of [typecat_mor_Ty], to fit a more consistent naming convention.
   TODO: consider making this the primitive name of the field? *)
  Definition fmap_ty {C D} (F : typecat_mor C D)
    := typecat_mor_Ty F.

  (* Call this [fmap_tm] for consistency with later defs, or [typecat_mor_tm] for consistency with primitive components? *)
  Definition fmap_tm
      {C D : split_typecat} (F : typecat_mor C D)
      {Γ:C} {A : C Γ} (a : tm A)
    : tm (typecat_mor_Ty F _ A).
  Proof.
    exists (# F a · typecat_mor_iso F A).
    abstract (cbn; eapply pathscomp0; [ apply pathsinv0, assoc |];
      eapply pathscomp0; [ apply maponpaths, pathsinv0, typecat_mor_triangle|];
      eapply pathscomp0; [ apply pathsinv0, functor_comp|];
      eapply pathscomp0; [ apply maponpaths, section_property|];
      apply functor_id).
  Defined.

  Lemma fmap_tm_as_map
      {C C' : split_typecat} (F : typecat_mor C C')
      {Γ:C} {A: C Γ} (a : tm A)
    : # F a = fmap_tm F a · inv_from_iso (typecat_mor_iso F A).
  Proof.
    now apply iso_inv_on_left.
  Qed.

  (* Other possible names: [typecat_mor_reind_ty], [typecat_mor_Ty_nat] *)
  Definition reindex_fmap_ty
      {C C' : split_typecat} (F : typecat_mor C C')
      {Γ:C} (A: C Γ) {Γ' : C} (f : Γ' --> Γ)
    : typecat_mor_Ty F _ (A ⦃f⦄) = (typecat_mor_Ty F _ A) ⦃ # F f ⦄
    := nat_trans_ax_pshf (typecat_mor_Ty F) _ _.

  Lemma reindex_fmap_tm {C D : split_typecat} (F : typecat_mor C D) {Γ Γ' : C}
        (f : C ⟦ Γ', Γ ⟧) {A : C Γ} (a : tm A) :
    tm_transportf (reindex_fmap_ty F A f) (fmap_tm F (reind_tm f a)) =
    reind_tm (# F f) (fmap_tm F a).
  Proof.
    apply paths_tm, PullbackArrowUnique; cbn; simpl;
      set (pb := make_Pullback _ _); rewrite <-!assoc.
    - etrans; [apply maponpaths, maponpaths, dpr_typecat_typeeq|].
      etrans; [apply maponpaths, (!typecat_mor_triangle F (A ⦃f⦄))|].
      now rewrite <- functor_comp, (PullbackArrow_PullbackPr1 pb), functor_id.
    - etrans; [apply maponpaths; rewrite assoc;
               apply (!typecat_mor_pentagon F A f)|].
      now rewrite !assoc, <- !functor_comp, (PullbackArrow_PullbackPr2 pb).
  Qed.

  Definition fmap_type_with_term {C C'} (F : typecat_mor C C')
      {Γ:C} (Aa : type_with_term Γ)
    : type_with_term (F Γ).
  Proof.
    exact (typecat_mor_Ty F _ (type_of Aa),,fmap_tm F Aa).
  Defined.

  Lemma var_with_type_fmap_type
      {C C'} (F : typecat_mor C C')
      {Γ} (A : C Γ)
    : var_with_type (fmap_ty F Γ A)
    = reind_type_with_term (inv_from_iso (typecat_mor_iso F A))
                           (fmap_type_with_term F (var_with_type A)).
  Proof.
    apply pathsinv0.
    use paths_type_with_term.
    - simpl.
      etrans. { eapply (maponpaths (fun X => reind_typecat X _)).
           exact (reindex_fmap_ty F _ (dpr_typecat A)). }
      etrans. { apply pathsinv0, reind_comp_typecat. }
      apply maponpaths, iso_inv_on_right, typecat_mor_triangle.
    - apply PullbackArrowUnique.
      + etrans. { apply pathsinv0, assoc. }
        etrans. { apply maponpaths, dpr_typecat_typeeq. }
        apply section_property.
      + (* NOTE: the next step is just asking to apply [cbn] to the subterm
         beginning [PullbackPr2].  [simpl PullbackPr2] applies [simpl] to this
         subterm, but [simpl] doesn’t simplify enough in this case. *)
        etrans. { apply maponpaths. cbn. apply idpath. }
        rewrite comp_ext_compare_comp.
        rewrite comp_ext_compare_comp.
        etrans. { apply pathsinv0, assoc. }
        etrans.
        { apply maponpaths.
          etrans. { apply pathsinv0, assoc. }
          etrans. { apply maponpaths, pathsinv0, assoc. }
          etrans. { apply maponpaths, maponpaths, q_typecat_mapeq. }
          etrans. { apply maponpaths, pathsinv0, q_q_typecat. }
          etrans. { apply assoc. }
          apply maponpaths_2, q_typecat_typeeq.
        }
        etrans. { apply assoc. }
        etrans. { apply maponpaths_2, assoc. }
        etrans. { apply maponpaths_2, maponpaths_2.
          refine (PullbackArrow_PullbackPr2 (make_Pullback _ _) _ _ _ _). }
        simpl pr1.
        etrans. { apply maponpaths_2, maponpaths_2, assoc. }
        etrans. { apply pathsinv0, assoc. }
        etrans. { apply pathsinv0, assoc. }
        etrans. { apply maponpaths, assoc. }
        etrans. { apply maponpaths, pathsinv0, typecat_mor_pentagon. }
        etrans. { apply pathsinv0, assoc. }
        etrans. { apply maponpaths, assoc. }
        etrans.
        { apply maponpaths, maponpaths_2.
          etrans. { apply pathsinv0, functor_comp. }
          etrans.
          { apply maponpaths.
            refine (PullbackArrow_PullbackPr2 (make_Pullback _ _) _ _ _ _).
          }
          apply functor_id.
        }
        etrans. { apply maponpaths, id_left. }
        apply iso_after_iso_inv.
  Qed.
  (* TODO: can we speed this proof up, perhaps by factoring out some lemma(s)? *)

End Derived_Actions.


Require Import Setoid Morphisms List Arith Lia.
Import ListNotations.

Require Import Undecidability.CFG.CFP.
Require Import Undecidability.CFG.CFG.
Require Import Undecidability.CFG.Util.Facts.

(* bad design : this file has nothing to do with PCP *)
Require Import Undecidability.PCP.Util.PCP_facts.

Require Import Undecidability.Synthetic.Definitions.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

Local Notation "x 'el' A" := (In x A) (at level 70).
Local Notation "A <<= B" := (incl A B) (at level 70).

(* * PCP to CFPP *)
Local Hint Rewrite concat_app map_app map_map : list.
Local Hint Rewrite <- map_rev : list.

Local Hint Constructors rew_cfg : core.
Local Hint Constructors rewt : core.

Lemma nil_app_nil {X} (A : list X) :
  A = [] ++ A ++ [].
Proof.
  now autorewrite with list.
Qed.

Definition gamma (A : stack nat) := map (fun '(x,y) => (x, rev y)) A.

Lemma sigma_eq  s A :
  sigma s A = tau1 A ++ [s] ++ rev (tau2 (gamma A)).
Proof.
  induction A  as [ | [u v] ].
  - reflexivity.
  - cbn. rewrite IHA. now simpl_list.
Qed.

Lemma tau2_gamma s A :
  s el rev (tau2 (gamma A)) <-> s el tau2 A.
Proof.
  induction A as [ | [u v] ]; cbn.
  - reflexivity.
  - simpl_list. rewrite !in_app_iff, IHA. firstorder.
Qed.

Lemma sigma_inv A s1 s x y :
  sigma s1 A = x ++ [s] ++ y -> ~ s el x -> ~ s el y -> ~ s el sym A ->
  s1 = s.
Proof.
  rewrite sigma_eq. intros.
  cbn in H. assert (s el  tau1 A ++ s1 :: rev (tau2 (gamma A))) by (rewrite H; eauto).
  eapply in_app_iff in H3 as [ | [ | ? % tau2_gamma]]; try firstorder using tau1_sym, tau2_sym.
Qed.

Lemma sigma_snoc A (x y u v: list sig) (s s': sig) :
  sigma s A = x ++ [s] ++ y -> ~ s el x -> ~ s el y ->
  sigma s' (A ++ [(u, v)]) = x ++ u ++ s' ++ v ++ y.
Proof.
  rewrite !sigma_eq. unfold gamma. cbn. simpl_list. cbn. simpl_list. cbn.
  intros. eapply list_prefix_inv in H as [-> <-]; eauto.
  eapply notInZero.
  eapply (f_equal (fun a => count a s)) in H. rewrite <- !countSplit in H. cbn in H.
  rewrite !Nat.eqb_refl in H. eapply notInZero in H0. eapply notInZero in H1.
  rewrite H0, H1 in *. lia.
Qed.

Section CFGs.

  Lemma rewrite_sing R a x :
    (a, x) el rules R -> rew_cfg R [a] x.
  Proof.
    intro. rewrite nil_app_nil, (nil_app_nil [a]). now econstructor.
  Qed.

  Global Instance rewtTrans R :
    PreOrder (rewt R).
  Proof.
    split.
    - hnf. econstructor.
    - induction 2; eauto.
  Qed.

  Global Instance rewrite_proper R :
    Proper (rewt R ==> rewt R ==> rewt R) (@app sig).
  Proof.
    intros x1 y1 H1 x2 y2 H2.
    induction H1.
    - induction H2.
      + reflexivity.
      + rewrite IHrewt. inv H. eapply rewtRule.
        * replace (x1 ++ x ++ [a] ++ y0) with ( (x1 ++ x) ++ [a] ++ y0) by now autorewrite with list.
          eauto.
        * replace (x1 ++ x ++ v ++ y0) with ( (x1 ++ x) ++ v ++ y0) by now autorewrite with list. eauto.
    - rewrite IHrewt. inv H. autorewrite with list. eauto.
  Qed.

  Global Instance subrel R :
    subrelation (rew_cfg R) (rewt R).
  Proof.
    intros x y H. econstructor.
    - reflexivity.
    - eassumption.
  Qed.

  Lemma terminal_iff G x :
    terminal G x <-> forall s y, s el x -> ~ (s, y) el rules G.
  Proof.
    split.
    - intros H s y A B. apply H. destruct (@in_split _ _ _ A) as (l1 & l2 & ->).
      exists (l1 ++ y ++ l2). change (s :: l2) with ([s] ++ l2). now econstructor.
    - intros H1 [y H2]. inv H2. eapply (H1 _ v); eauto.
  Qed.

  Definition sym_G (G : cfg) :=
    startsym G :: flat_map (fun '(a, x) => a :: x) (rules G).

  Lemma sym_G_rewt x G y :
    x <<= sym_G G -> rewt G x y -> y <<= sym_G G.
  Proof.
    intros. induction H0.
    - eauto.
    - destruct H1. destruct R. cbn in *.
      pose (app_incl_l IHrewt).
      eapply incl_app.
      { eapply app_incl_l. eassumption. }
      eapply incl_app.
      + unfold sym_G. intros ? ?.
        right. eapply in_flat_map. exists (a, v). eauto.
      + eapply cons_incl. eapply app_incl_R. eassumption.
  Qed.

End CFGs.

Section Post_CFG.

  Variable R : stack nat.
  Variable a : nat.

  Definition Sigma := sym R ++ [a].
  Definition S : nat := fresh Sigma.

  Definition G := (S, (S,[S]) :: map (fun '(u, v) => (S, u ++ [S] ++ v)) R ++ map (fun '(u, v) => (S, u ++ [a] ++ v)) R).

  Lemma terminal_iff_G y :
    terminal G y <-> ~ S el y.
  Proof.
    unfold terminal.
    enough ((exists y0, rew_cfg G y y0) <-> S el y). { firstorder. } split.
    - intros [y0 ?]. inv H. cbn in H0.
      destruct H0 as [ | [ [[] []] % in_map_iff | [[] []] % in_map_iff ] % in_app_iff]; inv H; eauto.
    - intros (u' & v' & ?) % List.in_split.
      subst. exists (u' ++ [S] ++ v'). econstructor. cbn. eauto.
  Qed.

  Lemma rewt_count x :
    rewt G [S] x -> count x S <= 1.
  Proof.
    induction 1.
    - cbn. now rewrite Nat.eqb_refl.
    - inv H0. destruct H1 as [ | [ [[] []] % in_map_iff | [[] []] % in_map_iff ] % in_app_iff]; inv H0.
      + eauto.
      + unfold Sigma. simpl_list. rewrite <- !countSplit in *. cbn in *.
        rewrite Nat.eqb_refl in *.
        enough (count l S = 0) as ->. { enough (count l0 S = 0) as ->. { lia. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_R in H1. unfold Sigma. eauto. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_l in H1. unfold Sigma. eauto.
      + unfold Sigma. simpl_list. rewrite <- !countSplit in *. cbn in *.
        rewrite Nat.eqb_refl in *.
        assert (S =? a = false) as ->. { eapply Nat.eqb_neq. intros D.
        edestruct fresh_spec with (l := Sigma); try reflexivity.
        unfold S in *. rewrite D. unfold Sigma; eauto. }
        enough (count l S = 0) as ->. { enough (count l0 S = 0) as ->. { lia. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_R in H1. unfold Sigma. eauto. }
        eapply notInZero. intros D.
        edestruct (fresh_spec) with (l := Sigma); try reflexivity.
        eapply sym_word_l in H1. unfold Sigma. eauto.
  Qed.

  Lemma Post_CFG_1' A :
    A <<= R -> A = [] \/ rewt G [S] (sigma a A).
  Proof.
    induction A.
    - cbn. eauto.
    - intros.  assert (A <<= R) by eauto. eapply IHA in H0.
      destruct a0 as [u v]. destruct H0.
      + subst. right. erewrite rewrite_sing with (x := u ++ [a] ++ v). { reflexivity. }
        right. eapply in_app_iff. right. eapply in_map_iff. exists (u,v); eauto.
      + right. erewrite rewrite_sing with (x := u ++ [S] ++ v).
        { now rewrite H0. } right. eapply in_app_iff. left. eapply in_map_iff. exists (u,v); eauto.
  Qed.

  Lemma Post_CFG_2 x :
    rewt G [S] x ->
    exists A m, A <<= R /\ sigma m A = x /\ (m = S \/ m = a /\ A <> []).
  Proof.
    intros. induction H.
    - cbn.  exists [], S. eauto.
    - inv H0. destruct H1 as [ | [(? & ? & ?) % in_map_iff | (? & ? & ?) % in_map_iff] % in_app_iff]; inv H0.
      + eassumption.
      + destruct x0 as [u' v']. inv H3.
        destruct IHrewt as (A & m & HA & IHA & Hm).
        exists (A ++ [(u', v')]), S. repeat split.
        * eauto.
        * simpl_list. cbn.
          enough (~ S el x). { enough (~ S el y0). {
          eapply sigma_snoc with (s := S); eauto.
          assert (IH2 := IHA).
          eapply sigma_inv in IHA; eauto. { subst. eauto. }
          intros D.
          edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
          eapply in_app_iff. left. eapply sym_mono. { eauto. } eauto. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia.
        * eauto.
      + destruct x0 as [u' v']. inv H3.
        destruct IHrewt as (A & m & HA & IHA & Hm).
        exists (A ++ [(u', v')]), a. repeat split.
        * eauto.
        * simpl_list. cbn.
          enough (~ S el x). { enough (~ S el y0). {
          eapply sigma_snoc with (s := S); eauto.
          -- assert (IH2 := IHA).
          eapply sigma_inv in IHA; eauto. { subst. eauto. }
          intros D.
          edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
          eapply in_app_iff. left. eapply sym_mono. { eauto. } eauto. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia. }
          eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
          rewrite Nat.eqb_refl in H. eapply notInZero. lia.
        * destruct A; cbn; firstorder congruence.
  Qed.

  Lemma reduction_full x :
    (exists A, A <<= R /\ A <> [] /\ sigma a A = x) <->  L G x.
  Proof.
    split.
    - intros (A & ? & ? & ?). subst. destruct Post_CFG_1' with (A := A); intuition.
      split.
      + eassumption.
      + eapply terminal_iff_G. rewrite sigma_eq. intros E.
        edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
        eapply in_app_iff in E as [ | [ | ? % tau2_gamma ] % in_app_iff].
        * eapply in_app_iff. left. eapply sym_mono; eauto. now eapply tau1_sym.
        * eapply in_app_iff. right. eauto.
        * eapply in_app_iff. left. eapply sym_mono; eauto. now eapply tau2_sym.
    - intros [(A & m & HA & HE & Hm) % Post_CFG_2 ?].
      subst. destruct Hm as [-> | [-> ?]].
      + eapply terminal_iff_G in H.  exfalso. rewrite sigma_eq in H.
        eapply H. eauto.
      + exists A. eauto.
  Qed.

End Post_CFG.

Theorem reduction :
  CFPP ⪯ CFP.
Proof.
  exists (fun '(R, a) => (G R a)). intros [R a].
  intuition; cbn in *.
  - destruct H as (A & HR & HA & H).
    exists (sigma a A). split.
    + eapply reduction_full; eauto.
    + eauto.
  - destruct H as (x & Hx & H).
    eapply reduction_full in Hx as (A & HR & HA & H1).
    exists A. subst; eauto.
Qed.