(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph.
From fourcolor Require Import hypermap geometry color chromogram coloring cfmap.
From fourcolor Require Import cfcolor dyck ctree initctree gtree initgtree.
From fourcolor Require Import gtreerestrict ctreerestrict.

(******************************************************************************)
(*   Here we put all the reducibility steps together, to compute the Kempe    *)
(* closure tree of a configuration, which we can use to test directly for     *)
(* D-reducibility. A bit more work will be required for C-reducibility.       *)
(* Definitions:                                                               *)
(*  Kempe_tree cp == a ctree containing exactly the even ring trace colorings *)
(*                  in the Kempe co-closure of the ring traces induced by     *)
(*                  colorings of cfmap cp.                                    *)
(*  Kempe_tree_closure d ctu ctr gtu == computes the largest subset of the    *)
(*                  set of traces/chromograms represented by ctu/gtu, that is *)
(*                  disjoint from ctr : ctree; more precisely, returns a pair *)
(*                  of a ctree that is a subset of ctu : ctree, and a gtree   *)
(*                  pair that represents a partition of gtu : gtree. Here d   *)
(*                  is the heigth of the trees involved. Kempe_tree is        *)
(*                  computed by taking ctu/gtu to be the initial ctree/gtree, *)
(*                  and ctr to be cpcolor cp.                                 *)
(*  ktc_step ktc0 kr == inner loop closure functional for Kempe_tree_closure. *)
(*                  Improves an approximation kr of the result of             *)
(*                  Kempe_tree_closure by restricting the ctree part of kr by *)
(*                  the deleted chromograms in it gtree partition part, then  *)
(*                  calling an approximation ktc0 of Kempe_tree_closure with  *)
(*                  the resulting ctree, deleting the permutation closure of  *)
(*                  the colorings deleted by the ctree restriction.           *)
(* ktc_dostep2c ktc0 == improve an approximation ktc0 of Kempe_tree_closure   *)
(*                  by running ktc0, then running ktc_step ktc0 twice on its  *)
(*                  result. Kempe_tree_closure is obtained by running this d  *)
(*                  times on the simple approximation that justs restricts    *)
(*                  gtu by ctr: the improved approximation will do up to 3^d  *)
(*                  restriction cycles, which guarantees convergence.         *)
(* Kempe_valid h P ctu ctr gtu gtr <-> ctu, ctr : ctree and gtu, gtr : gtree  *)
(*                  is a valid intermediate Kempe_tree_closure state:         *)
(*                  the pairs are respectively partitions of subset of the    *)
(*                  initial (full) [cg]tree for ring size h+2, ctu contains   *)
(*                  exactly the even traces matching chromograms in the union *)
(*                  of gtu and gtr, with the correct multiplicities, and the  *)
(*                  removed colorings/chomograms in ctr/gtr are in the Kempe  *)
(*                  co-closure of the predicate P.                            *)
(*  ctree_size t == the number of different colorings stored in t : ctree.    *)
(* Kempe_complete P sz ctu ctr gtu gtr <-> ctu/ctr, gtu/gtr are a complete    *)
(*                  Kempe_tree_closure state, up to size sz: either ctu has   *)
(*                  size < sz, or both ctr and gtr are empty; any trace with  *)
(*                  a permutation not in ctu or whose completion satisfies P  *)
(*                  either has a Color2-3 permutation in ctr, or does not     *)
(*                  match any chromogram in gtu.                              *)
(******************************************************************************)

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

Fixpoint ctree_size (t : ctree) : nat :=
  match t with
  | CtreeNode t1 t2 t3 => ctree_size t1 + (ctree_size t2 + ctree_size t3)
  | CtreeLeaf _ => 1
  | CtreeEmpty => 0
  end.

Lemma ctree_size_partition t t' t'' :
    ctree_partition t (CtreePair t' t'') ->
  ctree_size t = ctree_size t' + ctree_size t''.
Proof.
have Esz0 t0: (forall et, ctree_mem t0 et = false) -> ctree_size t0 = 0.
  elim: t0 => [t1 IHt1 t2 IHt2 t3 IHt3 /(_ (_ :: _))nomem | ? _ /(_ [::])|] //=.
  by rewrite (IHt1 (nomem Color1)) (IHt2 (nomem Color2)) (IHt3 (nomem Color3)).
rewrite /=; elim: t => [t1 IHt1 t2 IHt2 t3 IHt3|lf IHlf|] in t' t'' * => Pt.
- have:= Pt (_ :: _); case: t' {Pt}(Pt [::]) => // [t1' t2' t3'|].
    case: t'' => [t1'' t2'' t3''|lf|] //= _ Pte.
      rewrite /= (IHt1 _ _ (Pte Color1)) (IHt2 _ _ (Pte Color2)).
      by rewrite (IHt3 _ _ (Pte Color3)) -!addnA; do !nat_congr.
    rewrite /= (IHt1 _ CtreeEmpty (Pte Color1)).
    rewrite (IHt2 _ CtreeEmpty (Pte Color2)).
    by rewrite (IHt3 _ CtreeEmpty (Pte Color3)) /= !addn0.
  case: t'' => [t1'' t2'' t3''|lf|] // _ Pte.
    rewrite /= (IHt1 CtreeEmpty _ (Pte Color1)).
    rewrite (IHt2 CtreeEmpty _ (Pte Color2)).
    by rewrite (IHt3 CtreeEmpty _ (Pte Color3)).
  rewrite /= (IHt1 CtreeEmpty CtreeEmpty (Pte Color1)).
  rewrite (IHt2 CtreeEmpty CtreeEmpty (Pte Color2)).
  by rewrite (IHt3 CtreeEmpty CtreeEmpty (Pte Color3)).
- case Dt': t' Pt (Pt [::]) => [t1' t2' t3'|lf'|]; last by case: t''.
    case: t'' => // lf'' Pt _; rewrite -Dt' /= Dt' Esz0 // => et.
    by case: et (Pt et) => //= e et; rewrite orbF.
  by move=> Pt _; rewrite /= Esz0 // => et; case: et (Pt et).
by move: Pt => /(_ _)/norP/=/all_and2[]; do 2!move=> /(_ _)/negPf/=/Esz0->.
Qed.

Lemma ctree_size_proper h t :
  ctree_proper h t -> ctree_size t = 0 -> t = CtreeEmpty.
Proof.
elim: h t => [|h IHh] [] //= t1 t2 t3 [t_ne t1ok t2ok t3ok] szt_0.
by move/eqP: szt_0 t_ne; rewrite !addn_eq0 => /and3P[]; do 3?move/eqP/IHh->.
Qed.

Lemma ctree_max_size_proper h t : ctree_proper h t -> ctree_size t <= 3 ^ h.
Proof.
elim: h t => [|h IHh] [t1 t2 t3|lf|] //= [_ t1ok t2ok t3ok].
by rewrite expnS 2!mulSn mul1n !leq_add ?IHh.
Qed.

Section KempeTreeClosure.

Variable h : nat.

Let ktc_fun := ctree -> ctree -> gtree -> ctree * gtree_pair.

Definition ktc_step closure kr :=
  let: (ctu, gtp) := kr in
  if ctree_empty ctu then kr else
  let: GtreePair gtr gtu := gtp in
  if gtree_empty gtr then kr else
  if gtree_empty gtu then (CtreeEmpty, empty_gtree_pair) else
  let: CtreePair ctu' ctr :=
    ctree_restrict h ctu (CtrCons Bstack0 gtr CtrNil) in
  closure ctu' (ctree_rotlr ctr) gtu.

Definition ktc_step2c step (closure : ktc_fun) ctu ctr gtu :=
  step (step (closure ctu ctr gtu)).

Definition ktc_dostep2c closure := ktc_step2c (ktc_step closure) closure.

Fixpoint Kempe_tree_closure d : ktc_fun :=
  if d is d'.+1 then ktc_dostep2c (Kempe_tree_closure d') else
  fun ctu ctr gtu => (ctu, gtree_restrict gtu (GtrCons Bstack0 ctr GtrNil)).

Variable P : colseq -> Prop.

Local Notation sub_gt gt et := (gtree_sub gt Bstack0 et).
Local Notation even_fun et E := (fun et => if ~~ even_trace et then 0 else E).

Definition Kempe_valid ctu ctr gtr gtu :=
 [/\ ctree_proper h.+1 ctu
     /\ ctree_sub ctu =1 even_fun et (sub_gt gtr et + sub_gt gtu et),
     forall et, ctree_mem ctr et ->
       Kempe_coclosure P (ctrace et) /\ size et = h.+1,
     forall w, gtree_mem gtr w -> ~ gtree_mem gtu w /\ init_gtree_spec h.+1 w,
     forall w, gtree_mem gtu w -> init_gtree_spec h.+1 w
   & forall w, ~ gtree_mem gtu w -> init_gtree_spec h.+1 w ->
        exists2 et, Kempe_coclosure P (ctrace et) & matchpg Bstack0 et w].

Definition Kempe_complete sz ctu ctr gtr gtu :=
  [/\ ctree_size ctu < sz \/ ctr = CtreeEmpty /\ (forall w, ~ gtree_mem gtr w)
    & forall et, let norm_et e := permt (edge_rot e) (etrace et) in
        P (ctrace et) \/ (exists e, ~ ctree_mem ctu (norm_et e)) ->
      ctree_mem ctr (etrace et) \/ gtree_sub gtu Bstack0 et = 0].

Let ktr_prop ktr Q : Prop :=
  let: (ctu, GtreePair gtr gtu) := ktr in Q (ctu : ctree) CtreeEmpty gtr gtu.

Theorem Kempe_tree_closure_correct d ctu ctr gtu :
    let ktr0 Q := Q ctu ctr GtreeEmpty gtu in
    let ktrp := ktr_prop (Kempe_tree_closure d ctu ctr gtu) in
    ktr0 Kempe_valid ->
 [/\ ktrp Kempe_valid
   & forall sz, ktr0 (Kempe_complete (3 ^ d + sz)) ->
     ktrp (Kempe_complete sz.+1)].
