Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple fintype.
Require Import ZArith zint.
Require Export Setoid Relation_Definitions.

Require Import WhileLang TrfState SelfComp.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition ident := positive.

Open Scope Z_scope.

Section FullProductTrf.

Variable ops: opSig.

Definition ok_upd (e: expr ops) : cmd ops :=
 Assign ok_lvalue (And ok_expr e).

Variable lspec: LeakSpec ops.

Definition EqLeak (e1 e2: expr ops): expr ops :=
 EqSeqExpr (preleak lspec e1) (preleak lspec e2).

Lemma isTrue_EqLeak: forall st st1 st2 e,
 isTrue_expr (joinState (st1,st2,st)) (EqLeak (expr_i1 e) (expr_i2 e))
 <-> leak_expr (preleak lspec) st1 e = leak_expr (preleak lspec) st2 e.
Proof.
move=> st st1 st2 e.
rewrite /EqLeak /= isTrue_EqSeqExpr /leak_expr !preleak_ren -map_comp.
have ->:[seq eval_expr (joinState (st1,st2,st)) (ren_expr false x)
        | x <- preleak lspec e] = [seq eval_expr st1 x | x <- preleak lspec e].
 by apply eq_map => x; rewrite eval_expr_join_i1.
rewrite -map_comp.
have ->:[seq eval_expr (joinState (st1,st2,st)) (ren_expr true x)
        | x <- preleak lspec e] = [seq eval_expr st2 x | x <- preleak lspec e].
 by apply eq_map => x; rewrite eval_expr_join_i2.
(*
have ->: [seq inr (eval_expr st1 e0) | e0 <- preleak lspec e] =
         map (@inr bool Z) [seq eval_expr st1 x | x <- preleak lspec e] .
 by rewrite map_comp.
have ->: [seq inr (eval_expr st2 e0) | e0 <- preleak lspec e] =
         map (@inr bool Z) [seq eval_expr st2 x | x <- preleak lspec e] .
 by rewrite map_comp.
*)
split => H; first by rewrite H.
apply H.
(*
have inr_inj: injective (@inr bool Z) by move=> x1 x2 [->].
by apply (inj_map inr_inj).
*)
Qed.

Definition assertEqLeak (e: expr ops): cmd ops :=
 ok_upd (EqLeak (ren_expr false e) (ren_expr true e)).
Definition assertEqLeakTest (e: expr ops): cmd ops :=
 ok_upd (And (Equal (IsTrue (ren_expr false e)) (IsTrue (ren_expr true e)))
             (EqLeak (ren_expr false e) (ren_expr true e))).

Fixpoint productTrf (c: cmd ops) {struct c} : cmd ops :=
 match c with
 | Skip => @Skip ops
 | Assert e => Seq (Assert (ren_expr false e)) (Assert (ren_expr true e))
 | Assume e => Seq (Assume (ren_expr false e)) (Assume (ren_expr true e))
 | Assign x e => Seq (Seq (assertEqLeak (ValOf x))
                          (assertEqLeak e))
                     (Seq (Assign (ren_lvalue false x) (ren_expr false e))
                          (Assign (ren_lvalue true x) (ren_expr true e)))
 | Seq c1 c2 => Seq (productTrf c1) (productTrf c2)
 | If b c1 c2 => Seq (assertEqLeakTest b)
                     (If ok_expr
                         (If (ren_expr false b) (productTrf c1) (productTrf c2))
                         (Seq (selfComp lspec (If b c1 c2)) (ok_upd okSC_expr)))
 | While b c1 =>
    Seq (assertEqLeakTest b)
        (Seq (While (And ok_expr (ren_expr false b) )
                    (Seq (productTrf c1)
                         (assertEqLeakTest b)))
             (Seq (selfComp lspec (While b c1)) (ok_upd okSC_expr)))
 end.