Proof.
elim: d => [|d IHd] /= in ctu ctr gtu *.
  move Dctrr: (GtrCons _ ctr _) => ctrr [[ctu_ok Dctu] Dctr Dgtr Dgtu closedP].
  move: (gtree_restrict_partition gtu ctrr) (gtree_mem0_restrict gtu ctrr).
  case: (gtree_restrict gtu ctrr) => gtr gtu' /= Pgt Pgtr.
  split=> [|sz [ctu_lt_sz ctr_closed]].
    split=> // [|w gt_w | w gt_w | w gt'w Dw]; first split=> // et.
    - by rewrite Dctu gtree_sub_empty -(match_count_partition Pgt).
    - move: gt_w (Pgtr w) (Pgt w) => -> /esym/andP[gt_w _] /idP.
      by rewrite gt_w; split=> //; apply: Dgtu.
    - by apply: Dgtu; apply: contraFT (Pgt w) => /negPf->; rewrite gt_w orbT.
    case: (@idP (gtree_mem gtu w)) (Pgt w) => [_ | ? _]; last exact: closedP.
    rewrite Pgtr andbC; case gt_w: (gtr_mem _ w) => [] => [_ | /negbFE//].
    by move: gt_w; rewrite -Dctrr /= orbF => /has_matchP[et /Dctr[]]; exists et.
  split=> [|et /= Pet].
    case: ctu_lt_sz => [|[{}Dctr _]]; [by left | right; split=> // w].
    by rewrite Pgtr -Dctrr Dctr /= andbC; case: has_matchP => // [] [].
  right; apply/eqP/match_countP=> [[w gt_w wMet]]; case/negP: (Pgt w).
  rewrite gt_w; case gtu_w: (gtree_mem gtu w); last by rewrite orbT.
  case/ctr_closed: Pet => [ct_et | /eqP/match_countP[]]; last by exists w.
  rewrite /eqb addbT negbK Pgtr gtu_w -Dctrr /= orbF.
  by apply/has_matchP; exists (etrace et); rewrite ?matchpg_etrace.
move: (Kempe_tree_closure d) IHd ctu ctr gtu => ktc' IHktc'.
suffices IHstep ktr:
    let ktrp := ktr_prop ktr in let ktrp' := ktr_prop (ktc_step ktc' ktr) in
    ktrp Kempe_valid ->
  [/\ ktrp' Kempe_valid
    & forall sz, ktrp (Kempe_complete (3 ^ d + sz.+1)) ->
      ktrp' (Kempe_complete sz.+1)].
- move=> ctu ctr gtu /IHktc'[/IHstep[/IHstep[valid full3] full2] full1].
  split=> // sz; rewrite expnS -!addnA => /full1.
  by rewrite -addnS => /full2; rewrite -addnS => /full3.
move Dktr': (ktc_step _ ktr) => ktr'; case: ktr => ctu [gtr gtu] /= in Dktr' *.
case=> [[ctu_ok Dctu] _ Dgtr Dgtu closedP].
case: ifP Dktr' => [/ctree_empty_eq ctu0 <- //= | _].
  by split=> // sz [_ ctr_closed]; split=> //; left; rewrite ctu0.
case: gtree_emptyP => [gtr0 <- //= | _].
  split=> // sz [_ ctr_closed]; split=> //; right; split=> // w.
  by rewrite gtr0 gtree_mem_empty.
case gtree_emptyP => [gtu0 | _] <- {ktr'}/=.
  split; last by split; [left | right; rewrite gtree_sub_empty].
  split=> //; do [by case | by rewrite -gtu0 | split=> // et].
  by rewrite gtree_sub_empty if_same.
have{ctu_ok}:= ctree_restrict_correct (CtrCons Bstack0 gtr CtrNil) ctu_ok.
case: (ctree_restrict _ _ _) => ctu' ctr /= [ct_ok Pctu Dctu'].
have{ct_ok} [/= ctr_ok ctu'_ok] := (ct_ok true, ct_ok false).
suffices{IHktc'} [gt_valid gt_full]:
  [/\ Kempe_valid ctu' (ctree_rotlr ctr) GtreeEmpty gtu
    & forall sz, Kempe_complete sz.+1 ctu CtreeEmpty gtr gtu ->
      Kempe_complete sz ctu' (ctree_rotlr ctr) GtreeEmpty gtu].
- by case/IHktc': gt_valid; split=> // sz; rewrite addnS => /gt_full; move: sz.
have {}Dctu': ctree_sub ctu' =1 even_fun et (sub_gt gtu et).
  by move=> et; rewrite Dctu' Dctu addn0; case: ifP; rewrite ?addKn.
split=> [|sz [ctu_lt_sz ctr_closed]].
  split=> // [|et0 ct_et0 | [] //].
    by split=> // et; rewrite gtree_sub_empty Dctu'.
  have{ct_et0} [g ct_et]: exists g, ctree_mem ctr (permt g et0).
    move: ct_et0; rewrite (ctree_mem_rotlr _ ctr_ok).
    by case/orP; [exists Eperm312 | exists Eperm231].
  set et := permt g et0 in ct_et.
  have{ct_et}[gtr_et gtu'et]: sub_gt gtr et != 0 /\ sub_gt gtu et == 0.
    case: ifP (Pctu et); rewrite ct_et ?orbT // -eqE eqb_id /ctree_mem.
    by rewrite Dctu Dctu' addnC; case: ifP => //; case: (sub_gt gtu et).
  have{gtr_et} sz_et: size et == h.+1.
    by case/match_countP: gtr_et => w /Dgtr[_ /andP[sz_w _]] /matchpg_size <-.
  split=> [P1 closedP1 P1et0|]; last by rewrite -(eqP sz_et) size_map.
  have{P1et0}-/closedP1[_ [w etMw wP1]]: P1 (ctrace et).
    by rewrite ctrace_permt; case/closedP1: P1et0.
  have w_bal: gram_balanced 0 false w.
    by have [_] := matchg_balanced etMw; rewrite sumt_ctrace.
  have Dw := matchg_cgram etMw; move: (take _ _) => w1 in Dw.
  have{etMw} etMw1: matchpg Bstack0 et w1 by rewrite -matchg_pg -Dw.
  have [gt_w1||et1 closedPet1 et1Mw1] := closedP w1.
  - by case/match_countP: gtu'et; exists w1.
  - by rewrite /init_gtree_spec (matchpg_size etMw1) sz_et -Dw.
  by apply: closedPet1 => //; apply: wP1; rewrite Dw matchg_pg -?Dw.
split=> [|et /=].
  have{ctu_lt_sz} [| [_ gtr0]] := ctu_lt_sz.
    rewrite (ctree_size_partition Pctu) addnC -ltn_subRL.
    case ctr0: (ctree_size ctr) => [|m]; last first.
      by move/leq_trans->; [left | rewrite subSS leq_subr].
    by right; split=> [|[]] //; rewrite (ctree_size_proper ctr_ok ctr0).
  right; split => [|[]] //; rewrite (_ : ctr = CtreeEmpty) //.
  apply/(ctree_size_proper ctr_ok)/(@addnI (ctree_size ctu')).
  rewrite -(ctree_size_partition Pctu).
  rewrite (@ctree_size_partition ctu ctu' CtreeEmpty) // => et.
  case: ifP (Pctu et) => [|_ /norP[/negPf->] //].
  rewrite /ctree_mem Dctu Dctu'; case: ifP => // _.
  by rewrite /gtree_sub match_count_0 => [-> // | w]; apply/negP.
case=> [Pet | [e]]; first by case: (ctr_closed et) => //; [left | right].
set et1 := permt _ _ => /negP ctu'et1.
case ctu'et: (ctree_mem ctu' (etrace et)); last first.
  right; apply: contraFeq ctu'et => /match_countP[w gt_w etMw].
  rewrite /ctree_mem Dctu' even_etrace; apply/match_countP.
  by exists w; rewrite ?matchpg_etrace.
case ctu_et1: (ctree_mem ctu et1); last first.
  by case: (ctr_closed et) => //; right=> //; exists e; rewrite ctu_et1.
left; case: ifP (Pctu (etrace et)); rewrite ctu'et // /eqb /= => _ ctr_et.
have:= Pctu et1; rewrite ctu_et1 (negPf ctu'et1) => /negbFE.
rewrite (ctree_mem_rotlr _ ctr_ok) /= /et1 /edge_rot.
by case: (e) ctr_et; by [rewrite permt_id => -> | move=> _ ->; rewrite ?orbT].
Qed.

Lemma Kempe_validP ctu ctr gtr gtu :
    Kempe_valid ctu ctr gtr gtu -> forall et, size et = h.+1 ->
    ~~ ctree_mem ctu (etrace et) ->
  Kempe_coclosure P (ctrace et).
Proof.
move=> [[_ Dctu] _ _ _ closedP] et0 sz_et0 ct'et0.
pose et := ctrace (etrace et0) => P1 closedP1 P1et0.
have{P1et0} P1et: P1 et by rewrite [et]ctrace_permt; case/closedP1: P1et0.
have [_ [w0 etMw0 w0P1]] := closedP1 _ P1et.
move: (take _ w0) (matchg_cgram etMw0) => w Dw0.
have w0bal: gram_balanced 0 false w0.
  by have [_] := matchg_balanced etMw0; rewrite sumt_ctrace.
have{etMw0} et0Mw: matchpg Bstack0 (etrace et0) w by rewrite -matchg_pg -Dw0.
have [gt_w||et1 closedPet1 et1Mw] := closedP w.
- case/negP: ct'et0; rewrite /ctree_mem Dctu even_etrace /= addn_eq0.
  by apply/nandP; right; apply/match_countP; exists w.
- by apply/andP; rewrite (matchpg_size et0Mw) size_map sz_et0 -Dw0.
by apply/closedPet1/w0P1; rewrite // Dw0 matchg_pg // -Dw0.
Qed.

Lemma Kempe_completeP ctu ctr gtr gtu :
    Kempe_valid ctu ctr gtr gtu -> Kempe_complete 1 ctu ctr gtr gtu ->
    forall et, size et = h.+1 ->
  reflect (Kempe_coclosure P (ctrace et)) (~~ ctree_mem ctu (etrace et)).
Proof.
move=> valid_gt [ctu0 closed_et0] et0 sz_et0.
apply: (iffP idP) => [|clPet0]; first exact: (Kempe_validP valid_gt).
have{valid_gt} [[ctu_ok Dctu] _ Dgtr Dgtu closedP] := valid_gt.
have{ctu0} [|[ctr0 /(_ _)/idP-gtr0]] := ctu0.
  by rewrite ltnS leqn0 => /eqP/(ctree_size_proper ctu_ok)->.
have ctu0 et: sub_gt gtu et = 0 -> ~ ctree_mem ctu et.
  by rewrite /ctree_mem Dctu => ->; rewrite /gtree_sub match_count_0 ?if_same.
have gtu132 et: sub_gt gtu et = 0 -> sub_gt gtu (permt Eperm132 et) = 0.
  apply: contra_eq => /match_countP[w]; rewrite matchpg_flip => gtu_w et_w.
  by apply/match_countP; exists w.
have ctu132 et:
  ctree_mem ctu (permt Eperm132 (etrace et)) -> ctree_mem ctu (etrace et).
- rewrite {2}/ctree_mem Dctu even_etrace {1}/gtree_sub match_count_0 //=.
  by apply: contraNneq => /gtu132/ctu0/idP.
have Pctue et: ctree_mem ctu (etrace et)
                     = ctree_mem ctu et || ctree_mem ctu (permt Eperm132 et).
- have /orb_idl := ctu132 et; rewrite /etrace /etrace_perm.
  by case: ifP => _; rewrite ?permt_id ?etrace_id // orbC.
pose tr_ctu cet := exists2 et, cet = ctrace et & ctree_mem ctu (etrace et).
move Dcet0: (ctrace et0) => cet0 in clPet0; apply/negP=> ctu_et0.
have [cet [et -> ct_et2] | | et Pet []] := clPet0 tr_ctu; try by exists et0.
  set et2 := etrace et in ct_et2; split=> [g|].
    exists (permt g et); first by rewrite ctrace_permt.
    have [g2 <-]: exists g2, permt g2 et2 = permt g et.
      have [g2 Dg2] := compose_permt g (etrace_perm et) et2.
      exists g2; rewrite Dg2 /et2 /etrace /etrace_perm.
      by case: ifP; rewrite ?permt_id ?etrace_id.
    apply: contraLR ct_et2; rewrite !Pctue {2}/permt -map_comp => ct'et2.
    have [||gt'et] := closed_et0 et; rewrite ?ctr0 //.
      right; exists (inv_eperm g2 Color1); apply/negP; case/norP: ct'et2.
      by case: g2 => // _; congr (~~ ctree_mem _ _ = _); apply: eq_map => [] [].
    by apply/norP; split; apply/negP; apply: ctu0 => //; apply: gtu132.
  have /match_countP[w gt_w wMet2]: sub_gt gtu et2 != 0 by apply/eqP=> /ctu0.
  have /andP[sz_w bal_w] := Dgtu _ gt_w.
  exists (cgram 0 false w); first by rewrite matchpg_etrace -matchg_pg in wMet2.
  move=> cet1 cet1Mw; have [et1 Det1]: exists et1, cet1 = ctrace et1.
    have:= balanced_sumt0 bal_w cet1Mw.
    case/lastP: cet1 cet1Mw => [|et1 e _]; first by case w.
    rewrite -{1}cats1 /sumt foldr_cat /= addc0 => sum_et1_0.
    exists et1; congr rcons; rewrite -[e]add0c -{}sum_et1_0.
    by elim: et1 e => /= [|e1 et1 IHet] e; rewrite ?addcc // -addcA IHet.
  exists et1 => //; rewrite Det1 matchg_pg // in cet1Mw.
  rewrite /ctree_mem Dctu even_etrace addn_eq0; apply/nandP; right.
  by apply/match_countP; exists w; rewrite ?matchpg_etrace.
move=> cet Dcet ct_cet.
case: (closed_et0 cet); rewrite ?ctr0 -?Dcet //; first by left.
move=> gt'_cet; case/negP: ct_cet; rewrite Dctu even_etrace.
have ->: sub_gt gtu (etrace cet) = 0.
  by rewrite /etrace /etrace_perm; case: ifP => _; rewrite (permt_id, gtu132).
by rewrite addn0; apply/match_countP=> -[w1 /idPn[]].
Qed.

Lemma Kempe_valid_restrict ctr ctu gtu gtr :
    (forall et, ctree_mem ctr et -> P (ctrace et) /\ size et = h.+1) ->
  Kempe_valid ctu CtreeEmpty gtr gtu -> Kempe_valid ctu ctr gtr gtu.
Proof.
move=> Dctr [[Hctu Ectu] ? Dgtr Dgtu closedP]; split=> // et ct_et.
by case/Dctr: ct_et; split; first by exists (ctrace et).
Qed.

Lemma Kempe_valid_init :
  let ctu := ctree_init_tree h.+1 in let gtu := gtree_init_tree h.+1 in
  Kempe_valid ctu CtreeEmpty GtreeEmpty gtu.
Proof.
move: (ctree_init_tree_proper h.+1) (ctree_sub_init_tree h.+1).
move: (ctree_init_tree _) => ctu ctu_ok Dctu.
move: (gtree_init_tree _) (gtree_mem_init_tree h.+1) => gtu Dgtu.
split=> // [|[]//|w|w]; rewrite ?Dgtu //; split=> // et.
rewrite Dctu andbA andbC; case: (even_trace et) => //=.
by rewrite -match_count_balanced -(match_count_eq Dgtu) gtree_sub_empty.
Qed.

Lemma Kempe_complete_init ctr :
    (forall et, P (ctrace et) -> ctree_mem ctr (etrace et)) ->
    let ctu := ctree_init_tree h.+1 in let gtu := gtree_init_tree h.+1 in
  forall gtr, Kempe_complete (3 ^ h.+2) ctu ctr gtr gtu.
Proof.
move=> Pctr; split=> [|et norm [/Pctr | [e /negP init'e]]]; try by left.
  left; apply: (@leq_ltn_trans (3 ^ h.+1)); last by rewrite ltn_exp2l.
  by apply: ctree_max_size_proper; apply: ctree_init_tree_proper.
right; apply: contraNeq init'e => /match_countP[w].
rewrite gtree_mem_init_tree => /andP[sz_w bal_w] etMw.
rewrite /ctree_mem ctree_sub_init_tree !size_map -(matchpg_size etMw) sz_w.
rewrite -matchg_pg // {}/norm in etMw *; set pre := permt _.
rewrite !ctrace_permt !memc0_permt (matchg_memc0 etMw).
have -> /=: even_trace (pre (etrace et)).
  apply: etrans (even_etrace et); rewrite /even_trace /ttail proper_permt.
  case: (etrace et) => [|[] ett] //=; rewrite /permt -map_comp;
    by apply: (congr1 even_tail (eq_map _ _)); case e => [] [].
rewrite -[n in dyck n]odd_double_half -lt0n.
have -> et': odd (count_cbit1 et') = cbit1 (sumt et').
  by elim: et' => //= c et' IHet'; rewrite oddD IHet' cbit1_addc; case c.
by rewrite !sumt_permt sumt_ctrace !permc0 even_dyck_pos.
Qed.

End KempeTreeClosure.

Definition Kempe_tree (cp : cprog) : ctree :=
  if cprsize cp is h.+2 then
    let ctu := ctree_init_tree h.+1 in
    let gtu := gtree_init_tree h.+1 in
    let ctr := cpcolor cp in
    fst (Kempe_tree_closure h h.+2 ctu ctr gtu)
  else CtreeEmpty.

Theorem Kempe_treeP cp et :
   size et = (cprsize cp).-1 ->
 reflect (Kempe_coclosure (ring_trace (rot 1 (cpring (cpmap cp)))) (ctrace et))
         (~~ ctree_mem (Kempe_tree cp) (etrace et)).
Proof.
set Pcol := ring_trace _; rewrite /Kempe_tree.
move: (cpcolor cp) (ctree_mem_cpcolor cp) => ctr Dctr.
case Dh: (cprsize cp) => [|[|h]].
- by rewrite -size_ring_cpmap head_cpring in Dh.
- by case: et => // _; left=> P1 closedP1 /closedP1[_ [[] ]].
set ctu := ctree_init_tree _; set gtu := gtree_init_tree _.
have [] := @Kempe_tree_closure_correct h Pcol h.+2 ctu ctr gtu.
  apply: (Kempe_valid_restrict _ (Kempe_valid_init _ _)) => et1 /Dctr.
  case=> even_et1 [k gt_k Det1]; split.
    by rewrite /Pcol /ctrace -rot1_cons Det1 -trace_rot -map_rot; exists k.
  rewrite [LHS](canRL succnK (congr1 size Det1)) size_trace size_map.
  by rewrite size_ring_cpmap Dh.
case: (Kempe_tree_closure h _ _ _ gtu) => [ctu' [gtr gtu']] Pcol_valid Pcol_sz.
apply: (Kempe_completeP Pcol_valid (Pcol_sz _ _)); rewrite addn0.
apply: Kempe_complete_init => et1 [k col_k Det1]; apply/Dctr.
rewrite even_etrace /etrace; set g := etrace_perm et1.
split=> //; exists (g \o k); first exact: coloring_inj (@permc_inj g) col_k.
rewrite map_comp trace_permt sumt_permt.
by rewrite -[trace _](rotK 1) -trace_rot -map_rot -Det1 rotr1_rcons.
Qed.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal35.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_2  := ( Succ (Succ Zero)).
Definition lfind_example_3  := ( Succ (Succ Zero)).
Definition lfind_example_4  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_5  := ( Succ Zero).
Definition lfind_example_6  := ( Succ Zero).
Definition lfind_example_7  := ( Succ (Succ Zero)).
Definition lfind_example_8  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_9  := ( Succ Zero).
Definition lfind_example_10  := ( Succ (Succ Zero)).
Definition lfind_example_11  := ( Succ (Succ Zero)).
Definition lfind_example_12  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_13  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_14  := ( Succ Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_mult_succ_78_plus_commut/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 .


(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

From Coq Require Import ssreflect ssrbool ssrfun.

Require Import GHC.Base.
Require Import HsToCoq.Nat.
Require Import Proofs.GHC.Base.
Require Import Proofs.GHC.List.
Require Import Proofs.Data.Foldable.
Require Import Proofs.GhcTactics.

Require Import Coq.Lists.List.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import SetoidList.

Import ListNotations.

Open Scope Z_scope.

Set Bullet Behavior "Strict Subproofs".

(**
Some of this can migrate to [base-thy] at some point, but maybe some lemmas or
tactics are rather specific.
*)

Lemma eqlist_Foldable_elem : forall a (s s' : list a) `{EqLaws a},
      eqlistA (fun x y => x == y) s s' ->
      (forall a, Foldable.elem a s = Foldable.elem a s').
Proof.
  intros a s s' EQ EQL. intro H. induction H.
  intro x.
  rewrite elem_nil. auto.
  intro y.
  repeat rewrite -> elem_cons.
  rewrite IHeqlistA.
  erewrite eq_replace_r; eauto.
Qed.

Lemma elem_exists_in {a}`{Eq_ a} (x:a) (xs : list a) :  Foldable.elem x xs -> exists y, List.In y xs /\ (x == y).
Proof.
   elim: xs => [|y ys IH].
   hs_simpl. done.
   hs_simpl.
   move => /orP.
   move => [h1| h2].
   exists y. unfold List.In. split; auto.
   move: (IH h2) => [z [Inz eqz]].
   exists z. unfold List.In. split; auto.
Qed.

Lemma list_in_elem {a} `{Base.EqLaws a} (x:a) xs: List.In x xs -> Foldable.elem x xs.
Proof. elim: xs => [|y ys IH]. hs_simpl. auto.
hs_simpl. simpl. intuition. subst. apply /orP. left. eapply Eq_refl.
Qed.

Lemma forallb_imp:
  forall a P Q (xs : list a),
  forallb P xs = true ->
  (forall x, P x = true -> Q x = true) ->
  forallb Q xs = true.
Proof.
  induction xs; simpl; intros; auto.
  apply andb_prop in H.
  apply andb_true_intro.
  intuition.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals ssreflect.

From Coquelicot Require Import Rcomplements Derive RInt Hierarchy Derive_2d AutoDerive.

(** This file aims at proving that d'Alembert's formula defines a
function that is solution to the one-dimensional wave equation. We
also need to prove the regularity of this function. *)

Local Open Scope R_scope.

Ltac auto_derive_2 :=
  match goal with
  | |- is_derive_n ?f 2 ?x ?d =>
    auto_derive_fun f ;
    match goal with
    | |- (forall x, _ -> is_derive _ x (@?d x)) -> _ =>
      let H := fresh "H" in
      let u := fresh "u" in
      intro H ;
      apply (is_derive_ext d) ;
      [ intro u ;
        apply sym_eq, is_derive_unique ;
        apply H
      | auto_derive ] ;
      clear H
    end
  end.

Section DAlembert.

Parameter c : R.

Hypothesis Zc : c <> 0.

Parameter u0 : R -> R.

Hypothesis Du0 : forall x, ex_derive (fun u => u0 u) x.
Hypothesis D2u0 : forall x, ex_derive_n (fun u => u0 u) 2 x.

Section Alpha.

Definition alpha x t := 1/2 * (u0 (x + c * t) + u0 (x - c * t)).
Definition alpha20 x t := 1/2 * (Derive_n u0 2 (x + c * t) + Derive_n u0 2 (x - c * t)).
Definition alpha02 x t := c^2/2 * (Derive_n u0 2 (x + c * t) + Derive_n u0 2 (x - c * t)).

Lemma alpha_20_lim :
  forall x t, is_derive_n (fun u => alpha u t) 2 x (alpha20 x t).
Proof.
intros x t.
unfold alpha.
auto_derive_2.
repeat split ; apply Du0.
repeat split ; apply D2u0.
unfold alpha20, Derive_n, Rminus.
ring.
Qed.

Lemma alpha_02_lim :
  forall x t, is_derive_n (fun u => alpha x u) 2 t (alpha02 x t).
Proof.
intros x t.
unfold alpha.
auto_derive_2.
repeat split ; apply Du0.
repeat split ; apply D2u0.
unfold alpha02, Derive_n, Rminus, Rdiv.
ring.
Qed.

End Alpha.

Parameter u1 : R -> R.

Hypothesis Du1 : forall x, ex_derive (fun u => u1 u) x.

Lemma Cu1 : forall x, continuity_pt (fun u => u1 u) x.
intros x.
destruct (Du1 x) as (l,Hl).
apply derivable_continuous_pt.
unfold derivable_pt, derivable_pt_abs.
exists l.
now apply is_derive_Reals.
Qed.

Lemma continuity_implies_ex_Rint: forall f a b,
   (forall x, continuity_pt f x) -> ex_RInt f a b.
intros f a b H.
case (Rle_or_lt a b); intros H1.
apply ex_RInt_Reals_1.
apply continuity_implies_RiemannInt.
exact H1.
intros x _; apply H.
apply ex_RInt_swap.
apply ex_RInt_Reals_1.
apply continuity_implies_RiemannInt.
left; exact H1.
intros x _; apply H.
Qed.

Lemma Iu1: forall a b, ex_RInt (fun u => u1 u) a b.
intros a b.
apply continuity_implies_ex_Rint.
apply Cu1.
Qed.

Section Beta.

Definition beta (x t : R) := 1/(2*c) * RInt (fun u => u1 u) (x - c * t) (x + c * t).
Definition beta20 x t := 1/(2*c) * (Derive (fun u => u1 u) (x + c * t) - Derive (fun u => u1 u) (x - c * t)).
Definition beta01 x t := 1/2 * (u1 (x + c * t) + u1 (x - c * t)).
Definition beta02 x t := c/2 * (Derive (fun u => u1 u) (x + c * t) - Derive (fun u => u1 u) (x - c * t)).

Lemma beta20_lim :
  forall x t, is_derive_n (fun u => beta u t) 2 x (beta20 x t).
Proof.
intros x t.
unfold beta.
auto_derive_2.
(* . *)
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
repeat split ; apply Du1.
unfold beta20, Rminus.
ring.
Qed.

Lemma beta01_lim :
  forall x t, is_derive (fun u => beta x u) t (beta01 x t).
Proof.
intros x t.
unfold beta.
auto_derive.
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
unfold beta01, Rminus, Rdiv.
now field.
Qed.

Lemma beta02_lim :
  forall x t, is_derive_n (fun u => beta x u) 2 t (beta02 x t).
Proof.
intros x t.
unfold beta.
auto_derive_2.
split.
apply Iu1.
repeat split.
apply filter_forall.
apply Cu1.
apply filter_forall.
apply Cu1.
repeat split ; apply Du1.
unfold beta02, Rminus, Rdiv.
now field.
Qed.

End Beta.

Hypothesis f : R -> R -> R.

Section Gamma.

Definition gamma x t := 1/(2*c) * RInt (fun tau => RInt (fun xi => f xi tau) (x - c * (t - tau)) (x + c * (t - tau))) 0 t.
Definition gamma20 x t := 1/(2*c) * RInt (fun tau => Derive (fun u => f u tau) (x + c * (t - tau)) - Derive (fun u => f u tau) (x - c * (t - tau))) 0 t.
Definition gamma02 x t := (f x t + c/2 * RInt (fun tau => Derive (fun u => f u tau) (x + c * (t - tau)) - Derive (fun u => f u tau) (x - c * (t - tau))) 0 t).

Lemma gamma20_lim :
  forall x t, is_derive_n (fun u => gamma u t) 2 x (gamma20 x t).
Proof.
intros x t.
unfold gamma.
auto_derive_2.
repeat split.
exists (mkposreal _ Rlt_0_1).
simpl.
intros t' u' _ _.
repeat split.
apply continuity_implies_ex_Rint => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
admit. (* cont 2D -> 1D *)
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
apply derivable_continuous_pt.
admit. (* ??? *)
intros t' _.
admit.
repeat split.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
repeat split.
admit.
admit.
apply filter_forall => y.
admit.
intros t' _.
admit.
unfold gamma20.
apply f_equal.
apply RInt_ext => z _.
now rewrite 4!Rmult_1_l.
Admitted.

Lemma gamma02_lim :
  forall x t, is_derive_n (fun u => gamma x u) 2 t (gamma02 x t).
Proof.
intros x t.
unfold gamma.
auto_derive_2.
repeat split.
apply locally_2d_forall => y z.
admit.
intros t' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
simpl.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
simpl.
intros t' u' _ _.
repeat split.
apply continuity_implies_ex_Rint => y.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
admit.
repeat split.
apply locally_2d_forall => y z.
admit.
apply locally_2d_forall => y z.
admit.
intros x' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
admit.
apply locally_2d_forall => y z.
admit.
intros t' _.
admit.
apply filter_forall => y.
admit.
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
apply filter_forall => y.
apply continuity_implies_ex_Rint => z.
admit.
exists (mkposreal _ Rlt_0_1).
intros t' u' _ _.
repeat split.
admit.
admit.
unfold gamma02.
ring_simplify.
rewrite Rplus_opp_r Rmult_0_r Ropp_0 Rplus_0_r.
rewrite RInt_point Rmult_0_r Rplus_0_r.
apply Rplus_eq_reg_l with (- f x t).
field_simplify.
2: exact Zc.
rewrite Rmult_1_r.
rewrite /Rdiv Rmult_comm.
rewrite Rmult_assoc (Rmult_comm _ (/2)) -Rmult_assoc.
rewrite -[Rmult]/(@scal _ R_ModuleSpace) -RInt_scal.
rewrite -RInt_scal.
apply RInt_ext => u _.
rewrite /scal /= /mult /= /Rminus.
now field.
admit.
admit.
Admitted.

End Gamma.

End DAlembert.


Require Import Arith Max Min ZArith_base NArith Nnat.

Open Local Scope Z_scope.

(** * zify: the Z-ification tactic *)

(* This tactic searches for nat and N and positive elements in the goal and
   translates everything into Z. It is meant as a pre-processor for
   (r)omega; for instance a positivity hypothesis is added whenever
     - a multiplication is encountered
     - an atom is encountered (that is a variable or an unknown construct)

   Recognized relations (can be handled as deeply as allowed by setoid rewrite):
     - { eq, le, lt, ge, gt } on { Z, positive, N, nat }

   Recognized operations:
     - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
     - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
     - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
     - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N
*)

(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)

Ltac zify_unop_core t thm a :=
 (* Let's introduce the specification theorem for t *)
 let H:= fresh "H" in assert (H:=thm a);
 (* Then we replace (t a) everywhere with a fresh variable *)
 let z := fresh "z" in set (z:=t a) in *; clearbody z.

Ltac zify_unop_var_or_term t thm a :=
 (* If a is a variable, no need for aliasing *)
 let za := fresh "z" in
 (rename a into za; rename za into a; zify_unop_core t thm a) ||
 (* Otherwise, a is a complex term: we alias it. *)
 (remember a as za; zify_unop_core t thm za).

Ltac zify_unop t thm a :=
 (* if a is a scalar, we can simply reduce the unop *)
 let isz := isZcst a in
 match isz with
  | true => simpl (t a) in *
  | _ => zify_unop_var_or_term t thm a
 end.

Ltac zify_unop_nored t thm a :=
 (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
 let isz := isZcst a in
 match isz with
  | true => zify_unop_core t thm a
  | _ => zify_unop_var_or_term t thm a
 end.

Ltac zify_binop t thm a b:=
 (* works as zify_unop, except that we should be careful when
    dealing with b, since it can be equal to a *)
 let isza := isZcst a in
 match isza with
   | true => zify_unop (t a) (thm a) b
   | _ =>
       let za := fresh "z" in
       (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
       (remember a as za; match goal with
         | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
         | _ => zify_unop_nored (t za) (thm za) b
        end)
 end.

Ltac zify_op_1 :=
  match goal with
   | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
   | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
   | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
   | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b
   | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a
   | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a
   | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a
   | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a
  end.

Ltac zify_op := repeat zify_op_1.

(** II) Conversion from nat to Z *)

Definition Z_of_nat' := Z_of_nat.

Ltac hide_Z_of_nat t :=
  let z := fresh "z" in set (z:=Z_of_nat t) in *;
  change Z_of_nat with Z_of_nat' in z;
  unfold z in *; clear z.

Ltac zify_nat_rel :=
 match goal with
  (* I: equalities *)
  | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
  | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
  | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H
  | |- context [ @eq nat ?a ?b ] =>       rewrite (inj_eq_iff a b)
  (* II: less than *)
  | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H
  | |- (lt ?a ?b) => apply (inj_lt_rev a b)
  | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H
  | |- context [ lt ?a ?b ] =>       rewrite (inj_lt_iff a b)
  (* III: less or equal *)
  | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H
  | |- (le ?a ?b) => apply (inj_le_rev a b)
  | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H
  | |- context [ le ?a ?b ] =>       rewrite (inj_le_iff a b)
  (* IV: greater than *)
  | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H
  | |- (gt ?a ?b) => apply (inj_gt_rev a b)
  | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H
  | |- context [ gt ?a ?b ] =>       rewrite (inj_gt_iff a b)
  (* V: greater or equal *)
  | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H
  | |- (ge ?a ?b) => apply (inj_ge_rev a b)
  | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H
  | |- context [ ge ?a ?b ] =>       rewrite (inj_ge_iff a b)
 end.

Ltac zify_nat_op :=
 match goal with
  (* misc type conversions: positive/N/Z to nat *)
  | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
  | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
  | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H
  | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a)
  | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H
  | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a)

  (* plus -> Zplus *)
  | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H
  | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b)

  (* min -> Zmin *)
  | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H
  | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b)

  (* max -> Zmax *)
  | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H
  | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b)

  (* minus -> Zmax (Zminus ... ...) 0 *)
  | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H
  | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b)

  (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *)
  | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
  | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)

  (* mult -> Zmult and a positivity hypothesis *)
  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
        let H:= fresh "H" in
        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
  | |- context [ Z_of_nat (mult ?a ?b) ] =>
        let H:= fresh "H" in
        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *

  (* O -> Z0 *)
  | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
  | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)

  (* S -> number or Zsucc *)
  | H : context [ Z_of_nat (S ?a) ] |- _ =>
     let isnat := isnatcst a in
     match isnat with
      | true => simpl (Z_of_nat (S a)) in H
      | _ => rewrite (inj_S a) in H
     end
  | |- context [ Z_of_nat (S ?a) ] =>
     let isnat := isnatcst a in
     match isnat with
      | true => simpl (Z_of_nat (S a))
      | _ => rewrite (inj_S a)
     end

  (* atoms of type nat : we add a positivity condition (if not already there) *)
  | H : context [ Z_of_nat ?a ] |- _ =>
        match goal with
          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
          | H' : 0 <= Z_of_nat' a |- _ => fail
          | _ => let H:= fresh "H" in
                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
        end
  | |- context [ Z_of_nat ?a ] =>
        match goal with
          | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a
          | H' : 0 <= Z_of_nat' a |- _ => fail
          | _ => let H:= fresh "H" in
                 assert (H:=Zle_0_nat a); hide_Z_of_nat a
        end
 end.

Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.

(* III) conversion from positive to Z *)

Definition Zpos' := Zpos.
Definition Zneg' := Zneg.

Ltac hide_Zpos t :=
  let z := fresh "z" in set (z:=Zpos t) in *;
  change Zpos with Zpos' in z;
  unfold z in *; clear z.

Ltac zify_positive_rel :=
 match goal with
  (* I: equalities *)
  | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
  | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
  | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H
  | |- context [ @eq positive ?a ?b ] =>       rewrite (Zpos_eq_iff a b)
  (* II: less than *)
  | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
  | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
  (* III: less or equal *)
  | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
  | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
  (* IV: greater than *)
  | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
  | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
  (* V: greater or equal *)
  | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
  | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
 end.

Ltac zify_positive_op :=
 match goal with
  (* Zneg -> -Zpos (except for numbers) *)
  | H : context [ Zneg ?a ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zneg a) with (Zneg' a) in H
      | _ => change (Zneg a) with (- Zpos a) in H
     end
  | |- context [ Zneg ?a ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zneg a) with (Zneg' a)
      | _ => change (Zneg a) with (- Zpos a)
     end

  (* misc type conversions: nat to positive *)
  | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
  | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)

  (* Pplus -> Zplus *)
  | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H
  | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b))

  (* Pmin -> Zmin *)
  | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H
  | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b)

  (* Pmax -> Zmax *)
  | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H
  | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b)

  (* Pminus -> Zmax 1 (Zminus ... ...) *)
  | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
  | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)

  (* Psucc -> Zsucc *)
  | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
  | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)

  (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
  | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
  | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)

  (* Pmult -> Zmult and a positivity hypothesis *)
  | H : context [ Zpos (Pmult ?a ?b) ] |- _ =>
        let H:= fresh "H" in
        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
  | |- context [ Zpos (Pmult ?a ?b) ] =>
        let H:= fresh "H" in
        assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *

  (* xO *)
  | H : context [ Zpos (xO ?a) ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
      | _ => rewrite (Zpos_xO a) in H
     end
  | |- context [ Zpos (xO ?a) ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xO a)) with (Zpos' (xO a))
      | _ => rewrite (Zpos_xO a)
     end
  (* xI *)
  | H : context [ Zpos (xI ?a) ] |- _ =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
      | _ => rewrite (Zpos_xI a) in H
     end
  | |- context [ Zpos (xI ?a) ] =>
     let isp := isPcst a in
     match isp with
      | true => change (Zpos (xI a)) with (Zpos' (xI a))
      | _ => rewrite (Zpos_xI a)
     end

  (* xI : nothing to do, just prevent adding a useless positivity condition *)
  | H : context [ Zpos xH ] |- _ => hide_Zpos xH
  | |- context [ Zpos xH ] => hide_Zpos xH

  (* atoms of type positive : we add a positivity condition (if not already there) *)
  | H : context [ Zpos ?a ] |- _ =>
        match goal with
         | H' : Zpos a > 0 |- _ => hide_Zpos a
         | H' : Zpos' a > 0 |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
        end
  | |- context [ Zpos ?a ] =>
        match goal with
         | H' : Zpos a > 0 |- _ => hide_Zpos a
         | H' : Zpos' a > 0 |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a
        end
 end.

Ltac zify_positive :=
 repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.

(* IV) conversion from N to Z *)

Definition Z_of_N' := Z_of_N.

Ltac hide_Z_of_N t :=
  let z := fresh "z" in set (z:=Z_of_N t) in *;
  change Z_of_N with Z_of_N' in z;
  unfold z in *; clear z.

Ltac zify_N_rel :=
 match goal with
  (* I: equalities *)
  | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
  | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
  | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H
  | |- context [ @eq N ?a ?b ] =>       rewrite (Z_of_N_eq_iff a b)
  (* II: less than *)
  | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
  | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b)
  | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
  | |- context [ (?a<?b)%N ] =>       rewrite (Z_of_N_lt_iff a b)
  (* III: less or equal *)
  | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H
  | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b)
  | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H
  | |- context [ (?a<=?b)%N ] =>       rewrite (Z_of_N_le_iff a b)
  (* IV: greater than *)
  | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H
  | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b)
  | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H
  | |- context [ (?a>?b)%N ] =>       rewrite (Z_of_N_gt_iff a b)
  (* V: greater or equal *)
  | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H
  | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b)
  | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H
  | |- context [ (?a>=?b)%N ] =>       rewrite (Z_of_N_ge_iff a b)
 end.

Ltac zify_N_op :=
 match goal with
  (* misc type conversions: nat to positive *)
  | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
  | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
  | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H
  | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a)
  | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H
  | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a)
  | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H
  | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0

  (* Nplus -> Zplus *)
  | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H
  | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b)

  (* Nmin -> Zmin *)
  | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H
  | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b)

  (* Nmax -> Zmax *)
  | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H
  | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b)

  (* Nminus -> Zmax 0 (Zminus ... ...) *)
  | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
  | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)

  (* Nsucc -> Zsucc *)
  | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
  | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)

  (* Nmult -> Zmult and a positivity hypothesis *)
  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ =>
        let H:= fresh "H" in
        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
  | |- context [ Z_of_N  (Nmult ?a ?b) ] =>
        let H:= fresh "H" in
        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *

  (* atoms of type N : we add a positivity condition (if not already there) *)
  | H : context [ Z_of_N ?a ] |- _ =>
        match goal with
         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
         | H' : 0 <= Z_of_N' a |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
        end
  | |- context [ Z_of_N ?a ] =>
        match goal with
         | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a
         | H' : 0 <= Z_of_N' a |- _ => fail
         | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a
        end
 end.

Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.

(** The complete Z-ification tactic *)

Ltac zify :=
 repeat progress (zify_nat; zify_positive; zify_N); zify_op.


Fixpoint fact (x:nat) :=
  match x with
    | 0 => 1
    | S x' => x * fact x'
  end.

fact _|_ =>

match _|_ with
  | 0 => 1
  | S x' => x * fact x'
end


Lemma foo : True.
evar (n : nat -> nat).
pose (m := fix aux m :=
      match m with
        | 0 => 0
        | S _ => aux (n m)
      end).
pose (eq_refl : n = fun n => n).
assert(eq_refl : m 1 = m 2).
apply eq_refl.
Qed.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Diophantine Constraint Solvability (H10C_SAT)
  to:
    Square Diophantine Constraint Solvability (H10SQC_SAT)
*)

Require Import List Lia.
Require Cantor.
Import ListNotations.

Require Import Undecidability.DiophantineConstraints.H10C.

Require Import ssreflect ssrbool ssrfun.

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

Module Argument.

Notation encode := Cantor.to_nat.
Notation decode := Cantor.of_nat.
Opaque Cantor.to_nat Cantor.of_nat.

Section Reduction.
(* given instance of Diophantine constraint solvability *)
Context (cs: list h10c).

(* variable renaming *)
Definition ζ (x: nat) := encode (x, 0).