(* prop1 de fullProduct *)
Lemma product_sound': forall n c s1 s2 st l1 l2 s1' s2',
  feval_cmd lspec n c s1 = Some (Some s1',l1) ->
  feval_cmd lspec n c s2 = Some (Some s2',l2) ->
  exists st' ll,
   eval_cmd lspec (updLValue (joinState (s1, s2, st)) (@ok_lvalue ops) 1)
            (productTrf c)
            ll (Some (joinState (s1',s2',st')))
   /\ (isTrue_expr (joinState (s1',s2',st')) (@ok_expr ops) <-> l1=l2).
Proof.
elim => //=.
move => n IH [|e|e|x e|c1 c2|b c1 c2|b c] s1 s2 st l1 l2 s1' s2' H1 H2.
- admit.
- admit.
- admit.
- admit.
- admit.
- admit.
- admit.
Qed.

Lemma product_sound: forall c s1 s2 st l1 l2 s1' s2',
  eval_cmd lspec s1 c l1 (Some s1') ->
  eval_cmd lspec s2 c l2 (Some s2') ->
  exists st' ll,
   eval_cmd lspec (updLValue (joinState (s1, s2, st)) (@ok_lvalue ops) 1)
            (productTrf c)
            ll (Some (joinState (s1',s2',st')))
   /\ (isTrue_expr (joinState (s1',s2',st')) (@ok_expr ops) <-> l1=l2).
Proof.
move=> c s1 s2 st l1 l2 s1' s2'
       /eval_cmd_feval [n1 H1] /eval_cmd_feval [n2 H2].
apply product_sound' with (maxn n1 n2).
 apply feval_cmd_weak with n1 => //.
 by apply leq_maxl.
apply feval_cmd_weak with n2 => //.
by apply leq_maxr.
Qed.

(* prop2 de fullProduct *)
Lemma product_complete: forall c s ll s',
  eval_cmd lspec s (productTrf c) ll (Some s') ->
  exists l1 l2,
   [/\ eval_cmd lspec (splitState s).1.1 c l1 (Some (splitState s').1.1),
       eval_cmd lspec (splitState s).1.2 c l2 (Some (splitState s').1.2)
    & isTrue_expr s (@ok_expr ops) -> l1=l2 -> isTrue_expr s' (@ok_expr ops)].
Proof.
admit.
Qed.

Lemma product_imgN: forall st s1 c l1,
 eval_cmd lspec s1 c l1 None ->
 exists ll,
 eval_cmd lspec (joinState (s1,s1,st)) (productTrf c) ll None.
Proof.
move=> st s1 c l1 /eval_cmd_feval [n H].
elim: n c s1 l1 st H => //=.
move => n IH [|e|e|x e|c1 c2|b c1 c2|b c] s1 l1 st H; try discriminate H.
- by move: H; case: (ifP _).
- move: H; case: (ifP _) => H //.
  move => _; exists [::]; constructor; constructor.
  move: H; rewrite /isTrue_expr eval_expr_join_i1.
  by move=> H; apply/negPf.
- move: H.
  move: {2 3}(feval_cmd lspec n c1 s1)
        (Logic.eq_refl (feval_cmd lspec n c1 s1)) => [[[s'|] l']|] E1 //.
   move: {2 3}(feval_cmd lspec n c2 s')
         (Logic.eq_refl (feval_cmd lspec n c2 s')) => [[[s''|] l'']|] E2 //.
   by admit.
  move=> [El']; move: E1; rewrite El' {El'} => E1 /=.
  elim (IH _ _ _ st E1) => ll; exists ll.
  by apply eval_SeqN.
- move: H; case: (ifP _) => Eb.
   move: {2 3}(feval_cmd lspec n c1 s1)
         (Logic.eq_refl (feval_cmd lspec n c1 s1)) => [[[s'|] l']|] E1 //.
   by admit.
  move: {2 3}(feval_cmd lspec n c2 s1)
        (Logic.eq_refl (feval_cmd lspec n c2 s1)) => [[[s'|] l']|] E1 //.
  by admit.
- move: H; case: (ifP _) => Eb //.
  move: {2 3}(feval_cmd lspec n (Seq c (While b c)) s1)
        (Logic.eq_refl (feval_cmd lspec n (Seq c (While b c)) s1))
        => [[[s'|] l']|] E1 //.
  by admit.
Qed.

Lemma product_preimgN: forall s c ll,
 eval_cmd lspec s (productTrf c) ll None ->
 (exists l1, eval_cmd lspec (splitState s).1.1 c l1 None)
 \/ (exists l2, eval_cmd lspec (splitState s).1.2 c l2 None).
Proof.
move=> s c l /eval_cmd_feval [n H].
elim: n c s l H => //.
move => n IH [|e|e|x e|c1 c2|b c1 c2|b c] s l H; try discriminate H.
- rewrite /= in H; move: {2 3}(feval_cmd lspec n (Assume _) s)
        (Logic.eq_refl (feval_cmd lspec n (Assume (ren_expr false e)) s)) H
        => [[[s'|] l']|] H1 //.
   move: {2 3}(feval_cmd lspec n (Assume _) s')
         (Logic.eq_refl (feval_cmd lspec n (Assume (ren_expr true e)) s'))
         => [[[s''|] l'']|] H2 // [E2].
   by move/feval_cmd_eval: H2 => /eval_cmd_AssumeI [].
  move=> [E1].
  by move/feval_cmd_eval: H1 => /eval_cmd_AssumeI [].
- rewrite /= in H; move: {2 3}(feval_cmd lspec n (Assert _) s)
        (Logic.eq_refl (feval_cmd lspec n (Assert (ren_expr false e)) s)) H
        => [[[s'|] l']|] H1 //.
   move: {2 3}(feval_cmd lspec n (Assert _) s')
         (Logic.eq_refl (feval_cmd lspec n (Assert (ren_expr true e)) s'))
         => [[[s''|] l'']|] H2 // [E2].
    move/feval_cmd_eval: H2 => /eval_cmd_AssertNI [] // Hb2 El2.
    move/feval_cmd_eval: H1 => /eval_cmd_AssertSI [] // Hb1 <- El1.
    right; exists [::]; constructor.
    by move: Hb2; rewrite /isTrue_expr {1}(joinSplitState s') eval_expr_join_i2.
   move=> [E1].
   move/feval_cmd_eval: H1 => /eval_cmd_AssertNI [] Hb1 El1.
   left; exists [::]; constructor.
   by move: Hb1; rewrite /isTrue_expr {1}(joinSplitState s) eval_expr_join_i1.
- admit.
- rewrite /= in H.
  move: {2 3}(feval_cmd lspec n _ s)
        (Logic.eq_refl (feval_cmd lspec n (productTrf c1) s)) H
        => [[[s'|] l']|] H1 //.
   move: {2 3}(feval_cmd lspec n _ s')
         (Logic.eq_refl (feval_cmd lspec n (productTrf c2) s'))
         => [[[s''|] l'']|] H2 // [E2].
   move/feval_cmd_eval: H1 => /product_complete [l1 [l2 [H11 H12 H13]]].
   move: {IH} (IH _ _ _ H2) => [[ll IH]|[ll IH]].
    by left; exists (l1++ll); apply eval_SeqS with (splitState s').1.1.
   by right; exists (l2++ll); apply eval_SeqS with (splitState s').1.2.
  move: {IH} (IH _ _ _ H1) => [[ll IH]|[ll IH]] [El].
   by left; exists ll; apply eval_SeqN.
  by right; exists ll; apply eval_SeqN.
- rewrite /= in H.
  move: {2 3}(feval_cmd lspec n _ s)
        (Logic.eq_refl (feval_cmd lspec n (assertEqLeakTest b) s)) H
        => [[[s'|] l']|] H1 //; last first.
   move => [El]; subst.
   admit (* assertEqLeak != None *).
  have ->: s' = updLValue s (@ok_lvalue ops) (eval_expr s b) (* it is NOT b *).
   admit (* invert feval_assertEqLeakTest *).
  move: {2 3}(feval_cmd lspec n _ _)
        (Logic.eq_refl (feval_cmd lspec n (If ok_expr (If (ren_expr false b) (productTrf c1) (productTrf c2))
          (Seq (selfComp lspec (If b c1 c2)) (ok_upd okSC_expr))) (updLValue s (@ok_lvalue ops) (eval_expr s b))))
        => [[[s''|] l'']|] H2 // [E2].
  move/feval_cmd_eval: H2 => /eval_cmd_IfI [ll].
  case: (ifP _) => Hok.
   (* Caso standard... *) admit.
  (* Caso SelfComp...
    eval_cmd lspec s (selfComp lspec c) ll None ->
    (exists l1, eval_cmd lspec (splitState s).1.1 c l1 None)
    \/ (exists l2, eval_cmd lspec (splitState s).1.2 c l2 None) *)
  admit.
- admit.
Qed.

Definition initProduct: cmd ops :=
 Assign ok_lvalue (Const 1).

Lemma initProduct_SeqI: forall st c l st',
 eval_cmd lspec st (Seq initProduct c) l st' ->
 eval_cmd lspec (updLValue st (@ok_lvalue ops) 1) c l st'.
Proof.
admit.
Qed.

Fixpoint assumeVarRestr (v: VarRestr) : cmd ops :=
 match v with
 | [::] => Skip _
 | x::xs => Seq (Assume (Equal (ren_expr false (ValOf (Var x))) (ren_expr true (ValOf (Var x))))) (assumeVarRestr xs)
 end.

Lemma assumeVarRestrP: forall v st l st',
 eval_cmd lspec st (assumeVarRestr v) l st'
 <->
 joinStateEqLow v st /\ l=[::] /\ st'=Some st.
Proof.
elim => [|x xs IH] st l st' /=.
 split.
  move=> /eval_cmd_SkipI [-> ->]; split; last by split.
  by rewrite /eqstateR.
 by move=> [_ [-> ->]]; constructor.
split.
 move=> /eval_cmd_SeqI
         [[-> H]|[s' [l1 [l2 [/eval_cmd_AssumeI [H1 [->] ->] H2 ->]]]]];
  first by inversion_clear H.
 rewrite -> IH in H2; move: {IH} H2 => [H2 [-> ->]].
 split; last by [].
 by admit (* simples eqstateR_cons *).
move => [Hv [-> ->]].
 rewrite -/([::]++[::]); apply eval_SeqS with st.
  constructor.
  by admit (* simples eqstateR_cons *).
 rewrite IH; split; last by [].
 by admit (* simples eqstateR_cons *).
Qed.

Lemma assumeSeq_SeqI: forall v st c l st',
 eval_cmd lspec st (Seq (assumeVarRestr v) c) l st' ->
 eval_cmd lspec st c l st' /\ joinStateEqLow v st.
Proof.
move=> v st c l st' /eval_cmd_SeqI [[->]|[s' [l1 [l2 [H1 H2 ->]]]]].
 by rewrite assumeVarRestrP => [[_ [_ H2]]].
move: H1; rewrite assumeVarRestrP => [[H1 [-> [Es]]]] /=.
by move: H1; rewrite -Es {Es} => H1; split.
Qed.

Variable vIN vOUT: VarRestr.

Definition fullProduct (c: cmd ops) : cmd ops :=
 Seq (Seq (Seq initProduct (assumeVarRestr vIN))
          (productTrf c))
     (Seq (assumeVarRestr vOUT) (Assert ok_expr)).

Lemma fullProduct_imgN: forall st s1 c l1,
 eval_cmd lspec s1 c l1 None ->
 exists ll,
 eval_cmd lspec (joinState (s1,s1,st)) (fullProduct c) ll None.
Proof.
rewrite /fullProduct => st s1 c l1 H.
set st' := (updLValue (joinState (s1, s1, st)) (@ok_lvalue ops) 1).
move: (product_imgN (splitState st').2 H) => [ll Hll].
exists ((((leak_expr lspec (joinState (s1, s1, st)) (ValOf ok_lvalue)
         ++leak_expr lspec (joinState (s1, s1, st)) (Const 1))++[::])++ll)).
apply eval_SeqN.
eapply eval_SeqS.
 eapply eval_SeqS.
 constructor; first by reflexivity.
 rewrite assumeVarRestrP; split => //.
have HS: eqstate (joinState (s1, s1, (splitState st').2))
                 (updLValue (joinState (s1, s1, st)) (@ok_lvalue ops) 1).
 move => id /=; split => //.
 by move: id => [x|x|].
by move: (eval_cmd_eqstate HS Hll) => [[st2'|] [HH1 //= HH2]].
Qed.

Lemma fullProduct_sound': forall c s1 s2 l1 l2 s1' s2',
  eqstateR vIN s1 s2 ->
  eval_cmd lspec s1 c l1 (Some s1') ->
  eval_cmd lspec s2 c l2 (Some s2') ->
  eqstateR vOUT s1' s2' ->
  exists ss ll,
   eval_cmd lspec (joinState (s1, s2, trfState0)) (fullProduct c)
            ll ss
   /\ (ss <> None -> l1=l2).
Proof.
move => c s1 s2 l1 l2 s1' s2' Hin H1 H2 Hout.
move: (product_sound trfState0 H1 H2) => [st' [ll [HH1 HH2]]].
have HH: eval_cmd lspec (joinState (s1,s2,trfState0))
                  (Seq (Seq initProduct (assumeVarRestr vIN)) (productTrf c))
                  (((leak_expr lspec (joinState (s1, s2, trfState0))
                               (ValOf ok_lvalue)
                    ++leak_expr lspec (joinState (s1, s2, trfState0))
                                 (Const 1))++[::])++ll)
                  (Some (joinState (s1', s2', st'))).
 apply: eval_SeqS; last by apply HH1.
 apply eval_SeqS with (updLValue (joinState (s1,s2,trfState0)) (@ok_lvalue ops)1).
  constructor.
by [].
 rewrite assumeVarRestrP; split => //.
case E: (isTrue_expr (joinState (s1', s2', st')) (@ok_expr ops)).
 exists (Some (joinState (s1', s2', st'))).
 exists ((((leak_expr lspec (joinState (s1, s2, trfState0)) (ValOf ok_lvalue)
         ++leak_expr lspec (joinState (s1, s2, trfState0)) (Const 1))++[::])++ll)++[::]).
 split; last first.
  by move=> _; rewrite -HH2.
 apply eval_SeqS with (joinState (s1', s2', st')); first by [].
 rewrite -/([::]++[::]); apply eval_SeqS with (joinState (s1', s2', st')).
  by rewrite assumeVarRestrP /joinStateEqLow; split.
 by constructor.
exists None.
exists ((((leak_expr lspec (joinState (s1, s2, trfState0)) (ValOf ok_lvalue)
         ++leak_expr lspec (joinState (s1, s2, trfState0)) (Const 1))++[::])++ll)++([::]++[::])).
split => //.
apply eval_SeqS with (joinState (s1', s2', st')); first by [].
apply eval_SeqS with (joinState (s1', s2', st')); last first.
 by constructor; rewrite E.
by rewrite assumeVarRestrP.
Qed.

Theorem fullProduct_sound: forall c,
 Safe lspec (fullProduct c) ->
 leakSecure lspec vIN vOUT c.
Proof.
rewrite /leakSecure => c H s1 l1 ss1 H1.
move: ss1 H1 => [s1'|] H1; last first.
 move: (H (joinState (s1,s1,trfState0))) => H'.
 move/(fullProduct_imgN trfState0): H1 => [ll H1].
 by move: (H' _ _ H1).
exists s1'; split => // s2 s2' l2 HIN H2 HOUT.
move: {H} (H (joinState (s1,s2,trfState0))) => H.
move: (fullProduct_sound' HIN H1 H2 HOUT) => [st' [ll [HH1]]].
by move: {H} st' HH1 (H _ _ HH1) => [st'|] HH1 _ //; apply.
Qed.

Theorem fullProduct_complete: forall c,
 leakSecure lspec vIN vOUT c ->
 Safe lspec (fullProduct c).
Proof.
rewrite /Safe /leakSecure => c H st.
move => [st'|] l H' => //.
move: H' => /eval_cmd_SeqNI [H'| [ss' [l1 [l2 [H1 H2 Hll]]]]].
 move: H'=> /eval_cmd_SeqNI [/initProduct_SeqI| [ss' [l1 [l2 [H1 H2 Hll]]]]].
  by rewrite assumeVarRestrP => [[_ [_ H']]].
 move: H1 => /eval_cmd_SeqSI [s1' [l1' [l2' [H1' H2' Hll']]]].
 move: H1' => /eval_cmd_AssignI [[H1a] H1b].
 move: H2'; rewrite assumeVarRestrP => [[H2a [H2b [H2c]]] _]; subst.
 move: H2 => /product_preimgN [[l1 H1]|[l2' H2]].
  by move: {H H1} (H _ _ _ H1) => [ss [Hss _]].
 by move: {H H2} (H _ _ _ H2) => [ss [Hss _]].
move: H1 => /eval_cmd_SeqSI [s1' [l1' [l2' [H1' H2' Hll']]]].
move: H1' => /eval_cmd_SeqSI [s1'' [l1'' [l2'' [H1'' H2'' Hll'']]]].
move: H1'' => /eval_cmd_AssignI [[H1a] H1b].
move: H2''; rewrite assumeVarRestrP => [[H2a [H2b [H2c]]] _]; subst.
move: H2 => /assumeSeq_SeqI [/eval_cmd_AssertNI [Hnok _] Hout].
move/negP: Hnok; apply.
move: {H2'} (product_complete H2') => [ll1 [ll2 [HH1 [HH2 HH]]]].
apply HH => //.
move: (H _ _ _ HH1) => [ss1' [[<-] HH1']] {ss1'}.
by apply HH1' with (splitState (updVar st 1%positive (eval_expr st (@Const ops 1)))).1.2 (splitState ss').1.2.
Qed.


From Coq Require Import List ZArith String Program Lia.
From WiSE Require Import imp utils.
Import ListNotations.

(** Operator names *)
Inductive op :=
  | ADD
  | SUB.

(** Compressed expressions in the E-graph *)
Inductive eexpr :=
  | Eop (op : op) (args : list positive)
  | Ecst (c : Z)
  | Evar (v : string).

(** Nodes of the E-graph *)
Inductive enode : Type :=
  | Enode (key : positive) (exp : eexpr).

(** An E-graph is a list of e-nodes*)
Definition egraph' := list enode.

Fixpoint list_eq (l1 l2 : list positive) :=
  match l1, l2 with
  | [], [] => true
  | x::xs, y::ys =>
    if (x =? y)%positive then
      list_eq xs ys
    else false
  | _, _ => false
  end.

Definition eeq (e1 e2 : eexpr) :=
  match e1, e2 with
  | Eop ADD args1, Eop ADD args2 =>
    list_eq args1 args2
  | Eop SUB args1, Eop SUB args2 =>
    list_eq args1 args2
  | Ecst c1, Ecst c2 => (c1 =? c2)%Z
  | Evar v1, Evar v2 => (v1 =? v2)%string
  | _, _ => false
  end.

Lemma eeq_eq:
  forall e1 e2, eeq e1 e2 = true <-> e1 = e2.
Proof.
Admitted.

Lemma eeq_refl:
  forall e, eeq e e = true.
Proof.
  intros.
  now apply eeq_eq.
Qed.

Lemma eeq_neq:
  forall e1 e2, eeq e1 e2 = false <-> e1 <> e2.
Proof.
Admitted.

(** Find a the *)
Fixpoint egraph_find_ptr (g : egraph') (ptr : positive) :=
  match g with
  | [] => None
  | (Enode lbl _ as nd)::g =>
    if (lbl =? ptr)%positive then Some nd else egraph_find_ptr g ptr
  end.

Definition label (nd : enode) :=
  match nd with
  | Enode lbl  _ => lbl
  end.

Fixpoint egraph_find (g : egraph') (exp : eexpr) : option (positive * enode) :=
  match g with
  | [] => None
  | (Enode lbl exp' as nd)::g =>
    if eeq exp' exp then
      Some (lbl, nd)
    else
      egraph_find g exp
  end.

Fixpoint egraph_get (g : egraph') (id : positive) : option enode :=
  match g with
  | [] => None
  | (Enode lbl _ as nd)::g =>
    if (lbl =? id)%positive then
      Some nd
    else
      egraph_get g id
  end.

Fixpoint repr (g : egraph') (id : positive) : option aexpr :=
  match g with
  | [] => None
  | (Enode lbl exp)::g =>
    if (lbl =? id)%positive then
      match exp with
      | Ecst c => Some (Cst c)
      | Evar v => Some (Var v)
      | Eop ADD args =>
        reduce Add (map (repr g) args)
      | Eop SUB args =>
        reduce Sub (map (repr g) args)
      end
    else
      repr g id
  end.

Definition repr_node (g : egraph') '(Enode _ exp : enode) : option aexpr :=
  match exp with
  | Ecst c => Some (Cst c)
  | Evar v => Some (Var v)
  | Eop ADD args =>
    reduce Add (map (repr g) args)
  | Eop SUB args =>
    reduce Sub (map (repr g) args)
  end.

Lemma get_repr:
  forall g id e,
    repr g id = Some e ->
    exists exp g',
      egraph_find g exp = Some (id, Enode id exp) /\
      repr_node g (Enode id exp) = Some e.
Proof.
  induction g; intros; try easy.
  destruct a as [key exp]. simpl in H.
  destruct (key =? id)%positive eqn:Heq1.
  - apply Pos.eqb_eq in Heq1 as ->.
    exists exp. split.
    + simpl. now rewrite eeq_refl.
    + Opaque repr. simpl.

Record egraph : Type := {
  counter : positive;
  data    :> egraph';
}.

Definition wf_eexpr (g : egraph) (e : eexpr) : Prop :=
  match e with
  | Ecst _ => True
  | Evar _ => True
  | Eop _ args =>
    args <> [] /\
    Forall (fun id => repr g id <> None) args
  end.

Inductive wf_egraph : egraph -> Prop :=
  | wf_egraph_nil :
    wf_egraph (Build_egraph 1 [])
  | wf_egraph_cons c l e:
    wf_egraph (Build_egraph c l) ->
    wf_eexpr (Build_egraph c l) e ->
    (forall key exp, In (Enode key exp) l -> exp <> e) ->
    wf_egraph (Build_egraph (1 + c) (Enode c e::l)).

Lemma reduce_map_not_none:
  forall A B (l : list A) (f : A -> option B) g,
    l <> [] ->
    Forall (fun x => f x <> None) l ->
    reduce g (map f l) <> None.
Proof.
  intros * H1 H2.
  induction H2; try easy.
  - destruct l. simpl.
    now destruct (f x).
    simpl. destruct (f x); try easy.
    destruct (reduce g _) eqn:Heq.
    simpl in *.
    now rewrite Heq.
    exfalso. now apply IHForall.
Qed.

Opaque Pos.add.

Lemma wf_egraph_repr:
  forall g i,
    wf_egraph g ->
    (i <? counter g)%positive = true ->
    repr g i <> None.
Proof.
  intros * H1 H2 Hcontr.
  dependent induction H1. cbn in *.
  - apply Pos.ltb_lt in H2.
    lia.
  - cbn in *.
    destruct (c =? i)%positive eqn:Heq.
    apply Pos.eqb_eq in Heq as ->.
    destruct e as [[|] args | | ]; try easy.
    + destruct H as [H_1 H_2].
      enough (reduce Add (map (repr l) args) <> None); auto.
      now apply reduce_map_not_none.
    + destruct H as [H_1 H_2].
      enough (reduce Sub (map (repr l) args) <> None); auto.
      now apply reduce_map_not_none.
    + apply Pos.eqb_neq in Heq.
      apply Pos.ltb_lt in H2.
      assert (Hlt : (i <? c = true)%positive).
      apply Pos.ltb_lt. lia.
      now apply IHwf_egraph.
Qed.

Definition register (g : egraph) (e : eexpr) : egraph * positive :=
  match egraph_find g e with
  | Some (i, _) => (g, i)
  | None =>
    let lbl' := (1 + counter g)%positive in
    let lbl := counter g in
    (Build_egraph lbl' (Enode lbl e::data g), lbl)
  end.

Lemma In_find:
  forall g key exp,
    In (Enode key exp) g ->
    egraph_find g exp <> None.
Proof.
  intros.
  induction g; try easy.
  + inversion H; subst.
    simpl. now rewrite eeq_refl.
    simpl. destruct a.
    destruct eeq eqn:Heq; try easy.
    now apply IHg.
Qed.

Lemma register_wf:
  forall g,
    wf_egraph g ->
    forall g' i e,
      wf_eexpr g e ->
      register g e = (g', i) ->
      wf_egraph g'.
Proof.
  intros [c g] * H1.
  Opaque Pos.add.
  induction H1; intros * H2 H3.
  - injection H3 as <- <-.
    econstructor; auto.
    econstructor.
  - unfold register in H3.
    destruct egraph_find as [[id nd]|]eqn:Hfind.
  + injection H3 as <- <-.
    now econstructor.
  + injection H3 as <- <-. simpl in *.
    destruct eeq eqn:Heq; try easy.
    apply eeq_neq in Heq.
    repeat econstructor; auto.
    intros. inversion H3.
    * now injection H4 as -> ->.
    * intros <-. apply In_find in H4.
      now rewrite Hfind in H4.
Qed.

Lemma init_wf:
  wf_egraph (Build_egraph 1 []).
Proof.
  econstructor.
Qed.

Example test :=
  let eg := Build_egraph 1 [] in
  let '(eg, i1) := register eg (Ecst 10%Z) in
  let '(eg, i2) := register eg (Ecst 11%Z) in
  let '(eg, i3) := register eg (Eop ADD [i1; i2]) in
  let '(eg, i4) := register eg (Eop SUB [i3; i3]) in
  let '(eg, i5) := register eg (Eop SUB [i3; i3]) in
  (eg, repr eg i5).
Compute test.

Fixpoint register_aexpr (g : egraph) (e : aexpr) : egraph * positive :=
  match e with
  | Cst c => register g (Ecst c)
  | Var v => register g (Evar v)
  | Add e1 e2 =>
    let '(g, i1) := register_aexpr g e1 in
    let '(g, i2) := register_aexpr g e2 in
    register g (Eop ADD [i1; i2])
  | Sub e1 e2 =>
    let '(g, i1) := register_aexpr g e1 in
    let '(g, i2) := register_aexpr g e2 in
    register g (Eop SUB [i1; i2])
  end.

Theorem repr_find:
  forall g id,
    repr g id <> None ->
    exists exp, In (Enode id exp) g.
Proof.
  intros.
  induction g; try easy.
  - destruct a as [lbl exp]. simpl in H.
    destruct (lbl =? id)%positive eqn:Heq.
  + apply Pos.eqb_eq in Heq as ->.
    exists exp. now left.
  + specialize (IHg H) as (exp' & H').
    exists exp'. now right.
Qed.

Theorem wf_egraph_id_lt_counter:
  forall g,
    wf_egraph g ->
    Forall (fun '(Enode lbl _) => (lbl < counter g)%positive) (data g).
Proof.
  intros.
  dependent induction H.
  + econstructor.
  + econstructor; simpl in *. lia.
    apply Forall_forall. intros [key exp] Hx.
    rewrite Forall_forall in IHwf_egraph.
    specialize (IHwf_egraph (Enode key exp) Hx).
    simpl in *. lia.
Qed.

Theorem egraph_find_in:
  forall g e id nd,
    egraph_find g e = Some (id, nd) ->
    In (Enode id e) g.
Proof.
  intros.
  induction g; try easy.
  simpl in *. destruct a as [key exp].
  destruct (eeq exp e) eqn:Heq.
  - apply eeq_eq in Heq as <-.
    injection H as -> ->. now left.
  - right. auto.
Qed.

Theorem egraph_get_in:
  forall g e id id',
    egraph_get g id = Some (Enode id' e) ->
    id = id' /\ In (Enode id e) g.
Proof.
  intros.
  induction g; try easy.
  simpl in *. destruct a as [key exp].
  destruct (key =? id)%positive eqn:Heq.
  - apply Pos.eqb_eq in Heq as <-.
    injection H as -> ->. auto.
  - specialize (IHg H) as [H1 H2]. auto.
Qed.

Theorem egraph_find_correct:
  forall g e id nd,
    egraph_find g e = Some (id, nd) ->
    nd = Enode id e.
Proof.
  induction g; intros; try easy.
  simpl in *. destruct a as [key exp].
  destruct eeq eqn:Heq.
  - apply eeq_eq in Heq as <-.
    now injection H as -> ->.
  - now apply IHg in H.
Qed.

Theorem egraph_get_find:
  forall g id key exp,
    wf_egraph g ->
    egraph_get g id = Some (Enode key exp) ->
    id = key /\ egraph_find g exp = Some (id, Enode key exp).
Proof.
  intros [c g].
  induction g in c |-*; intros * Hwf Hget; try easy.
  split.
  - destruct a as [key' exp']. simpl in *.
    destruct (key' =? id)%positive eqn:Heq.
    apply Pos.eqb_eq in Heq as ->.
    now injection Hget as ->.
    inversion Hwf; subst.
    eapply IHg; eauto.
  - destruct a as [key' exp']. simpl in *.
    destruct (key' =? id)%positive eqn:Heq.
    apply Pos.eqb_eq in Heq as ->.
    injection Hget as -> ->.
    now rewrite eeq_refl.
    apply Pos.eqb_neq in Heq.
    destruct eeq eqn:Heq'.
    apply eeq_eq in Heq' as ->.
    inversion Hwf; subst.
    apply egraph_get_in in Hget as [->].
    now apply H5 in H.
    inversion Hwf; subst.
    eapply IHg; eauto.
Qed.

Inductive MonoKey : egraph' -> Prop :=
  | mono_nil  : MonoKey []
  | mono_cons l key exp :
    MonoKey l ->
    (forall key' exp', In (Enode key' exp') l -> (key > key')%positive) ->
    MonoKey (Enode key exp::l).

Inductive NoDupKey : egraph' -> Prop :=
  | no_dup_nil  : NoDupKey []
  | no_dup_cons l key exp :
    NoDupKey l ->
    (forall key' exp', In (Enode key' exp') l -> key' <> key) ->
    NoDupKey (Enode key exp::l).

Theorem mono_no_dup:
  forall g, MonoKey g -> NoDupKey g.
Proof.
  induction 1.
  + econstructor.
  + econstructor; auto.
    intros * Hin ->.
    apply H0 in Hin. lia.
Qed.

Theorem wf_egraph_no_dup_key:
  forall g,
    wf_egraph g ->
    MonoKey g.
Proof.
  intros [c g] Hwf.
  induction g in c, Hwf |-*.
  - repeat econstructor.
  - inversion Hwf; subst.
    specialize (IHg _ H2).
    inversion IHg; simpl in *; subst.
  + now econstructor.
  + repeat econstructor; auto.
    intros. inversion H2; subst.
    inversion H1.
    injection H5 as -> ->. lia.
    specialize (H0 _ _ H5). lia.
Qed.

Theorem egraph_find_get:
  forall g key1 exp1 key2 exp2,
    wf_egraph g ->
    egraph_find g exp1 = Some (key1, Enode key2 exp2) ->
    key1 = key2 /\ exp1 = exp2 /\ egraph_get g key1 = Some (Enode key1 exp1).
Proof.
  intros [c g].
  induction g in c |-*; intros * Hwf Hget; try easy.
  repeat split.
  - destruct a as [key' exp']. simpl in *.
    destruct eeq eqn:Heq.
    apply eeq_eq in Heq as ->.
    now injection Hget as ->.
    inversion Hwf; subst.
    eapply IHg; eauto.
  - destruct a as [key' exp']. simpl in *.
    destruct eeq eqn:Heq.
    apply eeq_eq in Heq as ->.
    now injection Hget as ->.
    apply egraph_find_correct in Hget.
    now injection Hget as ->.
  - destruct a as [key' exp']. simpl in *.
    destruct (key' =? key1)%positive eqn:Heq.
    apply Pos.eqb_eq in Heq as ->.
    destruct eeq eqn:Heq.
    apply eeq_eq in Heq as ->.
    now injection Hget as ->.
    apply wf_egraph_no_dup_key in Hwf.
    inversion Hwf; subst.
    apply egraph_find_in in Hget.
    specialize (H3 _ _ Hget). lia.
    destruct eeq eqn:Heq'.
    injection Hget as -> ->.
    now rewrite Pos.eqb_neq in Heq.
    inversion Hwf; subst.
    eapply IHg; eauto.
Qed.

Theorem register_mono':
  forall e g g' i,
    wf_egraph g ->
    register g e = (g', i) ->
    (i < counter g')%positive.
Proof.
  intros * H1 H2.
  unfold register in H2.
  destruct egraph_find as [[id nd]|] eqn:Heq.
  - injection H2 as <- <-.
    apply egraph_find_in in Heq.
    pose proof (wf_egraph_id_lt_counter _ H1).
    rewrite Forall_forall in H.
    apply (H _ Heq).
  - injection H2 as <- <-. simpl.
    lia.
Qed.

Theorem register_mono:
  forall e g g' i,
    register g e = (g', i) ->
    (counter g <= counter g')%positive.
Proof.
  intros * H.
  induction e; intros.
  - unfold register in H.
    destruct egraph_find as [[id nd]|].
    injection H as <- <-. lia.
    injection H as <- <-. simpl. lia.
  - unfold register in H.
    destruct egraph_find as [[id nd]|].
    injection H as <- <-. lia.
    injection H as <- <-. simpl. lia.
  - unfold register in H.
    destruct egraph_find as [[id nd]|].
    injection H as <- <-. lia.
    injection H as <- <-. simpl. lia.
Qed.

Theorem register_aexpr_mono':
  forall e g g' i,
    register_aexpr g e = (g', i) ->
    (counter g <= counter g')%positive.
Proof.
  induction e; intros.
  - simpl in H. unfold register in H.
    destruct egraph_find as [[id nd]|] eqn:Heq.
    injection H as -> ->. lia.
    injection H as <- <-. simpl. lia.
  - simpl in H. unfold register in H.
    destruct egraph_find as [[id nd]|] eqn:Heq.
    injection H as -> ->. lia.
    injection H as <- <-. simpl. lia.
  - simpl in H.
    destruct (register_aexpr g e1) as [g1 i1] eqn:Heq1.
    destruct (register_aexpr g1 e2) as [g2 i2] eqn:Heq2.
    specialize (IHe1 g g1 i1 Heq1).
    specialize (IHe2 g1 g2 i2 Heq2).
    apply register_mono in H.
    lia.
  - simpl in H.
    destruct (register_aexpr g e1) as [g1 i1] eqn:Heq1.
    destruct (register_aexpr g1 e2) as [g2 i2] eqn:Heq2.
    specialize (IHe1 g g1 i1 Heq1).
    specialize (IHe2 g1 g2 i2 Heq2).
    apply register_mono in H.
    lia.
Qed.

Theorem register_aexpr_wf:
  forall e g g' i,
    wf_egraph g ->
    register_aexpr g e = (g', i) ->
    wf_egraph g' /\ (i < counter g')%positive.
Proof.
  induction e; intros [c g] * H1 H2.
  - split.
  + eapply register_wf; eauto. econstructor.
  + simpl in H2. eapply register_mono'; eauto.
  - split.
  + eapply register_wf; eauto. econstructor.
  + simpl in H2. eapply register_mono'; eauto.
  - simpl in H2.
    destruct (register_aexpr _ e1) as [g1 i1] eqn:Heq1.
    destruct (register_aexpr _ e2) as [g2 i2] eqn:Heq2.
    pose proof (IHe1 _ _ _ H1 Heq1) as [Hwf1_1 Hwf1_2].
    pose proof (IHe2 _ _ _ Hwf1_1 Heq2) as [Hwf2_1 Hwf2_2].
    split.
    eapply register_wf; eauto.
    econstructor; try easy.
    repeat econstructor; try easy.
    apply wf_egraph_repr; auto.
    apply Pos.ltb_lt.
    eapply Pos.lt_le_trans; eauto.
    eapply register_aexpr_mono'; eauto.
    apply wf_egraph_repr; auto.
    apply Pos.ltb_lt.
    eapply Pos.lt_le_trans; eauto.
    reflexivity.
    eapply register_mono'; eauto.
  - simpl in H2.
    destruct (register_aexpr _ e1) as [g1 i1] eqn:Heq1.
    destruct (register_aexpr _ e2) as [g2 i2] eqn:Heq2.
    pose proof (IHe1 _ _ _ H1 Heq1) as [Hwf1_1 Hwf1_2].
    pose proof (IHe2 _ _ _ Hwf1_1 Heq2) as [Hwf2_1 Hwf2_2].
    split.
    eapply register_wf; eauto.
    econstructor; try easy.
    repeat econstructor; try easy.
    apply wf_egraph_repr; auto.
    apply Pos.ltb_lt.
    eapply Pos.lt_le_trans; eauto.
    eapply register_aexpr_mono'; eauto.
    apply wf_egraph_repr; auto.
    apply Pos.ltb_lt.
    eapply Pos.lt_le_trans; eauto.
    reflexivity.
    eapply register_mono'; eauto.
Qed.

Theorem register_correct_1:
  forall e g,
    wf_egraph g ->
    let '(g', i) := register g e in
    egraph_get g' i = Some (Enode i e).
Proof.
  intros.
  unfold register.
  destruct egraph_find as [[id nd]|]eqn:Heq.
  + rewrite (egraph_find_correct _ _ _ _ Heq) in Heq.
    eapply egraph_find_get; eauto.
  + simpl. now rewrite Pos.eqb_refl.
Qed.

Theorem egraph_repr_evar:
  forall g v,
    wf_egraph g ->
    let '(g', i) := register_aexpr g (Var v) in
    repr g' i = Some (Var v).
Proof.
  intros [c g] * Hwf.
  unfold register_aexpr, register.
  destruct egraph_find as [[id nd]|]eqn:Hfind.
  - simpl in *.
   induction g in c, id, nd, Hfind, Hwf |-*; try easy.
    destruct a as [key' exp']. simpl in Hfind.
    destruct eeq eqn:Heq.
    + apply eeq_eq in Heq as ->.
      injection Hfind as ->. simpl.
      now rewrite Pos.eqb_refl.
    + apply eeq_neq in Heq.
      destruct nd as [key exp].
      rewrite (egraph_find_correct _ _ _ _ Hfind) in Hfind.

    destruct (key' =? id)%positive eqn:Heq'.
      apply Pos.eqb_eq in Heq' as ->.
      destruct exp'.

Theorem egraph_correct:
  forall e g,
    wf_egraph g ->
    let '(g', i) := register_aexpr g e in
    repr g' i = Some e.
Proof.
  induction e; intros.
  - simpl. unfold register.
    destruct egraph_find as [[id nd]|]eqn:Heq.
  + destruct g as [c g]. simpl in *.
    rewrite (egraph_find_correct _ _ _ _ Heq) in Heq.
    induction g as [|[key exp] g IH]; try easy.
    simpl in *.
    destruct eeq in Heq.
    injection Heq as _ -> ->.
    now rewrite Pos.eqb_refl.
    destruct (key =? id)%positive eqn:Heq2.
    apply Pos.eqb_eq in Heq2 as ->.
    apply wf_egraph_no_dup_key in H.
    inversion H; subst.
    apply egraph_find_in in Heq.
    apply H4 in Heq. lia.
    inversion H; subst.
    apply IH; auto.

    destruct eeq eqn:Heq1.
    apply eeq_eq in Heq1 as ->.
    now rewrite Pos.eqb_refl.
    destruct exp.

  admit. (* by lemma egraph_find <-> repr *)
  + simpl. now rewrite Pos.eqb_refl.
  - simpl. unfold register.
    destruct egraph_find as [[id nd]|]eqn:Heq.
  + admit. (* by lemma egraph_find <-> repr *)
  + simpl. now rewrite Pos.eqb_refl.
  - simpl. do 2 unfold register.
    destruct (register_aexpr g e1) as [g1 i1] eqn:Heq1.
    destruct (register_aexpr g1 e2) as [g2 i2] eqn:Heq2.
    destruct egraph_find as [[id nd]|]eqn:Heq.
  + pose proof (register_wf g H).
    specialize (IHe1 g H).
    rewrite Heq1 in IHe1.
    specialize (IHe2 g1).


Require Import maps.
Require Import patterns.

Set Implicit Arguments.

Lemma emptyP_expose : forall {Key Val} (h : Map Key Val),
  h |= mapEmpty <-> h ~= mapEmpty.
reflexivity.
Qed.
Lemma itemP_expose : forall {Key Val} (h : Map Key Val) k v,
  h |= itemP k v <-> h ~= k |-> v.
reflexivity.
Qed.
Lemma litP_expose : forall {Key Val} (h : Map Key Val) h',
  h |= litP h' <-> h ~= h'.
reflexivity.
Qed.
Lemma constraint_expose : forall {Key Val} (h : Map Key Val) P,
  h |= constraint P <-> (P /\ h ~= mapEmpty).
reflexivity.
Qed.

(* Try to eliminate a hypothesis H : h ~= _
   by rewriting with it everywhere, unless
   it appears in the conclusion
   (in the conclusion it's likely to be
    stuck under something we don't know
    how to rewrite under, and in that condition
    a rewrite can waste a second or two figuring
    out it is going to fail)
 *)
Ltac try_subst_map h H :=
  match goal with
  | [|- context C [h]] => idtac
  | _ => rewrite ?H in * |- *; clear h H
  end.

(* Find a hypothesis where a pattern has some explicit
   map structure, and break it down into a map
   equality and maybe some simpler patterns *)
Ltac simplify_pat_hyp := match goal with
| [H : ?h |= exP _ |- _ ] => destruct H
| [H : ?h |= asP _ _ |- _] =>
    let Heq := fresh "Heq" in
    destruct H as [Heq];try_subst_map h Heq
| [H : ?h |= emptyP |- _] =>
  rewrite emptyP_expose in H;try_subst_map h H
| [H : ?h |= itemP _ _ |- _] =>
  rewrite itemP_expose in H;try_subst_map h H
| [H : ?h |= litP _ |- _] =>
  rewrite litP_expose in H;try_subst_map h H
| [H : ?h |= constraint _ |- _] =>
  let Heq := fresh "Heq" in
  destruct H as [? Heq];try_subst_map h Heq
| [H : ?h |= _ :* _ |- _] =>
  let Heq := fresh "Heq" in
  destruct H as (? & ? & ? & ? & Heq);try_subst_map h Heq
end.

(* Simplify all pattern hypotheses, then clean
   up any empty maps and mis-associated terms that
   might be left in map equalities *)
Ltac simplify_pat_hyps := repeat simplify_pat_hyp;
  rewrite ?@equivAssoc, ?@equivUnitL, ?@equivUnit  in * |- .


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall B C D T Bprime Bprimeprime X Y : Universe, ((wd_ B C /\ (wd_ B D /\ (wd_ B T /\ (wd_ C D /\ (wd_ C T /\ (wd_ D T /\ (wd_ B Bprime /\ (wd_ Bprimeprime T /\ (wd_ X T /\ (wd_ T Y /\ (wd_ X Y /\ (wd_ Bprimeprime X /\ (wd_ Y C /\ (wd_ Y D /\ (wd_ X B /\ (wd_ X D /\ (col_ B Bprime D /\ (col_ T Bprimeprime Y /\ (col_ Bprimeprime T X /\ col_ B D C))))))))))))))))))) -> col_ X T Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC Cprime Bprime BCprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Bprime O /\ (wd_ BC O /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime Cprime /\ (col_ O Eprime Bprime /\ col_ O Eprime BCprime))))))))))))))))) -> col_ O B BC)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O X Y L M N P : Universe, ((wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Aprime O /\ (wd_ Cprime O /\ (wd_ X Y /\ (wd_ A L /\ (wd_ A M /\ (wd_ L Aprime /\ (wd_ A N /\ (wd_ B P /\ (wd_ A P /\ (wd_ M P /\ (wd_ O P /\ (wd_ P N /\ (wd_ Aprime A /\ (wd_ A B /\ (wd_ Aprime B /\ (wd_ Bprime A /\ (wd_ Bprime B /\ (wd_ Aprime Cprime /\ (wd_ Aprime Bprime /\ (wd_ A Cprime /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A C /\ (wd_ Aprime C /\ (wd_ L O /\ (wd_ L Bprime /\ (wd_ C Cprime /\ (wd_ O N /\ (col_ O A Aprime /\ (col_ O B Bprime /\ (col_ O C Cprime /\ (col_ A X Y /\ (col_ L X Y /\ (col_ L Aprime Cprime /\ (col_ M X Y /\ (col_ M O C /\ (col_ N A B /\ (col_ N L Bprime /\ (col_ P A N /\ (col_ P O C /\ col_ P N C)))))))))))))))))))))))))))))))))))))))))))) -> col_ N A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P T Y X : Universe, ((wd_ P T /\ (wd_ X Y /\ (wd_ P Y /\ (wd_ P X /\ (wd_ B T /\ (wd_ B P /\ (wd_ A B /\ (wd_ X B /\ (wd_ A C /\ (wd_ C B /\ (wd_ Y B /\ (col_ T P Y /\ (col_ P Y X /\ (col_ B A X /\ col_ B C Y)))))))))))))) -> col_ T P X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
(*Require Import UniMath.RezkCompletion.Monads.*)
Require Import UniMath.RezkCompletion.limits.products.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import UniMath.RezkCompletion.limits.terminal.
Require Import UniMath.RezkCompletion.limits.initial.
Require Import UniMath.RezkCompletion.FunctorAlgebras.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
(*Require Import SubstSystems.HorizontalComposition.*)
(*Require Import SubstSystems.PointedFunctorsComposition.*)
Require Import SubstSystems.Signatures.
(* Require Import SubstSystems.SubstitutionSystems. *)
Require Import SubstSystems.FunctorsPointwiseCoproduct.
Require Import SubstSystems.FunctorsPointwiseProduct.
Require Import SubstSystems.EndofunctorsMonoidal.
Require Import SubstSystems.SumOfSignatures.
Require Import SubstSystems.SubstitutionSystems.
Require Import SubstSystems.LamSignature.
Require Import SubstSystems.LiftingInitial.
Require Import SubstSystems.MonadsFromSubstitutionSystems.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
(*Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).*)
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).
Local Notation "C ⟦ a , b ⟧" := (precategory_morphisms (C:=C) a b) (at level 50).
Local Notation "` T" := (alg_carrier _ _ T) (at level 3).
Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).

Arguments θ_source {_ _} _ .
Arguments θ_target {_ _} _ .
Arguments θ_Strength1 {_ _ _} _ .
Arguments θ_Strength2 {_ _ _} _ .

Section Lambda.

Variable C : precategory.
Variable hs : has_homsets C.

(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C, hs]) .

Variable terminal : Terminal C.

Variable CC : Coproducts C.
Variable CP : Products C.

Local Notation "'EndC'":= ([C, C, hs]) .
Local Notation "'Ptd'" := (precategory_Ptd C hs).
Local Notation "'U'" := (functor_ptd_forget C hs).

Let hsEndC : has_homsets EndC := functor_category_has_homsets C C hs.
Let CPEndC : Coproducts EndC := Coproducts_functor_precat _ _ CC hs.
Let EndEndC := [EndC, EndC, hsEndC].
Let CPEndEndC:= Coproducts_functor_precat _ _ CPEndC hsEndC: Coproducts EndEndC.

Local Notation "'ℓ'" := (pre_composition_functor_data _ _ _ _ _ ).

Local Notation "'τ'" := (tau_from_alg _ _ _ _ ).

Let one : C :=  @TerminalObject C terminal.

Variable KanExt : ∀ Z : precategory_Ptd C hs,
   RightKanExtension.GlobalRightKanExtensionExists C C
     (U Z) C hs hs.

Let Lam_S : Signature _ _ := Lam_Sig C hs terminal CC CP.
Let LamE_S : Signature _ _ := LamE_Sig C hs terminal CC CP.

(* assume initial algebra for signature Lam *)

Variable Lam_Initial : Initial
     (precategory_FunctorAlg ([C, C] hs)
                             (Id_H C hs CC Lam_S) hsEndC).

Let Lam := InitialObject _ Lam_Initial.

(* bracket for Lam from the initial hss obtained via theorem 15+ *)

Definition LamHSS_Initial : Initial (hss_precategory CC Lam_S).
Proof.
  apply Ihss.
  - apply KanExt.
  - apply Lam_Initial.
Defined.
Let LamHSS := InitialObject _ LamHSS_Initial.

(* extract constructors *)

Definition Lam_Var : EndC ⟦functor_identity C, `Lam ⟧.
Proof.
  exact (CoproductIn1 _ _ ;; alg_map _ _ Lam).
Defined.

(* we later prefer leaving App and Abs bundled in the definition of LamE_algebra_on_Lam *)

Definition Lam_App : [C, C] hs ⟦ (App_H C hs CP) `Lam , `Lam ⟧.
Proof.
  exact (CoproductIn1 _ _ ;; (CoproductIn2 _ _ ;; alg_map _ _ Lam)).
Defined.

Definition Lam_Abs : [C, C] hs ⟦ (Abs_H C hs terminal CC) `Lam, `Lam ⟧.
Proof.
  exact (CoproductIn2 _ _ ;; (CoproductIn2 _ _ ;; alg_map _ _ Lam)).
Defined.

Definition Lam_App_Abs :  [C, C] hs
   ⟦ (H C hs CC (App_H C hs CP) (Abs_H C hs terminal CC)) `Lam , `Lam ⟧.
Proof.
  exact (CoproductIn2 _ _ ;; alg_map _ _ Lam).
Defined.

(* we need a flattening in order to get a model for LamE *)

Definition Lam_Flatten :
  [C, C] hs ⟦ (Flat_H C hs) `Lam , `Lam ⟧.
Proof.
  exact (fbracket LamHSS (identity _ )).
Defined.

(* now get a LamE-algebra *)

Definition LamE_algebra_on_Lam : precategory_FunctorAlg _ (Id_H _ _ CC LamE_S) hsEndC.
Proof.
  exists ((*ob_from_algebra_ob _ _*) `Lam).
  refine (CoproductArrow _ (CPEndC _ _ )  _ _ ) .
  + exact Lam_Var.
  + refine (CoproductArrow _ (CPEndC _ _ )  _ _ ).
    * apply Lam_App_Abs. (* do NOT destruct and reassemble more, use App_Abs directly *)
    * apply Lam_Flatten.
Defined.

Lemma τ_LamE_algebra_on_Lam : τ LamE_algebra_on_Lam =
                              CoproductArrow _ (CPEndC _ _ ) Lam_App_Abs Lam_Flatten.
Proof.
  apply CoproductIn2Commutes.
Defined.

(* now define bracket operation for a given [Z] and [f] *)

(* preparations for typedness *)
Definition bla': (ptd_from_alg_functor C hs CC LamE_S LamE_algebra_on_Lam) ⇒ (ptd_from_alg_functor C hs CC _ Lam).
Proof.
  refine (tpair _ _ _ ).
    + apply (nat_trans_id _ ).
    + abstract
        (intro c; rewrite id_right (* should be opaque *)
         ; apply CoproductIn1Commutes_left_dir;
         apply idpath).
Defined.

Definition bla'_inv: (ptd_from_alg_functor C hs CC _ Lam) ⇒ (ptd_from_alg_functor C hs CC LamE_S LamE_algebra_on_Lam).
Proof.
  refine (tpair _ _ _ ).
    + apply (nat_trans_id _ ).
    + abstract
        (intro c; rewrite id_right ; (* should be opaque *)
         apply CoproductIn1Commutes_right_dir;
         apply idpath) .
Defined.

(* this iso does nothing, but is needed to make the argument to [fbracket] below well-typed *)
(* maybe a better definition somewhere above could make this iso superfluous *)
(* maybe don't need iso, but only morphism *)
Definition bla : iso (ptd_from_alg_functor C hs CC LamE_S LamE_algebra_on_Lam) (ptd_from_alg_functor C hs CC _ Lam).
Proof.
  unfold iso.
  exists bla'.
  apply is_iso_from_is_z_iso.
  exists bla'_inv.
  abstract (
   split; [
    apply (invmap (eq_ptd_mor _ hs _ _));
    apply nat_trans_eq; try (exact hs) ;
    intro c ;
    apply id_left
                   |
    apply eq_ptd_mor_precat; (* idem *)
    apply (invmap (eq_ptd_mor _ hs _ _)) ;
    apply nat_trans_eq; try (exact hs) ;
    intro c ;
    apply id_left ]
           ).
Defined.

(* A simple but important lemma *)

Definition fbracket_for_LamE_algebra_on_Lam (Z : Ptd)
   (f : Ptd ⟦ Z, ptd_from_alg_functor C hs CC LamE_S LamE_algebra_on_Lam ⟧ ) :
   [C, C] hs
   ⟦ functor_composite (U Z) `LamE_algebra_on_Lam, `LamE_algebra_on_Lam ⟧ .
Proof.
  exact (fbracket LamHSS (f ;; bla)).
Defined.

Lemma bracket_property_for_LamE_algebra_on_Lam (Z : Ptd)
  (f : Ptd ⟦ Z, ptd_from_alg C hs CC LamE_S LamE_algebra_on_Lam ⟧)
 :
   bracket_property C hs CC LamE_S LamE_algebra_on_Lam f
                    (fbracket_for_LamE_algebra_on_Lam Z f).
Proof.
  (* Could we have this in a more declarative style? *)
  assert (Hyp := pr2 (pr1 (pr2 LamHSS _ (f;; bla)))).

  apply parts_from_whole in Hyp.
  apply whole_from_parts.
  split.
  + (* the "easy" eta part *)
    apply pr1 in Hyp.
    apply (maponpaths (fun x => x;; #U (inv_from_iso bla))) in Hyp.
    rewrite <- functor_comp in Hyp.
    rewrite <- assoc in Hyp.
    rewrite iso_inv_after_iso in Hyp.
    rewrite id_right in Hyp.
    eapply pathscomp0.
      exact Hyp.
    clear Hyp.
    fold (fbracket LamHSS (f ;; bla)).
    unfold fbracket_for_LamE_algebra_on_Lam.
    match goal with |[ |- _;; _ ;; ?h = _  ] =>
         assert (idness : h = nat_trans_id _) end.
      apply nat_trans_eq; try (exact hs).
      intro c.
      unfold functor_ptd_forget.
      simpl.
      apply id_left.
    rewrite idness. clear idness.
    rewrite id_right.
    (* does not work:
       apply cancel_postcomposition.
       although the terms are of identical type:
    match goal with | [ |- _ ;; ?l = _ ] => let ty:= (type of l) in idtac ty end.
(*
([C, C] hs
 ⟦ functor_composite (U Z) (functor_from_algebra_ob C hs CC Lam_S LamHSS)
   :[C, C] hs, LamHSS ⟧)
*)
    match goal with | [ |- _ = _ ;; ?l ] => let ty:= (type of l) in idtac ty end.
(*
([C, C] hs
 ⟦ functor_composite (U Z) (functor_from_algebra_ob C hs CC Lam_S LamHSS)
   :[C, C] hs, LamHSS ⟧)
*)
*)
    apply nat_trans_eq; try (exact hs).
    intro c.
    apply cancel_postcomposition.
    apply CoproductIn1Commutes_right_dir.
    apply idpath.
    (* this proof did not work with pointedness but with brute force *)
  + (* now the difficult case of the domain-specific constructors *)
    destruct Hyp as [_ Hyp2].
    fold (fbracket LamHSS (f ;; bla)) in Hyp2.
    unfold fbracket_for_LamE_algebra_on_Lam.
    apply nat_trans_eq; try (exact hs).
    intro c.

    (* from here slightly interesting, because it is crucial to see that
       the τ considered here is a Coproduct arrow *)

    rewrite τ_LamE_algebra_on_Lam.
    eapply pathscomp0; [apply cancel_postcomposition ; apply CoproductOfArrows_comp | ].
    idtac.
    eapply pathscomp0.
    apply precompWithCoproductArrow.
    apply pathsinv0.

    (* showing that a diagram of coproduct arrows splits into two is slightly cumbersome,
       but a general theorem seems difficult to formulate

       instead we apply [CoproductArrowUnique] and then use the coproduct beta laws in
       each branch; this gives precisely what we want *)

    apply CoproductArrowUnique.
  - eapply pathscomp0. apply assoc.
    eapply pathscomp0.
    apply cancel_postcomposition. apply CoproductIn1Commutes.
    assert (T:= nat_trans_eq_pointwise _ _ _ _ _ _ Hyp2 c).
    clear Hyp2.
    match goal with | [H : ?e = _ |- _ ] => transitivity e end.
    Focus 2. apply idpath.

    match goal with | [H : _ = ?f |- _ ] => transitivity f end.
    Focus 1. apply idpath.
    apply pathsinv0. assumption.

    (* There should be a more general hypothesis than 'Hyp' defined above,
       one where one has a quantification over maps 'f', no? *)

  - clear Hyp2.
    eapply pathscomp0. apply assoc.
    eapply pathscomp0.
    apply cancel_postcomposition. apply CoproductIn2Commutes.
    unfold Lam_Flatten.
    (* now we have the equation that is mentioned in the documents *)

    (* maybe make a better writeup of the proof before proceeding here ?*)

    (* from here on not sure how to proceed, but 'simpl' is feasible
       after some opacification, at least *)
    Opaque fbracket.
    Opaque LamHSS.
    set (X:= f ;; bla).

    assert (TT:=compute_fbracket C hs CC Lam_S LamHSS(Z:=Z)).
    simpl in *.
    assert (T3 := TT  X).
    clear TT.
    unfold X; unfold X in T3; clear X.
    rewrite id_left.
    rewrite id_left.
    rewrite id_left.

    Local Notation "⦃ f ⦄" := (fbracket _ f)(at level 0).
    (* written '\{{' and '\}}', respectively *)

    set (Tη := ptd_from_alg C hs CC Lam_S _ ).

    rewrite functor_id.
    rewrite functor_id.
    rewrite id_right.
    destruct Z as [Z e]. simpl in *.
    set (T := ` Lam).

    (* now we want to rewrite with T3 in 3 places *)

    assert (T3':= nat_trans_eq_pointwise _ _ _ _ _ _ T3 c).
    simpl in *.
    match goal with |[ T3' : _ = ?f |- ?a ;; _ = _ ] => transitivity (a ;; f) end.
    { apply maponpaths. apply T3'. }

    repeat rewrite assoc.
(*
    apply cancel_postcomposition. (* that's a bad idea, because it fucks up use of third monad law *)
*)

    match goal with |[ T3' : _ = ?f |- _ = ?a ;; ?b ;; _ ;; ?d  ] => transitivity (a ;; b ;; #T f ;; d) end.
    Focus 2.  apply cancel_postcomposition. apply maponpaths. apply maponpaths. apply (!T3').
    clear T3'.

    apply pathsinv0.

    assert (T3':= nat_trans_eq_pointwise _ _ _ _ _ _ T3 (T (Z c))).

    eapply pathscomp0. apply cancel_postcomposition. apply cancel_postcomposition.
                       apply maponpaths. apply T3'.

    clear T3'.
    apply pathsinv0.

    destruct f as [f fptdmor]. simpl in *.
    simpl.

    rewrite id_right.
    rewrite id_right.

    repeat rewrite assoc.

    assert (X := fptdmor (T (Z c))). clear T3 fptdmor.
    assert (X' := maponpaths (#T) X).
    rewrite functor_comp in X'.

    apply pathsinv0.
    eapply pathscomp0. apply cancel_postcomposition. apply cancel_postcomposition.
                       apply cancel_postcomposition. apply X'.
                       clear X'.

    clear X.

    assert (X := Monad_law_2_from_hss _ _ CC Lam_S LamHSS (T (Z c))).
    unfold μ_0 in X. unfold μ_2 in X.

    match goal with |[ X : ?e = _ |- ?a ;; ?b ;; _ ;; _  = _ ] =>
                     assert (X' : e = a ;; b) end.
    { apply cancel_postcomposition. apply maponpaths.
      simpl.
      unfold coproduct_nat_trans_in1_data. simpl.
      repeat rewrite  assoc.
      unfold coproduct_nat_trans_data.
      apply pathsinv0. eapply pathscomp0. apply CoproductIn1Commutes.
      apply idpath. }

    rewrite X' in X. clear X'.

    eapply pathscomp0. apply cancel_postcomposition. apply cancel_postcomposition. apply X. clear X.

    rewrite id_left.

    assert (μ_2_nat := nat_trans_ax (μ_2 C hs CC Lam_S LamHSS)).
    assert (X := μ_2_nat _ _ (f c)).
    unfold μ_2 in X.

    eapply pathscomp0. Focus 2. apply cancel_postcomposition. apply X. clear X.

    rewrite functor_comp.
    repeat rewrite <- assoc.
    apply maponpaths.

    assert (X := third_monad_law_from_hss _ _ CC Lam_S LamHSS).
    assert (X' := nat_trans_eq_pointwise _ _ _ _ _ _ X). clear X.
    simpl in X'.

    eapply pathscomp0. apply X'.

    rewrite id_left. apply idpath.

 (*
    Check θ.
    Arguments θ {_ _ _ _ _ } _ _ .
    idtac.
    Opaque θ.
    Opaque fbracket.
    simpl.
    unfold coproduct_nat_trans_in2_data.

    unfold Flat_H. simpl.

    simpl.

    unfold coproduct_nat_trans_data. simpl.
    unfold coproduct_nat_trans_in1_data.
    unfold product_nat_trans_data.

    simpl.

    rewrite assoc.

    unfold bla1.

    rewrite id_left.

    unfold coproduct_nat_trans_data. simpl.
*)

(*
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    apply CoproductArrow_eq_cor.
    simpl.
    repeat rewrite <- assoc.
    apply CoproductIn1Commutes_left_in_ctx_dir.

    unfold LamE_S. unfold LamE_Sig.

(*
  match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end.
  match goal with | [ H1: ?l = _ |- _] => let ty:= (type of l) in idtac ty end.
*)

 *)

Qed.

Lemma bracket_for_LamE_algebra_on_Lam_unique (Z : Ptd)
  (f : Ptd ⟦ Z, ptd_from_alg C hs CC LamE_S LamE_algebra_on_Lam ⟧)
 :
   ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z)
               (` LamE_algebra_on_Lam),
           `LamE_algebra_on_Lam ⟧,
       bracket_property C hs CC LamE_S LamE_algebra_on_Lam f h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z)
                (` LamE_algebra_on_Lam),
            `LamE_algebra_on_Lam ⟧,
      bracket_property C hs CC LamE_S LamE_algebra_on_Lam f h)
     (fbracket_for_LamE_algebra_on_Lam Z f) (bracket_property_for_LamE_algebra_on_Lam Z f).
Proof.
  intro t.
  apply total2_paths_second_isaprop.
  apply isaset_nat_trans. apply hs.
  simpl.
  destruct t as [t Ht]; simpl.
  unfold fbracket_for_LamE_algebra_on_Lam.
  apply (fbracket_unique LamHSS).
  split.
  -  apply parts_from_whole in Ht. destruct Ht as [H1 _].
     apply nat_trans_eq; try assumption.
     intro c.
     assert (HT:=nat_trans_eq_pointwise _ _ _ _ _ _ H1 c).
     simpl.
     rewrite id_right.
     match goal with |[ H : _ = ?a |- _ ] => transitivity a end.
     + apply HT.
     + simpl. repeat rewrite assoc. apply cancel_postcomposition.
       repeat rewrite <- assoc.
       unfold coproduct_nat_trans_in1_data.
       unfold coproduct_nat_trans_data.
       eapply pathscomp0. apply CoproductIn1Commutes.
       apply idpath.
  - apply parts_from_whole in Ht. destruct Ht as [_ H2].
     apply nat_trans_eq; try assumption.
     intro c.
     assert (HT := nat_trans_eq_pointwise _ _ _ _ _ _ H2 c).
     match goal with |[H2 : ?e = ?f |- _ ] =>
                         assert (X: CoproductIn1 _ _ ;; e = CoproductIn1 _ _ ;; f) end.
     { apply maponpaths . assumption. }
     clear HT. clear H2.

     match goal with |[X : _ = ?f |- _ ] => transitivity f end.
     Focus 2. rewrite τ_LamE_algebra_on_Lam.
     eapply pathscomp0. apply assoc.
     eapply pathscomp0. apply cancel_postcomposition. apply CoproductIn1Commutes.
     apply idpath.

     match goal with |[X : ?e = _ |- _ ] => transitivity e end.
     Focus 2. apply X.

     rewrite τ_LamE_algebra_on_Lam.

     apply pathsinv0.
     eapply pathscomp0. apply assoc.
     eapply pathscomp0.
     apply cancel_postcomposition. apply assoc.
     eapply pathscomp0.
     apply cancel_postcomposition.
     apply cancel_postcomposition.
     apply CoproductIn1Commutes.

     repeat rewrite <- assoc.

     eapply pathscomp0. apply maponpaths.
     apply assoc.

     eapply pathscomp0. apply maponpaths. apply cancel_postcomposition.
     apply CoproductIn1Commutes.

     eapply pathscomp0. apply maponpaths. apply (!assoc _ _ _ _ _ _ _ _ ).
     eapply pathscomp0. apply maponpaths. apply maponpaths.
     apply CoproductIn1Commutes.
     apply idpath.
Qed.

Definition bracket_for_LamE_algebra_on_Lam_at (Z : Ptd)
  (f : Ptd ⟦ Z, ptd_from_alg C hs CC LamE_S LamE_algebra_on_Lam ⟧)
  :
    bracket_at C hs CC LamE_S LamE_algebra_on_Lam f.
Proof.
  refine (tpair _ _ _ ).
  - exists (fbracket_for_LamE_algebra_on_Lam Z f).
    apply (bracket_property_for_LamE_algebra_on_Lam Z f).
  - apply bracket_for_LamE_algebra_on_Lam_unique.
Defined.

Definition bracket_for_LamE_algebra_on_Lam : bracket C hs CC LamE_S LamE_algebra_on_Lam.
Proof.
  intros Z f.
  simpl.
  apply bracket_for_LamE_algebra_on_Lam_at.
Defined.

Definition LamE_model_on_Lam : hss CC LamE_S.
Proof.
  exists LamE_algebra_on_Lam.
  exact bracket_for_LamE_algebra_on_Lam.
Defined.

(* assume initial algebra for signature LamE *)

Variable  LamE_Initial : Initial
     (precategory_FunctorAlg ([C, C] hs)
        (Id_H C hs CC LamE_S) hsEndC).

Definition LamEHSS_Initial : Initial (hss_precategory CC LamE_S).
Proof.
  apply  Ihss.
  - apply KanExt.
  - apply LamE_Initial.
Defined.
Let LamEHSS := InitialObject _ LamEHSS_Initial.

Definition FLATTEN : (hss_precategory CC LamE_S) ⟦LamEHSS, LamE_model_on_Lam⟧
  := InitialArrow _ _ _ .

End Lambda.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj15eqsynthconj3 : forall  (lv0 : lst), (@eq natural (len lv0) (len (append Nil (append Nil lv0)))).
Admitted.
QuickChick conj15eqsynthconj3.


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

(* This type is from VST: https://github.com/PrincetonUniversity/VST/blob/v2.1/floyd/compact_prod_sum.v#L6 *)
Fixpoint compact_prod (T: list Type): Type :=
  match T with
  | nil => unit
  | t :: nil => t
  | t :: T0 => (t * compact_prod T0)%type
  end.

(* The rest is a nonsensical, just to give a minimalistic reproducible example *)
Inductive Foo :=
| Foo1 : list Foo -> Foo
| Foo2 : list Foo -> Foo.

Equations foo_type (t : Foo) : Type :=
  foo_type (Foo1 fs) := compact_prod (List.map foo_type fs);
  foo_type (Foo2 fs) := compact_prod (List.map foo_type fs).
Transparent foo_type.

(* Moving val nato the return type, rather than having it as an argument might be unnecessary if
   https://github.com/mattam82/Coq-Equations/issues/73 was fixed *)
(* Set Equations Debug. *)

Equations do_foo (t : Foo) : forall (val : foo_type t), nat := {
  do_foo (Foo1 fs) := fun val => do_foo1 fs val;
  do_foo (Foo2 fs) := fun val => do_foo2 fs val }

where do_foo1 (fs:list Foo) : forall (val : compact_prod (map foo_type fs)), nat
 (* by struct fs *) := {
    do_foo1 nil := fun val => 0;
    (* do_foo1 (cons hd nil) := fun val => do_foo hd val; *)
    (* do_foo1 (cons hd tl) := fun val => 0 } *)
    (* Attempting to work around https://github.com/mattam82/Coq-Equations/issues/78 *)
    do_foo1 (cons hd tl) with (fun val => do_foo1 tl val) => {
      do_foo1 (cons hd nil) _ := fun val => do_foo hd val;
      do_foo1 (cons hd _) do_foo_tl := fun val =>
        (do_foo hd (fst val)) + (do_foo_tl (snd val))}}

where do_foo2 (fs : list Foo) : forall val : compact_prod (List.map foo_type fs), nat
 by struct fs := {
    do_foo2 nil := fun val => 0;
    do_foo2 (cons var nil) :=
      fun val => do_foo var val;
    do_foo2 _ := fun val => 0 }.


(** * Soudness *)

(* begin hide *)
Require Import Brenner.ResourceDependency.
Require Import Brenner.Semantics.
Require Aniceto.Graphs.FGraph.
Module F := Aniceto.Graphs.FGraph.
Require Import Aniceto.Graphs.Graph.
Require Import Brenner.Vars.
Require Import Brenner.Syntax.
Require Import Aniceto.Pair.
Import Map_TID_Extra.
(* end hide *)
(**
  The property of soundness ensures the absense of false positives,
  that is, soundness entails that if we find a cycle in the WFG of
  a given state, then such state is deadlocked.
  The proof follows by first showing soundness on totally deadlocked states.

 *)

(** ** Soundness for totally deadlocked states *)

Section Basic.

  (** Let [s] be a state. *)

  Variable s:state.

(* begin hide *)

Lemma tedge_inv:
  forall w t t',
  TWalk s w ->
  F.Edge w (t, t') ->
  exists e,
  WaitOn s t e /\ ImpededBy s e t'.
Proof.
  intros.
  apply in_edge with (Edge:=TEdge s) in H0.
  inversion H0.
  simpl in *.
  subst.
  exists b.
  intuition.
  assumption.
Qed.

(*
 **WHY IS THIS LEMMA IMPORTANT?**
Any task [t] that is in a walk [w] over the WFG of [s] is in state [s].
From [t] in [w]  there exists an edge $(t_1,t_2)$ in [w] such that $t=t_1$ or $t=t_2$.
Since $(t_1,t_2)$ is in the WFG of [s], then $t_1$ is blocked an some event [e]
that is impeding $t_2$.
If $t = t_1$, then [t] is blocked, which is in [s].
Otherwise, $t = t_2$, then $t$ is impeded, so it is blocked and therefore in [s].
*)

Lemma vertex_in_tasks:
  forall t w,
  TWalk s w ->
  Graph.In (F.Edge w) t ->
  Map_TID.In t (get_tasks s).
Proof.
  intros.
  simpl in *.
  (* destruct F.In t w *)
  inversion H0 as ((t1, t2), (Hin, Hpin)).
  (* then there exists an edge (t1, t2) *)
  destruct Hpin as [H2|H2].
  - subst; simpl in *.
    (* lhs, t=t1 *)
    apply tedge_inv in Hin; auto. (* invert (t, t2) *)
    destruct Hin as (r, (Hwf, _)).
    apply wait_on_in_tasks in Hwf.
    assumption.
  - subst. simpl in *.
    (* rhs *)
    apply tedge_inv in Hin.
    + destruct Hin as (r, (_, Himp)).
      eauto using impeded_by_in_tasks.
    + auto.
Qed.

(* end hide *)

Section TotallyDeadlocked.

(**
 Let [w] be a cycle [w] in the WFG of [s] such that
 the vertices in [w] constitute the domain of the task map of [s].
*)

Variable w:t_walk.
Variable is_cycle: TCycle s w.
Variable vertex_in_tasks:
  forall t, Graph.In (F.Edge w) t <-> Map_TID.In t (get_tasks s).

(* begin hide *)

Let Hwalk: TWalk s w.
Proof.
  intros.
  inversion is_cycle.
  assumption.
Qed.

Lemma blocked_in_w:
  forall t e,
  WaitOn s t e ->
  Graph.In (F.Edge w) t.
Proof.
  intros.
  destruct H as (p, (Hin, _)).
  apply mapsto_to_in in Hin.
  rewrite vertex_in_tasks.
  assumption.
Qed.

(** The gist of the main proof of this section is to show that any
 task [t] blocked on an event [e] impedes a task [t'].  Proof: By
 Lemma [blocked_in_w], any blocked task [t] is in cycle [w].  But
 given that [w] is a cycle, then [t] has a successor [t'] such that
 $(t,t')$ is in [w].  From $(t,t')$, we have that $e$ impedes [t'].
 Since [t'] is in [w] and [w] is a cycle, then there exists a task
 [t''] such that [(t',t'')] is in [w], and therefore [t'] is blocked.
 *)

Lemma blocked_in_walk:
  forall t e,
  WaitOn s t e ->
  exists t', F.Edge w (t', t).
Proof.
  intros.
  apply blocked_in_w in H.
  apply F.pred_in_cycle with (v:=t) in is_cycle; auto.
  destruct is_cycle as (t', (_, He')).
  exists t'.
  auto.
Qed.

Lemma in_inv_left:
  forall t t',
  List.In (t, t') w ->
  Map_TID.In t (get_tasks s).
Proof.
  intros.
  simpl in *.
  apply vertex_in_tasks.
  unfold In.
  exists (t, t').
  unfold F.Edge.
  intuition.
  apply pair_in_left.
Qed.

Lemma vertex_to_blocked:
  forall t,
  Graph.In (F.Edge w) t ->
  exists e, WaitOn s t e.
Proof.
  intros.
  apply F.succ_in_cycle with (E:=TEdge s) in H; repeat auto.
  destruct H as (t', (He, Hi)).
  apply tedge_inv in Hi; auto.
  destruct Hi as (r, (Hw, _)); eauto.
Qed.

Lemma blocked_to_impeded_by:
  forall t e,
  WaitOn s t e ->
  exists t', ImpededBy s e t' /\ exists e', WaitOn s t' e'.
Proof.
  intros.
  assert (Hblocked := H).
  apply wait_on_in_tasks in H.
  apply vertex_in_tasks in H.
  apply F.succ_in_cycle with (E:=TEdge s) in H; repeat auto.
  destruct H as (t', (He, Hin)).
  assert (Hx := Hin).
  apply tedge_inv in Hin; auto.
  destruct Hin as (e', (Hw, Hi)).
  assert (e' = e) by eauto using wait_on_fun; subst.
  eauto using in_def, pair_in_right, vertex_to_blocked.
Qed.

(* end hide *)

Theorem soundness_totally:
  TotallyDeadlocked s.
Proof.
  intros.
  unfold TotallyDeadlocked.
  intros.
  intuition.
  - unfold AllTasksWaitOn; intros.
    assert (Graph.In (F.Edge w) t) by (apply vertex_in_tasks; assumption).
    assert (exists t2, TEdge s (t, t2)). {
      eapply F.succ_in_cycle in H0; eauto.
      destruct H0 as (?, (?, _)); eauto.
    }
    destruct H1 as (t2, H1).
    apply tedge_spec in H1.
    destruct H1 as (r', (Hwf1, Himp1)).
    eauto.
  - unfold AllImpededBy; intros.
    assert (Hblocked := H).
    apply blocked_to_impeded_by in H.
    destruct H as (?, (?, (?, ?))); eauto.
  - inversion is_cycle.
    exists v1.
    apply in_inv_left with (t':=v2).
    subst.
    apply List.in_eq.
Qed.

(** Recall that:

<<
TotallyDeadlocked s =
  AllTasksWaitOn s /\
  AllImpededBy s /\
  (exists t, Map_TID.In t (get_tasks s))
     : Prop
>>

First, let us show that [AllTasksWaitOn s] holds.
   By unfolding this definition we get that:
   <<
H : Map_TID.In (elt:=prog) t (get_tasks s)
______________________________________(1/1)
exists e : event, WaitOn s t e
>>
   We can conclude that [Graph.In (F.Edge w) t] holds by applying
   hypothesis [vertex_in_tasks].
   Now, since [t] is in cycle [w], then there must exist some other task [t'] such
   that succeeds [t] in cycle [w], say [(TEdge s) (t, t2)].
   We conclude this case by unfolding [TEdge].

Second, we show [AllImpededBy]. By unfolding our goal, we get that:
<<
H : WaitOn s t e
______________________________________(1/1)
exists t' : tid, ImpededBy s e t'
>>
  From [WaitOn s t e] we know that [t] in [get_tasks s],
  hence [In (F.Edge w) t].
  Since [w] is a cycle, there is some [t'] such that
  [(TEdge s) (t, t')].
  By inversting the latter we get that there exists some event [e']
  such that [WaitOn s t e'] and [ImpededBy s e t'].
  However, we know that each task can only wait on one event, thus
  [e = e'].

 Third, we show that there exists some task [t] such that
 [Map_TID.In t (get_tasks s))].
 Since [w] is a cycle, then, by
   definition, there is at least one vertex [t] such that [w] starts with [t]
   and [w] ends with [t].
   Since [w] starts with [t], then there is some task [t'] and a walk [w']
   such that [w = (t, t2) :: w'], hence [List.In (t, t2) w].
   We conclude by applying [vertex_in_tasks] to the latter.
  *)

End TotallyDeadlocked.
End Basic.

(** ** Soundness for deadlocked  states *)

(*
  Our strategy to prove soudness is to meet conditions required by
  theorem [soundness_totally] from Section ??. To this end, given
  a state [s] and a cycle [w], we partition the task map of state [s]
  into two task maps, one that contains the vertices that appear in walk [w],
  and another one that does not contain any vertex present in [w].

  Consider a state [s] and a cycle [w] in the WFG of [s].
  To construct the state needed by theorem [soundness_totally], we divide
  the task map of [s] with the following expression.
 [[
Let split (t:tid) (p:prog) := mem t w.
Let part := partition split (get_tasks s).
]]
  Function [partition] comes from Coq's
  standard library of finite maps [Coq.FSets.FMap] and divides map
  [get_tasks s] into two maps according to predicate [split]. The result,
  bound to variable [part], is a pair: on the left-hand side we get the map
  in which predicate [split] yields true;
  on the righ-hand side we get the map in which predicate [split] yields false.
*)

Section Soundness.
Variable w: t_walk.
Variable s: state.
Variable is_cycle: TCycle s w.

(**
    Our goal is to show that [s] is deadlocked.
    By unfolding [Deadlocked s] we get
    <<
______________________________________(1/1)
exists tm tm' : Map_TID.t prog,
  Map_TID_Props.Partition (get_tasks s) tm tm' /\
  TotallyDeadlocked (get_phasers s, tm)
>>

That is, we need to find a partition of the task map [tm] that is totally
deadlocked. To find such a partition we use
<<
Map_TID_Props.partition
     : forall elt : Type,
       (Map_TID.key -> elt -> bool) ->
       Map_TID.t elt -> Map_TID.t elt * Map_TID.t elt
>>
which takes a selector function of type [Map_TID.key -> elt -> bool] and
a task map, and then yields two partitions, on the left side
are the elements which the selector returned [true] and
on the right side are the which the selector returned [false].

We want to partition [get_tasks s] according to the members of the walk [w],
since in a totally deadlocked state all the members of the task
map are in the cycle and vice versa.

Let [part] and [split] be defined as
 *)

Let split : tid -> prog -> bool := (fun t (p:prog) => F.mem TID.eq_dec t w).

Let part := Map_TID_Props.partition split (get_tasks s).

(**
where [F.mem] is testing the node membership in walk [w]. The result
of [part] is two task maps. On the left-hand side, we have
the task map [fst part] such that [t] is in the domain of [dst part]
if, and only if [t] is a member of walk [w].
*)

(** Function [split] returns [true] if, and only if, the vertex
    is in cycle [w]. *)

Let split_to_vertex:
  forall t e,
  split t e = true ->
  In (F.Edge w) t.
Proof.
  intros.
  unfold split in *.
  apply F.mem_prop in H.
  assumption.
Qed.

Let vertex_to_split:
  forall t p,
  In (F.Edge w) t ->
  split t p = true.
Proof.
  intros.
  apply F.mem_from_prop with (eq_dec:=TID.eq_dec) in H.
  unfold split in *.
  assumption.
Qed.

(**
Apply [Map_TID_Props.partition_Partition] shows that
[part] is indeed a partition of [get_tasks s].
*)

Let Hpart: Map_TID_Props.Partition (get_tasks s) (fst part) (snd part).
Proof.
  apply Map_TID_Props.partition_Partition with (f:=split).
  auto with *.
  unfold part.
  auto.
Qed.

(** Let [ds] be the state that we want to show to be totally deadlocked. *)

Let deadlocked_tasks := fst part.

Let ds := (get_phasers s, deadlocked_tasks).

(**
  Since our aim is to apply Theorem [soundness_totally] to state [ds],
  then we need to show that
  (i) each task [t] is in [w] iff t is in state [ds], and
  (ii) cycle [w] is in the WFG of [ds].
*)

(**
  If task [t] is in state [ds], then task [t] is in [w].
  Proof: if task [t] is in [deadlocked_tasks], then
  there exists a program [p] such that [split t p = true] and
  [t] is in [get_tasks s]. Since we have [split t p = true], then
  [t] is in [w].
 *)

Let deadlocked_in_right:
  forall t,
  Map_TID.In t deadlocked_tasks -> In (F.Edge w) t.
Proof.
  intros.
  apply in_to_mapsto in H.
  (* there exists a program [p] such that *)
  destruct H as (e, H).
  (* [split t p = true] and [t] is in [get_tasks s] *)
  rewrite Map_TID_Props.partition_iff_1 with
     (f:=split) (m:=(get_tasks s)) in H; auto with *.
  destruct H as (H1, H2).
  eauto using split_to_vertex.
Qed.

(**
  If task [t] is in [w], then [t] is in state [ds].
  Proof: [t] is in [w], so there exists a program [p] such that
  [t] maps to [p] in [get_tasks s]. Since [t] is in [w], then
  [split t p = true], thus [t] is in [deadlocked_tasks].
 *)

Let deadlocked_in_left:
  forall t,
  In (F.Edge w) t -> Map_TID.In t deadlocked_tasks.
Proof.
  intros.
  assert (Hin := H).
  (* since [t] in [w], then [t] in [get_tasks s] *)
  apply vertex_in_tasks with (s:=s) (t:=t) (w:=w) in H; auto.
  - apply in_to_mapsto in H.
    (* [t] is in [get_tasks s], thus there exists a program [p] *)
    destruct H as (p, Hmt).
    (* [t] is in [w], thus [split t p = true] *)
    apply vertex_to_split with (p:=p) in Hin.
    assert (Hg: Map_TID.MapsTo t p (get_tasks s) /\ split t p = true). {
      intuition.
    }
    (* thus, [t] in [deadlocked_tasks] *)
    rewrite <- Map_TID_Props.partition_iff_1
      with (m1:=(fst part)) in Hg; auto with *.
    eauto using mapsto_to_in.
  - inversion is_cycle.
    auto.
Qed.

(**
  Lemma [vertex_in_tasks] captures result (i), and is trivially proved by
  applying Lemmas [deadlocked_in_left] and [deadlocked_in_right].
 *)

Let vertex_in_tasks:
  forall t, Graph.In (F.Edge w) t <-> Map_TID.In t (get_tasks ds).
Proof.
  intros.
  split.
  - apply deadlocked_in_left.
  - apply deadlocked_in_right.
Qed.

Let deadlocked_in:
  forall t,
  (In (F.Edge w) t <-> Map_TID.In t (fst part)).
Proof.
  intros.
  split; auto using deadlocked_in_left, deadlocked_in_right.
Qed.

(**
  Next, we show (ii), by first establishing that if an edge [e] is in [w] and
  [e] is an ede of the WFG of [s], then [e] is an edge of the WFG of [ds].
  Such proof requires the demonstration that any task [t] in [w] is blocked (registered)
  in [ds], and that any event [e] that impedes a task in [w] also
  impedes over state [ds].
*)

Let tid_in_walk:
  forall t,
  Graph.In (F.Edge w) t ->
  exists p,
  Map_TID.MapsTo t p (get_tasks s) /\
  Map_TID.MapsTo t p deadlocked_tasks.
Proof.
  intros.
  apply deadlocked_in in H.
  apply in_to_mapsto in H.
  destruct H as (p, H).
  exists p.
  intuition.
  unfold Map_TID_Props.Partition in Hpart.
  destruct Hpart as (Hdj, Hrw).
  rewrite Hrw.
  auto.
Qed.

Let task_in_left:
  forall t1 t2,
  List.In (t1, t2) w ->
  Graph.In (F.Edge w) t1.
Proof.
  intros.
  apply in_def with (e:=(t1, t2));
  eauto using pair_in_left.
Qed.

Let task_in_right:
  forall t1 t2,
  List.In (t1, t2) w ->
  Graph.In (F.Edge w) t2.
Proof.
  intros.
  apply in_def with (e:=(t1, t2));
  eauto using pair_in_right.
Qed.

(**
  Given that any task [t] that is in [w] is in [deadlocked_tasks] and in [get_tasks s],
  thus, applying the definition of [WaitOn] we get that [t] is also blocked in [ds].
*)

Let blocked_conv:
  forall t e,
  Graph.In (F.Edge w) t ->
  WaitOn s t e ->
  WaitOn ds t e.
Proof.
  intros.
  unfold WaitOn in *.
  destruct H0 as (p, (H1, H2)).
  exists p.
  intuition.
  (* [t] is in [w] so [t] is in [deadlocked_tasks] and [t] is in [get_tasks s]*)
  apply tid_in_walk in H.
  destruct H as (p', (H4, H5)).
  apply Map_TID_Facts.MapsTo_fun with (e:=p') in H1; auto.
  subst.
  assumption.
Qed.

(**
  It is trivial to observe that if task [t] is registered in [s],
  then task [t] is also registered in [ds], by using lemma [blocked_conv].
*)

Let registered_conv:
  forall (t:tid) e,
  Graph.In (F.Edge w) t ->
  Registered s t e ->
  Registered ds t e.
Proof.
  intros.
  destruct H0 as (?,(?,(?,?))).
  eauto using registered_def.
Qed.

(**
  Showing that an impeded_by relation is preserved in [ds],
  follows from lemmas [registered_conv] and [blocked_conv].
*)

Let impeded_by_conv:
  forall e t1 t2,
  List.In (t1, t2) w ->
  WaitOn s t1 e ->
  ImpededBy s e t2 ->
  ImpededBy ds e t2.
Proof.
  intros.
  destruct H1 as (_, (ev, (H2, H3))).
  apply registered_conv in H2.
  - eauto using impeded_by_def.
  - eauto using task_in_right.
Qed.

(**
  We conclude (ii) by establishing that any edge [e] in the WFG of [s] and
  in walk [w] is also in the WFG of [ds], from lemmas [blocked_conv] and
  [impeded_by_conv].
*)

Let t_edge_conv:
  forall e,
  List.In e w ->
  TEdge s e ->
  TEdge ds e.
Proof.
  intros.
  simpl in *.
  inversion H0; clear H0; subst.
  assert (ImpededBy ds b a2). {
    eauto using impeded_by_conv.
  }
  assert (WaitOn ds a1 b). {
    apply blocked_conv in H1; repeat auto.
    eauto using task_in_left.
  }
  eauto using Bipartite.aa.
Qed.

(**

  Thus, from lemma [t_edge_conv], we get (i) [w] is a cycle on the WFG of [ds]. *)

Let cycle_conv:
  TCycle ds w.
Proof.
  intros.
  eauto using cycle_impl_weak, t_edge_conv.
Qed.

(**
  We conclude the main result of this section by applying Theorem [soundness_totally]
  to Lemma [cycle_conv] and Lemma [vertex_in_tasks].
  *)

Let ds_totally_deadlocked :=
  soundness_totally ds w cycle_conv vertex_in_tasks.

Theorem soundness:
  Deadlocked s.
Proof.
  unfold Deadlocked.
  exists (fst part).
  exists (snd part).
  auto.
Qed.

End Soundness.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: DecidableType.v 12641 2010-01-07 15:32:52Z letouzey $ *)

Require Export SetoidList.
Require Equalities.

Set Implicit Arguments.
Unset Strict Implicit.

(** NB: This file is here only for compatibility with earlier version of
    [FSets] and [FMap]. Please use [Structures/Equalities.v] directly now. *)

(** * Types with Equalities, and nothing more (for subtyping purpose) *)

Module Type EqualityType := Equalities.EqualityTypeOrig.

(** * Types with decidable Equalities (but no ordering) *)

Module Type DecidableType := Equalities.DecidableTypeOrig.

(** * Additional notions about keys and datas used in FMap *)

Module KeyDecidableType(D:DecidableType).
 Import D.

 Section Elt.
 Variable elt : Type.
 Notation key:=t.

  Definition eqk (p p':key*elt) := eq (fst p) (fst p').
  Definition eqke (p p':key*elt) :=
          eq (fst p) (fst p') /\ (snd p) = (snd p').

  Hint Unfold eqk eqke.
  Hint Extern 2 (eqke ?a ?b) => split.

   (* eqke is stricter than eqk *)

   Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
   Proof.
     unfold eqk, eqke; intuition.
   Qed.

  (* eqk, eqke are equalities *)

  Lemma eqk_refl : forall e, eqk e e.
  Proof. auto. Qed.

  Lemma eqke_refl : forall e, eqke e e.
  Proof. auto. Qed.

  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
  Proof. auto. Qed.

  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
  Proof. unfold eqke; intuition. Qed.

  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
  Proof. eauto. Qed.

  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
  Proof.
    unfold eqke; intuition; [ eauto | congruence ].
  Qed.

  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
  Hint Immediate eqk_sym eqke_sym.

  Global Instance eqk_equiv : Equivalence eqk.
  Proof. split; eauto. Qed.

  Global Instance eqke_equiv : Equivalence eqke.
  Proof. split; eauto. Qed.

  Lemma InA_eqke_eqk :
     forall x m, InA eqke x m -> InA eqk x m.
  Proof.
    unfold eqke; induction 1; intuition.
  Qed.
  Hint Resolve InA_eqke_eqk.

  Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
  Proof.
   intros; apply InA_eqA with p; auto with *.
  Qed.

  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
  Definition In k m := exists e:elt, MapsTo k e m.

  Hint Unfold MapsTo In.

  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)

  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
  Proof.
  firstorder.
  exists x; auto.
  induction H.
  destruct y.
  exists e; auto.
  destruct IHInA as [e H0].
  exists e; auto.
  Qed.

  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
  Proof.
  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *.
  Qed.

  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
  Proof.
  destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
  Qed.

  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
  Proof.
    inversion 1.
    inversion_clear H0; eauto.
    destruct H1; simpl in *; intuition.
  Qed.

  Lemma In_inv_2 : forall k k' e e' l,
      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
  Proof.
   inversion_clear 1; compute in H0; intuition.
  Qed.

  Lemma In_inv_3 : forall x x' l,
      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
  Proof.
   inversion_clear 1; compute in H0; intuition.
  Qed.

 End Elt.

 Hint Unfold eqk eqke.
 Hint Extern 2 (eqke ?a ?b) => split.
 Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
 Hint Immediate eqk_sym eqke_sym.
 Hint Resolve InA_eqke_eqk.
 Hint Unfold MapsTo In.
 Hint Resolve In_inv_2 In_inv_3.

End KeyDecidableType.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section SemicartesianMonoidal.

Context {C : Category}.

Class SemicartesianMonoidal `{@Monoidal C} := {
eliminate {x} : x ~> I;

unit_terminal {x} (f g : x ~> I) : f ≈ g;

proj_left  {x y} : x ⨂ y ~> x := unit_right ∘ id ⨂ eliminate;
proj_right {x y} : x ⨂ y ~> y := unit_left  ∘ eliminate ⨂ id
}.

Corollary eliminate_comp `{@Monoidal C} `{@SemicartesianMonoidal _} `{f : A ~> B} :
eliminate ∘ f ≈ eliminate.
Proof. hammer_hook "Semicartesian" "Semicartesian.eliminate_comp". intros; apply unit_terminal. Qed.

End SemicartesianMonoidal.

Require Import Category.Structure.Terminal.

Program Definition SemicartesianMonoidal_Terminal `{@Monoidal C}
`{@SemicartesianMonoidal C _} : @Terminal C := {|
terminal_obj := I;
one := @eliminate _ _ _;
one_unique := @unit_terminal _ _ _
|}.

Import EqNotations.

Program Definition Terminal_SemicartesianMonoidal `{M : @Monoidal C}
`{T : @Terminal C} (Heq : 1 = @I C M) :
@SemicartesianMonoidal C _ := {|
eliminate := fun x => rew Heq in one;
unit_terminal := fun x f g =>
_ (one_unique (rew <- Heq in f) (rew <- Heq in g))
|}.
Next Obligation.
unfold eq_rect_r, eq_rect, eq_sym in x.
destruct Heq.
assumption.
Defined.


From Coq Require Import ssreflect ssrbool.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import BasicAst Reflect.
From MetaCoq.Erasure Require Import EAst EInduction.
From Equations Require Import Equations.

Local Ltac finish :=
  let h := fresh "h" in
  right ;
  match goal with
  | e : ?t <> ?u |- _ =>
    intro h ; apply e ; now inversion h
  end.

Local Ltac fcase c :=
  let e := fresh "e" in
  case c ; intro e ; [ subst ; try (left ; reflexivity) | finish ].

Local Ltac term_dec_tac term_dec :=
  repeat match goal with
         | t : term, u : term |- _ => fcase (term_dec t u)
         | n : nat, m : nat |- _ => fcase (Nat.eq_dec n m)
         | i : ident, i' : ident |- _ => fcase (eq_dec i i')
         | i : kername, i' : kername |- _ => fcase (eq_dec i i')
         | i : string, i' : kername |- _ => fcase (eq_dec i i')
         | n : name, n' : name |- _ => fcase (eq_dec n n')
         | i : inductive, i' : inductive |- _ => fcase (eq_dec i i')
         | x : inductive * nat, y : inductive * nat |- _ =>
           fcase (eq_dec x y)
         | x : projection, y : projection |- _ => fcase (eq_dec x y)
         | x : recursivity_kind, y : recursivity_kind |- _ => fcase (eq_dec x y)
         end.

Ltac nodec :=
  let bot := fresh "bot" in
  try solve [ constructor ; intro bot ; inversion bot ; subst ; tauto ].

Derive NoConfusion NoConfusionHom for term.

#[global]
Instance EqDec_term : EqDec term.
Proof.
  intro x; induction x using term_forall_list_ind ; intro t ;
    destruct t ; try (right ; discriminate).
  all: term_dec_tac term_dec.
  - left; reflexivity.
  - revert l0. induction X ; intro l0.
    + destruct l0.
      * left. reflexivity.
      * right. discriminate.
    + destruct l0.
      * right. discriminate.
      * destruct (IHX l0) ; nodec.
        destruct (p t) ; nodec.
        subst. left. inversion e. reflexivity.
  - destruct (IHx t) ; nodec.
    subst; left; reflexivity.
  - destruct (IHx1 t1) ; nodec.
    destruct (IHx2 t2) ; nodec.
    subst. left. reflexivity.
  - destruct (IHx1 t1) ; nodec.
    destruct (IHx2 t2) ; nodec.
    subst. left. reflexivity.
  - revert l. induction X ; intro l0.
    + destruct l0.
      * left. reflexivity.
      * right. discriminate.
    + destruct l0.
      * right. discriminate.
      * destruct (IHX l0) ; nodec.
        destruct (p t) ; nodec.
        inversion e. subst; left; reflexivity.
  - destruct (IHx t) ; nodec.
    subst. revert l0. clear IHx.
    induction X ; intro l0.
    + destruct l0.
      * left. reflexivity.
      * right. discriminate.
    + destruct l0.
      * right. discriminate.
      * destruct (IHX l0) ; nodec.
        destruct (p (snd p1)) ; nodec.
        destruct (eq_dec (fst x) (fst p1)) ; nodec.
        destruct x, p1.
        left.
        cbn in *. subst. inversion e. reflexivity.
  - destruct (IHx t) ; nodec.
    left. subst. reflexivity.
  - revert m0. induction X ; intro m0.
    + destruct m0.
      * left. reflexivity.
      * right. discriminate.
    + destruct m0.
      * right. discriminate.
      * destruct (p (dbody d)) ; nodec.
        destruct (IHX m0) ; nodec.
        destruct x, d ; subst. cbn in *.
        destruct (eq_dec dname dname0) ; nodec.
        subst. inversion e0. subst.
        destruct (eq_dec rarg rarg0) ; nodec.
        subst. left. reflexivity.
  - revert m0. induction X ; intro m0.
    + destruct m0.
      * left. reflexivity.
      * right. discriminate.
    + destruct m0.
      * right. discriminate.
      * destruct (p (dbody d)) ; nodec.
        destruct (IHX m0) ; nodec.
        destruct x, d ; subst. cbn in *.
        destruct (eq_dec dname dname0) ; nodec.
        subst. inversion e0. subst.
        destruct (eq_dec rarg rarg0) ; nodec.
        subst. left. reflexivity.
  - destruct (eq_dec p p0); nodec.
    left; subst. reflexivity.
Defined.

#[global]
Instance ReflectEq_term : ReflectEq.ReflectEq _ :=
  @EqDec_ReflectEq _ EqDec_term.

Definition eqb_constant_body (x y : constant_body) :=
  eqb (cst_body x) (cst_body y).

#[global, program]
Instance reflect_constant_body : ReflectEq constant_body :=
  {| eqb := eqb_constant_body |}.
Next Obligation.
Proof.
  revert x y; intros [] [].
  unfold eqb_constant_body.
  cbn -[eqb].
  finish_reflect.
Qed.

Definition eqb_constructor_body (x y : constructor_body) :=
  (x.(cstr_name), x.(cstr_nargs)) == (y.(cstr_name), y.(cstr_nargs)).

#[global, program]
Instance reflect_constructor_body : ReflectEq constructor_body :=
  {| eqb := eqb_constructor_body |}.
Next Obligation.
Proof.
  unfold eqb_constructor_body.
  destruct x, y; cbn.
  case: eqb_spec; intros H; constructor; congruence.
Qed.
Definition eqb_projection_body (x y : projection_body) :=
  x.(proj_name) == y.(proj_name).

#[global, program]
Instance reflect_projection_body : ReflectEq projection_body :=
  {| eqb := eqb_projection_body |}.
Next Obligation.
Proof.
  unfold eqb_projection_body.
  destruct x, y; cbn.
  case: eqb_spec; intros H; constructor; congruence.
Qed.

Definition eqb_one_inductive_body (x y : one_inductive_body) :=
  let (n, i, k, c, p) := x in
  let (n', i', k', c', p') := y in
  eqb n n' && eqb i i' && eqb k k' && eqb c c' && eqb p p'.

#[global]
Instance reflect_one_inductive_body : ReflectEq one_inductive_body.
Proof.
  refine {| eqb := eqb_one_inductive_body |}.
  intros [] [].
  unfold eqb_one_inductive_body; finish_reflect.
Defined.

Definition eqb_mutual_inductive_body (x y : mutual_inductive_body) :=
  let (f, n, b) := x in
  let (f', n', b') := y in
  eqb f f' && eqb n n' && eqb b b'.

#[global, program]
Instance reflect_mutual_inductive_body : ReflectEq mutual_inductive_body :=
  {| eqb := eqb_mutual_inductive_body |}.
Next Obligation.
Proof.
  revert x y; intros [] [].
  unfold eqb_mutual_inductive_body; finish_reflect.
Defined.

Definition eqb_global_decl x y :=
  match x, y with
  | ConstantDecl cst, ConstantDecl cst' => eqb cst cst'
  | InductiveDecl mib, InductiveDecl mib' => eqb mib mib'
  | _, _ => false
  end.

#[global, program]
Instance reflect_global_decl : ReflectEq global_decl :=
  {| eqb := eqb_global_decl |}.
Next Obligation.
Proof.
  revert x y.
  unfold eqb_global_decl.
  intros [] []; finish_reflect.
Defined.


(* Submitted by Randy Pollack *)

Record pred (S : Set) : Type :=  {sp_pred :> S -> Prop}.
Record rel (S : Set) : Type :=  {sr_rel :> S -> S -> Prop}.

Section testSection.
Variables (S : Set) (P : pred S) (R : rel S) (x : S).
Check (P x).
Check (R x x).
End testSection.

(* Check the removal of coercions with target Funclass *)

Record foo : Type :=  {D :> nat -> nat}.
Check (fun (x : foo) (n : nat) => x n).

(* Check both removal of coercions with target Funclass and mixing
   string and numeral scopes *)

Require Import String.
Open Scope string_scope.
Inductive PAIR := P (s:string) (n:nat).
Coercion P : string >-> Funclass.
Check ("1" 0).


Require Import utility.
Require Import PredomAux.
Require Import typedlambda.
Require Import typeddensem.
Require Import Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.

(* Need this for nice pretty-printing *)
Unset Printing Implicit Defensive.

(*==========================================================================
  Semantics of substitution and renaming
  ==========================================================================*)

Fixpoint SemMap (P:Env -> Ty -> Type) (sem : forall env ty, P env ty -> SemEnv env -c> SemTy ty) env env' : Map P env' env -> SemEnv env -c> SemEnv env' :=
  match env' return Map P env' env -> SemEnv env -c> SemEnv env' with
  | nil => fun s => K _ (tt:DOne)
  | _ => fun s => PROD_fun (SemMap sem (tlMap s)) (sem _ _ (hdMap s))
  end.

Definition semWk P (k:Kit P) (sem:forall E t, P E t -> SemEnv E -c> SemTy t) := forall E t0 t (v:P E t), sem _ _ (wk k t0 v) == sem E t v @_ FST.
Definition semVr P (k:Kit P) (sem:forall E t, P E t -> SemEnv E -c> SemTy t) := forall E t0, sem _ _ (vr k (ZVAR E t0)) == SND.
Definition semVl P (k:Kit P) (sem:forall E t, P E t -> SemEnv E -c> SemTy t) := forall E t (v:P E t), sem _ _ v = SemVal (vl k v).

Lemma SemShiftMap :
  forall P (k:Kit P) sem, semWk k sem -> forall E E' (s:Map P E E') t, SemMap sem (shiftMap (K:=k) t s) == SemMap sem s @_ FST.
Proof.
intros P k sem semwk.
induction E. intros. simpl.
apply (DOne_final (K (Dprod (SemEnv E') (SemTy t)) (tt:DOne)) _).

intros.
simpl. destruct (consMapInv s) as [s' [var eq]].
subst. simpl. rewrite hdConsMap. rewrite tlConsMap.
specialize (IHE E' s' t).
rewrite PROD_fun_comp.
refine (PROD_fun_eq_compat _ _).
rewrite IHE. auto.

rewrite shiftConsMap. rewrite hdConsMap.
unfold semWk in semwk.
rewrite semwk. auto.
Qed.

Lemma SemLiftMap :
  forall P (k:Kit P) sem, semWk k sem -> forall E E' (s:forall t, Var E t -> P E' t) t0, SemMap sem (tlMap (lift (K:=k) t0 s)) == SemMap sem s @_ FST.
Proof.
induction E. intros. simpl.
apply (DOne_final (K (Dprod (SemEnv E') (SemTy t0)) (tt:DOne)) _).

intros.
simpl. destruct (consMapInv s) as [s' [var eq]].
subst. rewrite hdConsMap. rewrite tlConsMap.
specialize (IHE E' s' t0).
rewrite PROD_fun_comp.
refine (PROD_fun_eq_compat _ _).
rewrite IHE. auto.unfold tlMap. simpl. unfold hdMap. simpl.
unfold semWk in H. rewrite H. auto.
Qed.

Lemma SemLift2Map :
  forall P (k:Kit P) sem, semWk k sem -> forall E E' (s:Map P E E') t t', SemMap sem (tlMap (tlMap (lift (K:=k) t' (lift (K:=k) t s)))) == SemMap sem s @_ FST @_ FST.
Proof.
induction E. intros. simpl.
apply (DOne_final (K (Dprod (Dprod (SemEnv E') (SemTy t)) (SemTy t')) (tt:DOne)) _).

intros.
simpl. destruct (consMapInv s) as [s' [var eq]].
subst. simpl. rewrite hdConsMap. rewrite tlConsMap.
specialize (IHE E' s' t).
rewrite PROD_fun_comp. rewrite PROD_fun_comp.
refine (PROD_fun_eq_compat _ _).
rewrite IHE. auto. unfold semWk in H. unfold hdMap. unfold tlMap.  simpl. rewrite H. rewrite H.  auto.
Qed.

Lemma SemCommutesWithMap : forall P (k:Kit P) sem, semWk k sem -> semVr k sem -> semVl k sem ->
   (forall E t (v : Value E t) E' (r : Map P E E'),
   SemVal v @_ SemMap sem r == SemVal (travVal v k r))
/\ (forall E t (exp : Exp E t) E' (r : Map P E E'),
   SemExp exp @_ SemMap sem r == SemExp (travExp exp k r)).
Proof.
intros P k sem semwk semvr semvl. unfold semWk in semwk. unfold semVr in semvr. unfold semVl in semvl.
apply ExpVal_ind.

(* TINT *)
intros. simpl. rewrite <- K_com; trivial.

(* TBOOL *)
intros. simpl. rewrite <- K_com; trivial.

(* TVAR *)
intros E t var E' s.
simpl.
dependent induction var. simpl. rewrite SND_PROD_fun.
destruct (consMapInv s) as [s' [v eq]]. subst.
simpl. rewrite hdConsMap. rewrite semvl. trivial.
destruct (consMapInv s) as [s' [v eq]]. subst.
simpl.
specialize (IHvar s' var (JMeq_refl _)).
rewrite <- IHvar. rewrite fcont_comp_assoc.
rewrite tlConsMap. rewrite FST_PROD_fun. trivial.

(* TFIX *)
intros E t t1 body IH E' s.
specialize (IH (t :: t --> t1 :: E') (lift (K:=k) t (lift (K:=k) (t --> t1) s))).
simpl SemVal.
rewrite fcont_comp_assoc. rewrite Curry_comp. rewrite Curry_comp. rewrite <- IH.
clear IH. simpl. rewrite PROD_map_fun. rewrite PROD_map_fun. rewrite ID_comp_left. rewrite ID_comp_left.
rewrite PROD_fun_comp. rewrite SemLift2Map. unfold tlMap. unfold hdMap. simpl.
rewrite semvr. rewrite semwk. rewrite semvr. auto. auto.

(* TPAIR *)
intros E t1 t2 v1 IH1 v2 IH2 E' s.
simpl SemVal. rewrite <- IH1. rewrite <- IH2. rewrite <- PROD_fun_comp. trivial.

(* TFST *)
intros E t1 t2 v IH E' s. simpl SemExp.
rewrite <- IH. repeat (rewrite fcont_comp_assoc). trivial.

(* TSND *)
intros E t1 t2 v IH E' s. simpl SemExp.
rewrite <- IH. repeat (rewrite fcont_comp_assoc). trivial.

(* TOP *)
intros E n v1 IH1 v2 IH2 E' s. simpl SemExp.
repeat (rewrite fcont_comp_assoc). rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.

(* TGT *)
intros E v1 IH1 v2 IH2 E' s. simpl SemExp.
repeat (rewrite fcont_comp_assoc). rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.

(* TVAL *)
intros E t v IH E' s. simpl SemExp.
rewrite <- IH. rewrite fcont_comp_assoc. trivial.

(* TLET *)
intros E t1 t2 e2 IH2 e1 IH1 E' s. simpl SemExp.
rewrite fcont_comp_assoc.
specialize (IH2 _ s).
specialize (IH1 _ (lift (K:=k) _ s)).
rewrite PROD_fun_comp.
rewrite KLEISLIR_comp.
rewrite <- IH2. clear IH2. rewrite <- IH1. clear IH1. simpl.
rewrite PROD_map_fun. rewrite ID_comp_left. rewrite ID_comp_left.
rewrite SemLiftMap. unfold hdMap. simpl. rewrite semvr. trivial. trivial.

(* TAPP *)
intros E t1 t2 v1 IH1 v2 IH2 E' s. simpl SemExp.
rewrite fcont_comp_assoc. rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.

(* TIF *)
intros E t ec IHc te1 IH1 te2 IH2 E' s. simpl SemExp.
rewrite fcont_comp3_comp. rewrite <- IHc. rewrite <- IH1. rewrite <- IH2. trivial.
Qed.

Definition SemRenaming := SemMap SemVar.
Definition SemSubst := SemMap SemVal.

Corollary SemCommutesWithRenaming:
   (forall E t (v : Value E t) E' (r : Renaming E E'),
   SemVal v @_ SemRenaming r == SemVal (renameVal r v))
/\ (forall E t (exp : Exp E t) E' (r : Renaming E E'),
   SemExp exp @_ SemRenaming r == SemExp (renameExp r exp)).
Proof.
assert (H1 : semWk RenamingKit SemVar). unfold semWk; intros;auto.
assert (H2 : semVr RenamingKit SemVar). unfold semVr; auto.
assert (H3 : semVl RenamingKit SemVar). unfold semVl; auto.
assert (H := SemCommutesWithMap H1 H2 H3). auto.
Qed.

(*==========================================================================
  Semantic function commutes with substitution
  ==========================================================================*)

Lemma SemIdRenaming : forall E, SemRenaming (idRenaming E) == ID.
Proof.
induction E.
simpl.
apply (DOne_final (K DOne _) _).

rewrite idRenamingDef. unfold SemRenaming. unfold SemMap. rewrite tlConsMap. fold SemMap. simpl. unfold shiftRenaming. rewrite SemShiftMap.
rewrite IHE. rewrite ID_comp_left.
apply fcont_eq_intro. intros. destruct x.  auto. unfold semWk. intros. auto.
Qed.

Lemma SemRenamingShift : forall E t0, SemRenaming (fun s : Ty => SVAR (env:=E) t0) == FST.
induction E.
intros t0. apply fcont_eq_intro. intros x.
case x.  intros. simpl in *. dependent destruction x. unfold SemRenaming. unfold SemMap. rewrite K_simpl. case t. auto.

(* Seems a bit round-about *)
intros t0.
assert ((fun s => SVAR t0) = tlMap (lift (K:=RenamingKit) t0 (idRenaming (a::E)))).
rewrite LiftRenamingDef. rewrite tlConsMap. apply MapExtensional. auto.
rewrite H. unfold SemRenaming.
rewrite SemLiftMap. rewrite SemIdRenaming. rewrite ID_comp_left. auto.
unfold semWk. intros. auto.
Qed.

Corollary SemCommutesWithSubst:
   (forall E t (v : Value E t) E' (s : Subst E E'),
   SemVal v @_ SemSubst s == SemVal (substVal s v))
/\ (forall E t (exp : Exp E t) E' (s : Subst E E'),
   SemExp exp @_ SemSubst s == SemExp (substExp s exp)).
Proof.
assert (H1 : semWk SubstKit SemVal). unfold semWk; intros.
simpl. rewrite <- (proj1 SemCommutesWithRenaming).
refine (fcont_comp_eq_compat _ _). trivial. rewrite SemRenamingShift. auto.
assert (H2 : semVr SubstKit SemVal). unfold semVr; auto.
assert (H3 : semVl SubstKit SemVal). unfold semVl; auto.
assert (H := SemCommutesWithMap H1 H2 H3). unfold renameVal. unfold renameExp.
split. intros. apply (proj1 H).
intros. apply (proj2 H).
Qed.