(*
  fresh variables
  θ x y 0 ~ x^2
  θ x y 1 ~ y^2
  θ x y 2 ~ x^2 + y^2
  θ x y 3 ~ x + y
  θ x y 4 ~ (x + y)^2
  θ x y 5 ~ 2xy
*)
Definition θ (x y t: nat) := encode (x, 1 + encode (y, t)).

(* x * y = z <-> x^2 + 2z + y^2 = (x + y)^2 *)
Definition h10c_to_h10sqcs (c : h10c) : list h10sqc :=
  match c with
  | h10c_one x      => [h10sqc_one (ζ x)]
  | h10c_plus x y z => [h10sqc_plus (ζ x) (ζ y) (ζ z)]
  | h10c_mult x y z => [
      h10sqc_sq (ζ x) (θ x y 0); h10sqc_sq (ζ y) (θ x y 1); h10sqc_plus (θ x y 0) (θ x y 1) (θ x y 2);
      h10sqc_plus (ζ x) (ζ y) (θ x y 3); h10sqc_sq (θ x y 3) (θ x y 4);
      h10sqc_plus (ζ z) (ζ z) (θ x y 5); h10sqc_plus (θ x y 2) (θ x y 5) (θ x y 4)]
  end.

(* constructed instance of square Diophantine constraint solvability *)
Definition sqcs := flat_map h10c_to_h10sqcs cs.

Section Transport.
(* solution of the given instance cs *)
Context (φ : nat -> nat) (Hφ: forall c, In c cs -> h10c_sem c φ).

(* solution of the constructed instance sqcs *)
Definition φ' (n: nat) :=
  match decode n with
  | (x, 0) => φ x
  | (x, S m) =>
    match decode m with
    | (y, 0) => (φ x) * (φ x)
    | (y, 1) => (φ y) * (φ y)
    | (y, 2) => (φ x) * (φ x) + (φ y) * (φ y)
    | (y, 3) => (φ x) + (φ y)
    | (y, 4) => ((φ x) + (φ y)) * ((φ x) + (φ y))
    | (y, 5) => (φ x) * (φ y) + (φ x) * (φ y)
    | (_, _) => 0
    end
  end.

Lemma h10c_to_h10sqcs_spec {c} : h10c_sem c φ -> Forall (h10sqc_sem φ') (h10c_to_h10sqcs c).
Proof.
  case: c => /=.
  - move=> x ?. constructor; last done.
    by rewrite /= /ζ /φ' Cantor.cancel_of_to.
  - move=> x y z ?. constructor; last done.
    by rewrite /= /ζ /φ' ?Cantor.cancel_of_to.
  - move=> x y z ?. (do ? constructor);
      rewrite /= /ζ /φ' ?Cantor.cancel_of_to /= ?Cantor.cancel_of_to; by nia.
Qed.

End Transport.

Lemma transport : H10C_SAT cs -> H10SQC_SAT sqcs.
Proof.
  move=> [φ Hφ]. exists (φ' φ).
  move: Hφ. rewrite -?Forall_forall /sqcs Forall_flat_map.
  apply: Forall_impl => ?. by move /h10c_to_h10sqcs_spec.
Qed.

Section InverseTransport.
(* solution of the constructed instance sqcs *)
Context (φ' : nat -> nat) (Hφ': forall c, In c sqcs -> h10sqc_sem φ' c).

(* solution of the given instance cs *)
Definition φ (x: nat) := φ' (ζ x).

Lemma h10c_of_h10sqcs_spec {c} : Forall (h10sqc_sem φ') (h10c_to_h10sqcs c) -> h10c_sem c φ.
Proof.
  case: c => /=.
  - by move=> x /Forall_cons_iff [].
  - by move=> x y z /Forall_cons_iff [].
  - move=> x y z. do 7 (move=> /Forall_cons_iff /and_comm []).
    rewrite /= /φ. by nia.
Qed.

End InverseTransport.

Lemma inverse_transport : H10SQC_SAT sqcs -> H10C_SAT cs.
Proof.
  move=> [φ' Hφ']. exists (φ φ').
  move: Hφ'. rewrite -?Forall_forall /sqcs Forall_flat_map.
  apply: Forall_impl => ?. by move=> /h10c_of_h10sqcs_spec.
Qed.

End Reduction.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* Diophantine Constraint Solvability many-one reduces to Square Diophantine Constraint Solvability *)
Theorem reduction : H10C_SAT ⪯ H10SQC_SAT.
Proof.
  exists (fun cs => Argument.sqcs cs) => cs. constructor.
  - exact: Argument.transport.
  - exact: Argument.inverse_transport.
Qed.


Parameter object : Type.
Definition PN   : Type := object.
Definition VP   : Type := object -> Prop.

Definition NP    : Type := VP -> Prop .   (* NP := (PN -> Prop) -> Prop *)
Definition UsePN : PN -> NP := fun pn vp => vp pn.
Definition Cl   : Type := Prop .

Definition PredVP  : NP -> VP -> Cl := fun np vp => np vp.
Definition V    : Type := object -> Prop.
Definition UseV  : V -> VP := fun v => v.
Definition S    : Type := Prop .

Definition Pol  : Type := Prop -> Prop .

Definition Pos : Pol := fun p => p.
Definition Neg : Pol := fun p => not p.
Definition UseCl : Pol -> Cl -> S :=
  fun pol c => pol c.

Parameter AP   : Type.
Parameter A    : Type.
Parameter CN   : Type.
Parameter Det  : Type.
Parameter N    : Type.
Parameter V2   : Type.
Parameter AdA  : Type.
Parameter Conj : Type.

Parameter ComplV2 : V2 -> NP -> VP.
Parameter DetCN   : Det -> CN -> NP.
Parameter ModCN   : AP -> CN -> CN.
Parameter CompAP  : AP -> VP.
Parameter AdAP    : AdA -> AP -> AP.
Parameter ConjS   : Conj -> S  -> S  -> S.
Parameter ConjNP  : Conj -> NP -> NP -> NP.
Parameter UseN    : N -> CN.
Parameter UseA    : A -> AP.
Parameter some_Det : Det.
Parameter every_Det : Det.
Parameter we_NP   : NP.
Parameter you_NP : NP.
Parameter very_AdA : AdA.
Parameter and_Conj : Conj.
Parameter or_Conj : Conj.

Parameter man_N :  N.
Parameter woman_N : N .
Parameter house_N :  N.
Parameter tree_N : N .
Parameter   big_A : A .
Parameter small_A : A .
Parameter green_A : A .
Parameter  walk_V : V  .
Parameter arrive_V : V .
Parameter love_V2 : V2  .
Parameter please_V2 : V2 .
Parameter john_PN : PN .
Parameter mary_PN : PN.

Definition everyoneNP : NP := fun vp => forall x, vp x.

Theorem everyone:  everyoneNP walk_V-> walk_V john_PN. cbv. intros. apply H. Qed.


Require Export Term.
Require Export Formula.
Require Export SignedSubformula.
Require Export Sequent.

Require Import Base.Lists.
Require Import Base.Permutation.
Require Import Tactics.FormulaEquality.
Require Import Tactics.TermEquality.
Require Import Tactics.WellFormedFormulaNoProofs.
Require Import Tactics.TermHasSortNoFormulas.

Module Type Consistency (G : GroundInfo) (GTerm : Term G) (GFormula : Formula G GTerm)
       (TE : TermEquality G GTerm) (FE : FormulaEquality G GTerm GFormula TE)
       (SSFormula : SignedSubformula G GTerm GFormula TE FE)
       (THS : TermHasSort'' G GTerm TE)
       (WFF : WellFormedFormula' G GTerm TE THS GFormula FE)
       (PF : Sequent G GTerm GFormula TE FE THS WFF).
  Import G. Import GTerm. Import GFormula. Import SSFormula. Import PF.
  Import ListNotations. Import THS. Import WFF.

  Inductive Falsy : flafolFormula -> Prop :=
    falseFalsy : Falsy FF
  | saysFalsy : forall p labl phi, Falsy phi -> Falsy (p □ ⟨ labl ⟩ phi).

  Hint Constructors Falsy.

  Theorem FalsySubst' : forall (x : var) (t : flafolTerm) (phi : flafolFormula),
      Falsy phi -> Falsy (phi f[x ↦ t]).
  Proof.
    intros x t phi H; induction phi; inversion H; simpl; constructor; auto.
  Qed.

  Theorem FalsySubst'' : forall (x : var) (t : flafolTerm) (phi : flafolFormula),
      Falsy (phi f[x ↦ t]) -> Falsy phi.
  Proof.
    intros x t phi H; induction phi; inversion H; simpl; try (constructor; auto).
    all: destruct (varEqDec x v); inversion H1.
    all: inversion H0.
  Qed.

  Theorem FalsySubst : forall (x : var) (t : flafolTerm) (phi : flafolFormula),
      Falsy phi <-> Falsy (phi f[ x ↦ t]).
  Proof.
    intros x t phi; split; [apply FalsySubst' | apply FalsySubst''].
  Qed.

  Open Scope formula_scope. Open Scope proof_scope.

  Ltac PositiveConsistency :=
    repeat match goal with
           | [ H : @InBool Belief BeliefEqDec ?a ?l = true |- _ ] =>
             match goal with
             | [_ : In ?a ?l |- _ ] => fail 1
             | _ => pose proof ((proj1 InBoolSpec) H)
             end
           | [ H :In ?a ?l |- _ ] =>
             match goal with
             | [ _ : InBool BeliefEqDec ?a ?l = true |- _ ] => fail 1
             | _ => pose proof ((proj2 InBoolSpec) H)
             end
           | [ H : _ ⊢[ _ ] (_ ⊑ _) @ _ |- _ ] => clear H
           | [ H : _ ⊢[ _ ] (canRead _ _) @ _ |- _ ] => clear H
           | [ H : _ ⊢[ _ ] (canWrite _ _) @ _ |- _ ] => clear H
           | [ IH : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) ?Gamma = true -> (psi0 s: Neg) ≤s (phi0 s: Neg) -> ~ Falsy psi0) ->
                    Falsy ?chi -> False,
                    H : ?Gamma ⊢[ _ ] ?chi @ _
               |- False] =>
             apply IH; auto
           | [ H : In _ (?Delta ++ ?Gamma) |- _ ] => apply in_app_or in H; destruct H
           | [ H : In _ (_ :: _) |- _ ] => destruct H
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ _ :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : Path (?phi1 @?m1) ?Delta,
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1 ] =>
             apply (H0 m1 phi1); [apply in_or_app; left | ]; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ _ :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : Path (?phi1 @ ?m1) ?Gamma,
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1 ] =>
             apply (H0 m1 phi1); [apply in_or_app; right; right | ]; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?phi ?psi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : (?phi @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (phi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f phi psi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := phi s: Neg);
             [rewrite H4; auto | constructor]
           | [ H0 : (forall (m0 : Modality) (phi0 psi0 : flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?phi ?psi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : (?psi @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi1, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (psi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f phi psi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := psi s: Neg);
             [rewrite H4; auto | constructor]
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?phi ?psi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : ((?f ?phi ?psi) @ ?m ) = (?phi1 @ ?m1),
                         H2 : (?psi0, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (f phi psi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f phi psi)); [apply in_or_app; right; left; auto | ];
             rewrite H4; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula) pc,
                        Path (phi0 @ m0) (?Delta ++ ((?f ?x ?phi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : (?phi @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi0, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (phi = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f x phi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := phi s: Neg);
             [rewrite H4; auto | constructor]; auto
           | [ H0 : (forall (m0 : Modality) (phi0 psi0: flafolFormula),
                        Path (phi0 @ m0) (?Delta ++ ((?f ?x ?phi) @ ?m) :: ?Gamma) ->
                        (psi0, Neg) ≤s (phi0, Neg) -> ~ Falsy psi0),
                    H1 : ((?phi f[?x ↦ ?t]) @ ?m) = (?phi1 @ ?m1),
                         H2 : (?psi0, Neg) ≤s (?phi1, Neg)
               |- ~ Falsy ?psi1] =>
             let H3 := fresh "H" in
             let H4 := fresh "H" in
             assert (m = m1) as H3 by (inversion H1; auto);
             assert (phi f[x ↦ t] = phi1) as H4 by (inversion H1; auto);
             apply (H0 m (f x phi)); [apply in_or_app; right; left; auto | ];
             apply SSTrans with (psi := (phi f[x ↦ t]) s: Neg);
             [rewrite H4; auto | constructor]; auto
           | [ |- forall _, _ ] => intro
           end.

  Hint Constructors SignedSubformulaOf.

  Definition phiBelief (b : Belief) : flafolFormula :=
    match b with
    | mkBelief phi m => phi
    end.

  Theorem PositiveConsistency' : forall {Gamma : Context} {b : Belief},
      (forall m phi, Path (phi @ m) Gamma -> ~((FF s: Neg) ≤s (phi s: Neg))) -> Gamma ⊢ b -> (phiBelief b <> FF).
  Proof.
    intros Gamma b H pf.
    induction pf; subst; auto; try (simpl; discriminate).
    all: try (repeat match goal with
                     | [ H : (forall (m : Modality) (phi : flafolFormula), Path (phi @ m) ?Gamma -> ~ (FF, Neg) ≤s (phi, Neg)), p : Path (?phi @ ?m) ?Gamma |- ~ (FF, Neg) ≤s (?phi, Neg) ] => apply (H m phi p)
                     | [ H : ?P -> ?Q |- ?Q ] => apply H; intros
                     | [ H : Path ?b1 (_ :: ?Gamma) |- _] => apply PathToIn in H; destruct H
                     | [ H : In ?b ?Gamma |- _ ] => apply (InToPath BeliefEqDec) in H
                     | [ H : ?phi @ ?m1 = ?psi @ ?m2 |- _ ] =>
                       match goal with
                       | [ _ : phi = psi, _ : m1 = m2 |- _ ] => fail 1
                       | _ => inversion H
                       end
                     end) .
    - destruct b. intro. simpl in H0. apply (H m f p0).
      rewrite H0; auto.
    - exfalso; apply (H m FF p1); auto.
    - intro Hphi0. apply (H m (phi & psi) pth).
      inversion H0; eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (phi & psi) pth).
      inversion H0; eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (phi ⊕ psi) pth).
      inversion H0; eapply SSTrans; eauto.
    - intro H1; apply (H m (phi ==⟨ l ⟩> psi) pth).
      inversion H2; eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (∀ sigma; phi) pth).
      eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (∃ VarSort y; phi) pth).
      eapply SSTrans; eauto.
    - intro Hphi0; apply (H m (p □ ⟨ lab ⟩ phi) pth).
      pose proof (provenProperContext pf).
      apply ConsProperContext in H1.
      destruct H1.
      inversion H1. inversion H5.
      inversion H2; eapply SSTrans; eauto.
    - rewrite <- H2. apply H with (m := CollapseDoubleInModality pth); auto.
    - rewrite <- H2. apply H with (m := m); auto.
    - rewrite <- H2. apply H with (m := m); auto.
    - rewrite <- H2; apply H with (m := m); auto.
  Qed.

  Theorem PositiveConsistency : forall (Gamma : Context) (m : Modality),
      (forall m' phi, Path (phi @ m') Gamma -> ~ ((FF s: Neg) ≤s (phi s: Neg))) ->
      Gamma ⊢ FF @ m -> False.
  Proof.
    intros Gamma m H H0.
    eapply @PositiveConsistency' with (b := FF @ m); eauto.
  Qed.

  Theorem Consistency : forall m, [] ⊢ FF @ m -> False.
  Proof.
    intros m H; eapply PositiveConsistency; eauto.
    intros m' phi H0; inversion H0.
  Qed.

End Consistency.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

Definition Natural {C D: Category} {F G: Functor C D} (α: ∀ x, D (F x) (G x)): Prop :=
  ∀ {x y} (m: C x y), map G m ∘ α _ == α _ ∘ map F m.
Existing Class Natural.

Definition natural {C D: Category} {F G: Functor C D} {α: ∀ x, D (F x) (G x)} `{N:Natural C D F G α}:
  ∀ {x y} (m: C x y), map G m ∘ α _ == α _ ∘ map F m := N.

#[program]
Definition Funct (K L: Category): Category := {|
  Obj := Functor K L ;
  Mor A B := { f | Natural f } ;
  Mor_Setoid _ _ := {| equiv f g := ∀ x, f x == g x |} ;
  id A _ := id _ ;
  compose _ _ _ f g _ := f _  ∘ g _  ;
|}.

Next Obligation.
Proof.
  exists.
  all: unfold Reflexive, Symmetric, Transitive; cbn.
  - intros.
    reflexivity.
  - intros ? ? p ?.
    symmetry.
    apply (p _).
  - intros ? ? ? p q ?.
    rewrite (p _), (q _).
    reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? ?.
  Reflect.category.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? ?.
  repeat rewrite compose_assoc.
  rewrite natural.
  repeat rewrite <- compose_assoc.
  apply compose_compat.
  1: reflexivity.
  rewrite natural.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q ?.
  cbn in *.
  rewrite (p _), (q _).
  reflexivity.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.

Require Export Wf.InfGen.
Require Export Wf.Inst.
Require Export Wf.U.
Require Export Wf.Uss.

Theorem Inst_wf : forall (env : Env) (sch : Sch) (a : A) (ty : Ty),
    env |= sch ≤ ⟨a⟩ ty
  -> wf(env)
  -> env |=ty sch
  -> wf(env ::o ⟦⟨a⟩ S_Mono ty⟧).
Proof. exact Wf.Inst.Inst_Wf. Qed.

Theorem U_Wf : forall (env__in : Env) (eqs : Eqs) (env__out : Env),
    U env__in eqs env__out
  -> wf(env__in)
  -> wf(env__out).
Proof. exact Wf.U.U_Wf. Qed.

Theorem Us_Wf : forall (env__in : Env) (eqs : Eqs) (env__out : Env) (sub : Sub),
    Us env__in eqs env__out sub
  -> wf(env__in)
  -> wf(env__out).
Proof. exact Wf.U.Us_Wf. Qed.

Theorem Uss_Wf : forall (env__in : Env) (eqs__in : Eqs) (env__out : Env) (eqs__out : Eqs) (sub : Sub),
    Uss env__in eqs__in env__out eqs__out sub
  -> wf(env__in)
  -> wf(Sub_app_Env env__out sub).
Proof. exact Wf.Uss.Uss_Wf. Qed.

Theorem Inf_Wf : forall (env__in : Env) (e : e) (a : A) (ty : Ty) (env__out : Env),
    env__in |= e ▸ ⟨a⟩ ty =| env__out
  -> wf(env__in)
  -> wf(env__out ::o ⟦⟨a⟩ S_Mono ty⟧).
Proof. exact (proj1 Inf_Gen_Wf). Qed.

Theorem Gen_Wf : forall (env__in : Env) (e : e) (sch : Sch) (env__out : Env),
    env__in |= e ▸ sch =| env__out
  -> wf(env__in)
  -> wf(env__out ::o ⟦sch⟧).
Proof. exact (proj2 Inf_Gen_Wf). Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.

(* Why3 assumption *)
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.
Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.
Implicit Arguments old.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Hint Constructors infix_mnmngt.
Require Import Why3. Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem reducible_or_value : forall (t:term), (exists tqt:term,
  (infix_mnmngt t tqt)) \/ (is_value t).
induction t; intuition.
right; simpl; auto.
right; simpl; auto.
left.
destruct H as (t1',h1).
exists (App t1' t2); intuition. ae.
left.
destruct H as (t1',h1).
exists (App t1' t2); intuition. ae.
left.
destruct H0 as (t2',h2).
exists (App t1 t2'); intuition. ae.
(* is_value t1 && is_value t2 *)
destruct t1; intuition.
destruct t1_1; intuition.
simpl in H.
right; red; intuition.
simpl in H.
left; intuition.
exists t1_2; intuition.
apply (red_K Hole); auto. ae.
simpl in H.
destruct t1_1_1; intuition.
left.
rename t1_1_2 into v1. rename t1_2 into v2. rename t2 into v3.
exists (App (App v1 v3) (App v2 v3)); intuition.
apply (red_S Hole); auto.
ae.
Qed.


Require Import Coq.omega.Omega.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Crypto.Util.Strings.Equality.
Require Import Crypto.Util.Strings.Ascii.

Local Open Scope list_scope.
Local Open Scope string_scope.

(** *** String concatenation *)
(** [concat sep sl] concatenates the list of strings [sl], inserting
    the separator string [sep] between each. *)

Definition concat (sep : string) : list string -> string
  := fix concat (sl : list string) : string
       := match sl with
          | nil => EmptyString
          | cons x nil => x
          | cons x xs => x ++ sep ++ concat xs
          end.

(** *** Conversion to and from lists *)
Fixpoint to_list (s : string) : list ascii
  := match s with
     | EmptyString => nil
     | String x xs => cons x (to_list xs)
     end.
Fixpoint of_list (s : list ascii) : string
  := match s with
     | nil => EmptyString
     | cons x xs => String x (of_list xs)
     end.

Lemma to_of_list s : to_list (of_list s) = s.
Proof. induction s as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.
Lemma of_to_list s : of_list (to_list s) = s.
Proof. induction s as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.

Lemma of_list_app s1 s2 : of_list (s1 ++ s2) = of_list s1 ++ of_list s2.
Proof. induction s1 as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.
Lemma to_list_app s1 s2 : to_list (s1 ++ s2) = (to_list s1 ++ to_list s2)%list.
Proof. induction s1 as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.

Definition lift_list_function (f : list ascii -> list ascii) (s : string) : string
  := of_list (f (to_list s)).

(** *** Mapping over a string *)
(** [map f s] applies function [f] in turn to all the characters of
    [s], creating a new string to return *)
Definition map (f : ascii -> ascii) : string -> string
  := lift_list_function (List.map f).
Lemma map_step f s
  : map f s = match s with
              | EmptyString => EmptyString
              | String x xs => String (f x) (map f xs)
              end.
Proof. destruct s; reflexivity. Qed.

(** *** string reversal *)
(** [rev s] reverses the string [s] *)
Definition rev : string -> string
  := lift_list_function (@List.rev _).

Lemma rev_step s
  : rev s
    = match s with
      | EmptyString => EmptyString
      | String x xs => rev xs ++ String x EmptyString
      end.
Proof. destruct s; cbn; rewrite ?of_list_app; reflexivity. Qed.

(** *** trimming a string *)
(** [trim s] returns a copy of the argument, without leading and trailing
    whitespace. The characters regarded as whitespace are: ' ',
    '\012', '\n', '\r', and '\t'. *)
Fixpoint ltrim (s : string) : string
  := match s with
     | EmptyString => EmptyString
     | String x xs
       => if ((x =? " ") || (x =? NewPage) || (x =? LF) || (x =? CR) || (x =? Tab))%char%bool
          then ltrim xs
          else s
     end.
Definition rtrim (s : string) : string
  := rev (ltrim (rev s)).

Definition trim (s : string) : string
  := rtrim (ltrim s).

(** Finds last occurence of [s1] in [s2], where the first character
    after [s1] is at position less than or equal to [n + 1].  Returns
    the location of the first character of [s1] in that occurence in
    [s2], if it exists. *)

Definition rindex (n : nat) (s1 s2 : string) : option nat :=
  option_map
    (fun n => length s2 - n - length s1)
    (index (length s2 - n - 1) (rev s1) (rev s2)).

Lemma append_alt s1 s2 : s1 ++ s2 = of_list (to_list s1 ++ to_list s2).
Proof. rewrite of_list_app, !of_to_list; reflexivity. Qed.
Lemma append_empty_r s : s ++ "" = s.
Proof.
  rewrite append_alt; cbn; rewrite List.app_nil_r, of_to_list. reflexivity.
Qed.
Lemma append_assoc s1 s2 s3 : s1 ++ (s2 ++ s3) = (s1 ++ s2) ++ s3.
Proof.
  rewrite !append_alt, ?to_of_list; cbn; rewrite List.app_assoc; reflexivity.
Qed.

Lemma length_substring n1 n2 s
  : length (substring n1 n2 s) = Nat.min n2 (length s - n1).
Proof.
  revert n1 n2; induction s as [|a s IHs]; intros; cbn.
  { destruct n1, n2; cbn; reflexivity. }
  { destruct n1; [ destruct n2 | ]; cbn; rewrite ?IHs, <- ?Minus.minus_n_O; reflexivity. }
Qed.

Lemma length_append s1 s2 : length (s1 ++ s2) = length s1 + length s2.
Proof.
  revert s1; induction s1 as [|a s1 IHs1]; cbn; congruence.
Qed.

(** *** membership *)
(** [contains n s1 s2] returns [true] if [s1] occurs in [s2] starting
    at position [n], and false otherwise *)
Definition contains (n : nat) (s1 s2 : string) : bool :=
  match index n s1 s2 with
  | Some _ => true
  | None => false
  end.

Section strip_prefix_cps.
  Context {R} (found : string -> R)
          (remaining : string -> string -> R).

  Fixpoint strip_prefix_cps (sepch : ascii) (sep : string) (s2 : string) {struct s2} : R
    := match s2 with
       | EmptyString => remaining (String sepch sep) s2
       | String x xs
         => if ascii_beq sepch x
            then match sep with
                 | EmptyString => found xs
                 | String sepch sep
                   => strip_prefix_cps sepch sep xs
                 end
            else remaining (String sepch sep) s2
       end.
End strip_prefix_cps.

(** *** splitting a string *)
(** [split sep s] returns the list of all (possibly empty) substrings
    of [s] that are delimited by the [sep] character.

    The function's output is specified by the following invariants:

    - The list is not empty.

    - Concatenating its elements using sep as a separator returns a
      string equal to the input

        [concat sep (split sep s) = s]

    - No string in the result contains [sep] as a substring, unless
      [sep] is the empty string, in which case this function returns
      [map (fun ch => String ch "") (to_list s)] if [s] is non-empty,
      and [""::nil] if [s] is also empty. *)

Fixpoint split_helper (sepch : ascii) (sep : string) (s : string) (rev_acc : string) {struct s}
  : list string
  := strip_prefix_cps
       (fun s => rev rev_acc :: split_helper sepch sep s "")
       (fun _ _
        => match s with
           | EmptyString => rev rev_acc :: nil
           | String x xs
             => split_helper sepch sep xs (String x rev_acc)
           end)
       sepch sep s.

Definition split (sep : string) (s : string) : list string
  := match sep with
     | EmptyString
       => if string_beq s EmptyString
          then "" :: nil
          else List.map (fun ch => String ch "") (to_list s)
     | String sepch sep
       => split_helper sepch sep s ""
     end.

Fixpoint split_helper_non_empty sepch sep s rev_acc {struct s}
  : split_helper sepch sep s rev_acc <> nil.
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; clear split_helper_non_empty; congruence | ].
  generalize (split_helper_non_empty sepch sep xs (String x rev_acc)).
  generalize (split_helper sepch sep xs (String x rev_acc)).
  intros ls H.
  generalize (String x xs).
  generalize sep at 2.
  generalize sepch at 2.
  fix H' 3.
  intros sepch' sep' s'.
  destruct s' as [|a s']; cbn; [ assumption | ].
  destruct (sepch' =? a)%char, sep'; try (clear H' split_helper_non_empty; congruence).
  apply H'.
Qed.

Lemma split_non_empty sep s : split sep s <> nil.
Proof.
  unfold split; destruct sep, s; try apply split_helper_non_empty; cbn;
    congruence.
Qed.

Lemma split_empty_empty : split EmptyString EmptyString = "" :: nil.
Proof. reflexivity. Qed.
Lemma split_empty_non_empty s
  : s <> EmptyString
    -> split EmptyString s = List.map (fun ch => String ch "") (to_list s).
Proof.
  intro H; destruct s; cbn; congruence.
Qed.

Fixpoint split_helper_no_substring sepch sep s rev_acc
  : List.Forall (fun s' => contains 0 (rev rev_acc ++ String sepch sep) s' = false)
                (split_helper sepch sep s rev_acc).
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; clear split_helper_no_substring;
      repeat constructor
    | ].
  { unfold contains.
    edestruct index eqn:H; [ | reflexivity ].
    apply index_correct1 in H.
    apply (f_equal length) in H.
    rewrite length_substring, !length_append in H.
    revert H; apply PeanoNat.Nat.min_case_strong; cbn; intros; omega. }
  { generalize (split_helper_no_substring sepch sep xs (String x rev_acc)).
    generalize (split_helper sepch sep xs (String x rev_acc)).
    intros ls.
Abort.
Lemma split_no_substring sep s (Hsep : sep <> EmptyString)
  : List.Forall (fun s' => contains 0 sep s' = false)
                (split sep s).
Proof.
  destruct sep as [|sepch sep]; [ congruence | ].
  unfold split.
Abort.

Fixpoint concat_split_helper sepch sep s rev_acc
  : concat (String sepch sep) (split_helper sepch sep s rev_acc)
    = rev rev_acc ++ s.
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; rewrite append_empty_r; reflexivity | ].
  generalize (concat_split_helper sepch sep xs (String x rev_acc)).
  generalize (split_helper sepch sep xs (String x rev_acc)).
  intros ls H.
  rewrite rev_step, <- append_assoc in H; cbn in H; revert H.
  generalize (String x xs); clear x xs.
  revert sep.
  revert sepch.
  fix H' 3.
  intros sepch' sep' s'; intros.
  destruct s' as [|a s']; cbn; [ assumption | ].
  destruct (sepch' =? a)%char eqn:Hsep, sep'; try (clear H' concat_split_helper; congruence).
  { cbn [concat].
    rewrite (concat_split_helper sepch' "" s').
    destruct (split_helper sepch' "" s' "") eqn:H''.
    { apply split_helper_non_empty in H''; exfalso; assumption. }
    { cbn.
      apply internal_ascii_dec_bl in Hsep; subst; reflexivity. } }
  { apply internal_ascii_dec_bl in Hsep; subst.
Abort.

Lemma concat_split sep s : concat sep (split sep s) = s.
Proof.
  destruct sep; cbn.
  { destruct s as [|x xs]; [ reflexivity | cbn ].
    revert x; induction xs as [|x' xs' IHxs]; intro x; cbn; trivial.
    apply f_equal; auto. }
  {
Abort.


Require Export TcfgReach PPexhead.
Require Import Lia.

Section cfg.

  Context `(C : redCFG).

  (* the more general formulation with deq_loop is wrong *)
  Lemma tpath_tag_take_r_eq p i q j t h n
        (Hlen : |j| = depth q)
        (Hpath : TPath (q,j) (p,i) t)
        (Hincl : forall r, r ∈ map fst t -> deq_loop r h)
        (Hdep : depth h = n)
    : take_r (n-1) j = take_r (n-1) i.
  Proof.
    revert p i Hpath.
    induction t;intros; inv_path Hpath.
    - reflexivity.
    - case (depth h) eqn:E.
      { cbn. reflexivity. }
      exploit' IHt.
      { intros. eapply Hincl. right. auto. }
      destruct x.
      copy Hincl Hincl'.
      eapply deq_loop_depth in Hincl.
      2: { right. eapply path_contains_front in H. eapply in_map with (f:=fst) in H. cbn in H;eauto. }
      eapply tcfg_edge_destruct' in H0.
      eapply tag_depth_unroot in H as Htagt0;eauto.
      destruct H0 as [[H0 Q0]|[[H0 Q0]|[[H0 Q0]|[H0 Q0]]]].
      + subst. eapply IHt;eauto.
      + subst.
        eapply depth_entry in Q0.
        rewrite take_r_cons_drop.
        * eapply IHt;eauto.
        * rewrite Htagt0. lia.
      + destruct t0.
        { cbn in Htagt0. lia. }
        cbn in H0. subst i.
        erewrite take_r_cons_replace.
        * eapply IHt;eauto.
        * cbn in Htagt0. clear - E Hincl Htagt0. rewrite E in Hincl. rewrite <-Htagt0 in Hincl. lia.
      + destruct t0. 1:cbn in Htagt0;lia.
        cbn in H0. subst.
        setoid_rewrite <-take_r_cons_drop at 2.
        * eapply IHt;eauto.
        * cbn in Htagt0. lia.
  Qed.

  Lemma weak_monotonicity q j p i t h n
        (Hlen : |j| = depth q)
        (Hpath : TPath (q,j) (p,i) t)
        (Hincl : forall r, r ∈ map fst t -> deq_loop r h)
        (Hdep : depth h = n)
    : take_r n j ⊴ take_r n i.
  Proof.
    revert p i Hpath.
    induction t;intros; inv_path Hpath.
    - reflexivity.
    - case (depth h) eqn:E.
      { cbn. reflexivity. }
      exploit' IHt.
      { intros. eapply Hincl. right. auto. }
      destruct x.
      copy Hincl Hincl'.
      eapply deq_loop_depth in Hincl.
      2: { right. eapply path_contains_front in H. eapply in_map with (f:=fst) in H. cbn in H;eauto. }
      eapply tcfg_edge_destruct' in H0.
      eapply tag_depth_unroot in H as Htagt0;eauto.
      destruct H0 as [[H0 Q0]|[[H0 Q0]|[[H0 Q0]|[H0 Q0]]]].
      + subst. eapply IHt;eauto.
      + subst.
        eapply depth_entry in Q0.
        setoid_rewrite take_r_cons_drop.
        * eapply IHt;eauto.
        * rewrite Htagt0. lia.
      + destruct t0.
        { cbn in Htagt0. lia. }
        rewrite H0.
        transitivity (take_r (S n) (n0 :: t0)).
        * eapply IHt;eauto.
        * unfold STag.
          eapply tagle_take_r.
          econstructor.
          econstructor.
          lia.
      + specialize (Hincl' p). exploit Hincl'. 1: left;cbn;eauto.
        destruct t0. 1:cbn in Htagt0;lia.
        cbn in H0. subst.
        setoid_rewrite <-take_r_cons_drop at 2.
        * eapply IHt;eauto.
        * cbn in Htagt0.
          eapply depth_exit in Q0.
          eapply deq_loop_depth in Hincl'.
          rewrite Q0 in Htagt0. lia.
  Qed.

  Lemma tcfg_fresh p i j t
        (Hpath : TPath (p,i) (p,j) t)
        (Hdep : | i | = depth p)
        (Hlen : | t | >= 2)
    : i ◁ j.
  Proof.
    eapply TPath_CPath in Hpath as Hpp.
    eapply p_p_ex_head in Hpp.
    2: rewrite map_length;eauto.
    destructH.
    destruct t. 1: inv Hpath.
    eapply in_fst in Hpp0. destruct Hpp0 as [k Hpp0].
    unfold TPath in *. path_simpl' Hpath.
    eapply path_from_elem' in Hpp0 as Hπ;eauto.
    destructH.
    eapply postfix_eq in Hπ1.
    destruct Hπ1 as [ϕ Hπ1].
    rewrite <-app_assoc in Hπ1.
    unfold app at 2 in Hπ1.
    assert (Prefix ((h,k) :: ϕ) ((p,j) :: t)) as Hpreϕ.
    { eapply prefix_eq. eexists;eauto. }
    eapply path_prefix_path in Hpath as Hϕ;eauto.
    inv_path Hϕ.
    {
      cbn in Hπ1.
      destruct equiv_dec in Hπ1.
      - cbn in Hπ1.
        destruct t;[|congruence]. cbn in Hlen. lia.
      - eapply tagle_neq_taglt.
        + erewrite <-take_r_geq with (n:=depth h).
          2: { erewrite tag_depth_unroot;eauto. }
          rewrite <-take_r_geq with (n:=depth h) at 1.
          2: { erewrite tag_depth_unroot;eauto. }
          eapply weak_monotonicity in Hpath. all:eauto.
          eauto using loop_contains_deq_loop.
        + contradict c0. intro. subst. apply H. reflexivity.
    }
    destruct x.
    assert (e ↪ h) as Hback.
    { eapply non_entry_head_back_edge. 1: destruct H0;eauto.
      eapply Hpp1. fold (fst (e,t0)). eapply in_map. eapply prefix_incl;eauto.
      right. eapply path_contains_front;eauto.
    }
    eapply weak_monotonicity in H;eauto.
    2: { intros. eapply loop_contains_deq_loop. eapply Hpp1. eapply prefix_incl;eauto.
         eapply prefix_map_fst;eauto. eapply prefix_cons;eauto.
    }
    eapply weak_monotonicity in Hπ0;eauto.
    3: {
      intros. eapply loop_contains_deq_loop. eapply Hpp1. eapply postfix_incl;eauto.
      eapply postfix_map_fst.
      eapply postfix_nincl_spec;eauto.
    }
    2: { eapply tag_depth_unroot in Hdep;eauto. }
    assert (| k | = depth h) as Hhdep.
    { eapply tag_depth_unroot;eauto. }
    destruct t0.
    { eapply back_edge_eq_loop in Hback. eapply tcfg_edge_depth_iff in Hhdep;eauto.
      rewrite Hback  in Hhdep. cbn in Hhdep.
      enough (0 > 0) by lia.
      rewrite Hhdep at 1. eapply depth_loop_head.
      eapply loop_contains_loop_head. eapply Hpp1. fold (fst (h,k)). eapply in_map. eauto.
    }
    eapply tag_back_edge_iff in Hback;eauto.
    specialize (taglt_stag n t0) as Hlt. subst k.
    rewrite take_r_geq in Hπ0. 2: setoid_rewrite Hhdep; lia.
    setoid_rewrite take_r_geq in H at 2. 2: setoid_rewrite Hhdep; lia.
    eapply tagle_taglt_trans in Hlt;eauto.
    eapply taglt_tagle_trans in Hlt;eauto.
    eapply taglt_take_r_taglt;eauto.
    rewrite Hdep.
    erewrite tag_depth_unroot;eauto.
  Qed.

  Lemma ex_entry (h p q : Lab) (i j j' k : Tag) t
        (Hin : loop_contains h q)
        (Hnin : ~ loop_contains h p)
        (Hpath : TPath (p,i) (q,j) t)
        (Hleni : | i | = depth p)
        (Heq : j = j' ++ k)
        (Hlen : | k | = depth h - 1)
    : (h,0 :: k) ∈ t.
  Proof.
    revert j' j q Heq Hpath Hin.
    induction t;intros;inv_path Hpath.
    - contradiction.
    - destruct x as [u l].
      decide (loop_contains h u).
      + right.
        copy H0 Htedge.
        eapply tcfg_edge_destruct' in H0.
        destruct H0 as [[H0 H1]|[[H0 H1]|[[H0 H1]|[H0 H1]]]].
        * eapply IHt. all: cycle 1; eauto.
        * destruct j'.
          -- exfalso.
             cbn in Hpath.
             eapply tag_depth_unroot in Hpath;eauto.
             eapply loop_contains_deq_loop in Hin. eapply deq_loop_depth in Hin.
             rewrite Hpath in Hlen.
             destruct k;cbn in *;[congruence|lia].
          -- eapply IHt. all: cycle 1; eauto. cbn in H0. inversion H0. eauto.
        * destruct j'.
          -- exfalso.
             cbn in Hpath.
             eapply tag_depth_unroot in Hpath;eauto.
             eapply loop_contains_deq_loop in Hin. eapply deq_loop_depth in Hin.
             rewrite Hpath in Hlen.
             destruct k;cbn in *;[|lia].
             eapply loop_contains_loop_head in l0.
             eapply depth_loop_head in l0. lia.
          -- destruct l;cbn in H0;[congruence|].
             eapply IHt. all: cycle 1; eauto.
             instantiate (1:=(n0 :: j')). cbn. inv H0. reflexivity.
        * destruct l.
          -- exfalso.
             eapply tag_depth_unroot in Hpath;eauto.
             rewrite H0 in Hpath. cbn in Hpath.
             eapply loop_contains_deq_loop in Hin as Hdeq. eapply deq_loop_depth in Hdeq.
             eapply loop_contains_loop_head in Hin.
             eapply depth_loop_head in Hin. lia.
          -- cbn in H0. eapply IHt. all: cycle 1; eauto. instantiate (1:=n :: j').
             cbn. rewrite H0. reflexivity.
      + eapply entry_through_header in Hin as Hin'. 2:eauto. 2: destruct H0;eauto.
        subst q.
        assert (entry_edge u h) as Hentry.
        { split. 1: eapply loop_contains_loop_head;eauto. split;destruct H0;eauto. }
        rewrite <-tag_entry_iff in Hentry;eauto.
        assert (| j' ++ k | = depth h).
        { eapply tag_depth_unroot in Hpath;eauto. }
        destruct j'.
        * exfalso.
          cbn in H1, Hentry. destruct k;[congruence|]. rewrite <-H1 in Hlen. cbn in Hlen. lia.
        * destruct j'.
          -- cbn in Hentry. inv Hentry. left. reflexivity.
          -- exfalso.
             rewrite <- H1 in Hlen. cbn in Hlen.
             rewrite app_length in Hlen. lia.
  Qed.

  Lemma ex_entry_rooted (h q : Lab) (j : Tag) n t
        (Hin : loop_contains h q)
        (Hpath : TPath (root,start_tag) (q,j) t)
        (Hdep : depth h = n)
    : (h,0 :: (take_r (n-1) j)) ∈ t.
  Proof.
    assert (n <= |j|) as Hnj.
    {
      eapply loop_contains_deq_loop in Hin.
      eapply deq_loop_depth in Hin.
      eapply tag_depth' in Hpath. rewrite Hpath.
      lia.
    }
    eapply ex_entry in Hpath;eauto.
    - eapply root_no_loop.
    - cbn. symmetry. eapply depth_root.
    - eapply take_take_r with (n:=|j| - (n - 1)).
      lia.
    - rewrite <- Hdep.
      eapply (take_r_length_le).
      lia.
  Qed.

  Lemma ex_entry_innermost (h p q : Lab) (i j : Tag) t
        (Hdep : | i | = depth p)
        (Hin : innermost_loop h q)
        (Hnin : ~ loop_contains h p)
        (Hpath : TPath (p,i) (q,j) t)
    : (h,0 :: tl j) ∈ t.
  Proof.
    destruct Hin as [Hloop Hinner].
    eapply loop_contains_deq_loop in Hloop as Hdeq.
    eapply deq_loop_depth in Hdeq.
    eapply loop_contains_loop_head in Hloop as Hhead.
    eapply depth_loop_head in Hhead. cbn in Hpath.
    eapply tag_depth_unroot in Hpath as Hq;eauto.
    destruct j;cbn;[exfalso;cbn in Hq;lia|].
    eapply ex_entry with (j':=[n]) in Hloop;eauto.
    cbn in Hq. eapply deq_loop_depth in Hinner. lia.
  Qed.

  Lemma tagle_monotone q j p i t h n
        (Hlen : |j| = depth q)
        (Hpath : TPath (q,j) (p,i) t)
        (Hdeqq : deq_loop q h)
        (Hdeqp : deq_loop p h)
        (Hdep : depth h = n)
    : take_r n j ⊴ take_r n i.
  Proof.
    revert n h p i Hpath Hdeqp Hdeqq Hdep.
    induction t;intros; inv_path Hpath.
    - reflexivity.
    - case (depth h) eqn:E.
      { cbn. reflexivity. }
      destruct x.
      eapply tcfg_edge_destruct' in H0.
      eapply tag_depth_unroot in H as Htagt0;eauto.
      destruct H0 as [[H0 Q0]|[[H0 Q0]|[[H0 Q0]|[H0 Q0]]]].
      + subst. eapply IHt;eauto.
        eapply basic_edge_eq_loop in Q0. symmetry in Q0. eapply eq_loop1;eauto.
      + decide (loop_contains p q).
        * subst i.
          specialize (tcfg_reachability Hlen) as Hreach.
          destructH.
          eapply ex_entry_rooted in Hreach as Hentry;eauto.
          eapply path_from_elem in Hentry;eauto.
          destructH.
          eapply path_app' in Hpath;eauto.
          eapply depth_entry in Q0 as Q1.
          eapply loop_contains_deq_loop in l as Hdeppq. eapply deq_loop_depth in Hdeppq.
          assert (depth p - 1 = depth e) as Hdeppe by lia.
          eapply deq_loop_depth in Hdeqq as Hdepq.
          eapply deq_loop_depth in Hdeqp as Hdepp.
          eapply tcfg_fresh in Hpath.
          2: {
            cbn.
            rewrite take_r_length_le.
            1: lia.
            lia.
          }
          2: { cbn. destruct t;[inv H|]. cbn. lia. }
          rewrite taglt_cons in Hpath.
          decide (depth p - 1 <= S n).
          -- left.
             eapply taglt_leq with (m:=depth p - 1).
             2-4: cbn;lia.
             rewrite take_r_cons_drop.
             2: lia.
             rewrite Hdeppe at 2. rewrite <-Htagt0.
             rewrite take_r_self. eassumption.
          -- eapply taglt_tagle in Hpath. eapply tagle_take_r with (n:=S n) in Hpath.
             rewrite take_r_cons_drop.
             2: lia.
             rewrite take_r_take_r_leq in Hpath.
             2: lia.
             eassumption.
        * subst i.
          assert (deq_loop e h) as Hdeqe.
          {
            intros h' Hh'.
             eapply deq_loop_entry_or in Q0;cycle 1.
             { eapply Hdeqp;eauto. }
             destruct Q0.
             - auto.
             - exfalso.
               subst p. eapply n0. eauto using loop_contains_deq_loop.
          }
          rewrite take_r_cons_drop.
          -- eapply IHt;eauto.
          -- rewrite Htagt0. rewrite <-E. eapply deq_loop_depth. auto.
      + destruct t0.
        { exfalso. cbn in Htagt0. eapply back_edge_eq_loop in Q0.
          rewrite Q0 in Htagt0. enough (depth p > 0) by lia.
          eapply deq_loop_depth in Hdeqp. lia.
        }
        rewrite H0.
        transitivity (take_r (S n) (n0 :: t0)).
        * eapply IHt;eauto.
          eapply back_edge_eq_loop in Q0. symmetry in Q0. eapply eq_loop1;eauto.
        * unfold STag.
          eapply tagle_take_r.
          econstructor.
          econstructor.
          lia.
      + destruct t0.
        {
          exfalso.
          cbn in Htagt0.
          eapply depth_exit in Q0.
          lia.
        }
        eapply IHt in H;eauto.
        * cbn in H0. subst t0.
          setoid_rewrite <-take_r_cons_drop at 2;eauto.
          eapply deq_loop_depth in Hdeqp.
          erewrite tag_depth_unroot;eauto. lia.
        * transitivity p;eauto.
          destruct Q0. eapply deq_loop_exited;eauto.
  Qed.

  Lemma tagle_monotone_eq_loop q1 q2 j1 j2 r
        (Hdep : | j1 | = depth q1)
        (Hpath : TPath (q1,j1) (q2,j2) r)
        (Hin : forall x, x ∈ map fst r -> deq_loop x q1)
        (Heq : eq_loop q1 q2)
    : j1 ⊴ j2.
  Proof.
    copy Hpath Hpath1.
    eapply tagle_monotone in Hpath.
    4: destruct Heq as [_ Heq];eapply Heq.
    3: reflexivity.
    2: assumption.
    2: reflexivity.
    rewrite take_r_geq in Hpath.
    2: rewrite <-Hdep;eauto.
    rewrite take_r_geq in Hpath.
    1: assumption.
    rewrite Heq.
    eapply tag_depth_unroot in Hpath1;eauto.
    rewrite Hpath1;eauto.
  Qed.

  Lemma tcfg_acyclic p i q j t
        (Hdep : | i | = depth p)
        (Hedge : tcfg_edge (q,j) (p,i))
        (Hpath : TPath (p,i) (q,j) t)
    : False.
  Proof.
    eapply PathCons in Hedge;eauto.
    eapply tcfg_fresh in Hedge;cbn;eauto.
    2: inv_path Hpath;cbn;eauto;lia.
    eapply Taglt_irrefl;eassumption.
  Qed.

End cfg.


Require Import Frap Pset11Sig.

Theorem deadlock_freedom : forall h p,
    Forall (fun c => goodCitizen {} c {}) p
    -> invariantFor (trsys_of h {} p) (fun h_l_p =>
                                         let '(_, _, p') := h_l_p in
                                         Forall finished p'
                                         \/ exists h_l_p', step h_l_p h_l_p').
Proof.
  (* To begin with, we weaken the invariant to the one proved in Pset11Sig. *)
  simplify.
  eapply invariant_weaken.
  eauto using a_useful_invariant.

  (* What's left is to prove that that invariant implies deadlock-freedom. *)
  first_order.
  cases s.
  cases p0.
  invert H0.

  (* We don't actually need to use the [disjointLocks] property.  It was only
   * important in strengthening the induction to prove that other invariant.
   * Also, the original hypothesis won't be needed anymore.*)
  clear H H6.
Admitted.