From Coq Require Import Ascii.
From Coq.ssr Require Import ssreflect.
From stdpp Require Import pretty strings.
From aneris.prelude Require Import misc.
Coercion Z.of_nat : nat >-> Z.

Definition StringOfZ (x : Z) :=
  match x with
  | 0%Z => "0"
  | Z.pos x0 => pretty (N.pos x0)
  | Z.neg x0 => "-" +:+ pretty (N.pos x0)
  end.

Definition ZOfAscii (c : Ascii.ascii) : option N :=
  match c with
  | "0"%char => Some 0%N
  | "1"%char => Some 1%N
  | "2"%char => Some 2%N
  | "3"%char => Some 3%N
  | "4"%char => Some 4%N
  | "5"%char => Some 5%N
  | "6"%char => Some 6%N
  | "7"%char => Some 7%N
  | "8"%char => Some 8%N
  | "9"%char => Some 9%N
  | _ => None
  end.

Fixpoint ZOfString' (x : string) (ac : N) : option N :=
  match x with
  | EmptyString => Some ac
  | String c x' =>
    match ZOfAscii c with
      None => None
    | Some d => (ZOfString' x' ((ac * 10) + d)%N)
    end
  end.

Definition ZOfString (x : string) : option Z:=
  match x with
  | EmptyString => None
  | String "-"%char x' =>
    match (ZOfString' x' 0) with
    | Some z => Some (- (Z.of_N z))%Z
    | None => None
    end
  | String _
 _ =>
    match (ZOfString' x 0) with
    | Some z => Some (Z.of_N z)
    | None => None
    end
  end.

Lemma lt_acc (n : N) : Acc N.lt n.
Proof.
  induction n using N.peano_ind; first by constructor; intros; lia.
  constructor => m Hlt.
  destruct (decide (m < n)%N); first by apply IHn.
    by replace m with n by lia.
Qed.

Lemma ZOfAscii_pretty x :
  (x < 10)%N →
  ZOfAscii (pretty_N_char x) = Some x.
Proof.
  intros Hlt.
  inversion Hlt as [Hlt']; cbv in Hlt'.
  destruct x as [|p]; first done.
  destruct p as [[[[]|[]|]|[[]|[]|]|]|[[[]|[]|]|[[]|[]|]|]|]; try done.
Qed.

Lemma ZOfString'_app s s' k :
  match ZOfString' s k with
  | None => ZOfString' (s +:+ s') k = None
  | Some m => ZOfString' (s +:+ s') k = ZOfString' s' m
  end.
Proof.
  revert s' k; induction s.
  - induction s'; simpl; first done.
    intros k.
    destruct a as [[] [] [] [] [] [] [] []]; simpl; auto;
      match goal with
        |- match ZOfString' s' ?A with _ => _ end =>
        specialize (IHs' A);
          destruct (ZOfString' s' A); trivial
      end.
  - intros s' k; simpl; fold append.
    destruct a as [[] [] [] [] [] [] [] []]; simpl; auto;
      match goal with
        |- match ZOfString' s ?A with _ => _ end =>
        specialize (IHs s' A);
          destruct (ZOfString' s (k * 10 + 7)); auto
      end.
Qed.

Global Instance append_assoc : Assoc eq append.
Proof.
  intros x.
  induction x.
  - induction y; auto with f_equal.
  - intros y z.
    rewrite /append -/append IHx. f_equal.
Qed.

Lemma pretty_N_go_app m s :
  (0 < m)%N → pretty_N_go m s = (pretty_N_go m "") +:+ s.
Proof.
  intros Hlt. revert s.
  induction (lt_acc m) as [? ? IH] => s.
  rewrite !(pretty_N_go_step x) //.
  destruct (decide (x < 10)%N).
  - rewrite N.div_small // pretty_N_go_0 /=.
  - assert (x `div` 10 < x)%N as Hltdv.
    { apply N.div_lt; auto with lia. }
    assert (0 < x `div` 10)%N as Hdvp.
    { apply N.div_str_pos; lia. }
    pose proof (IH _ Hltdv Hdvp) as IH'.
    rewrite (IH' (String (pretty_N_char (x `mod` 10)) "")).
    rewrite IH'; simpl.
      by rewrite -assoc.
Qed.

Lemma ZOfString'_inv (n : nat) :
  ZOfString' (StringOfZ n) 0 = Some (N.of_nat n).
Proof.
  destruct n; first done; simpl.
  unfold pretty, pretty_N.
  remember (N.pos (Pos.of_succ_nat n)) as m.
  replace (S n) with (N.to_nat m); last first.
  { by rewrite Heqm positive_N_nat SuccNat2Pos.id_succ. }
  assert (Hmlt : (0 < m)%N) by lia.
  rewrite decide_False; [|lia].
  clear dependent n.
  induction (lt_acc m) as [? ? IH].
  rewrite pretty_N_go_step; last done.
  destruct (decide (x < 10)%N).
  - rewrite N.mod_small //.
    rewrite N.div_small // pretty_N_go_0 /= ZOfAscii_pretty //.
  - assert (x `div` 10 < x)%N as Hltdv.
    { apply N.div_lt; auto with lia. }
    assert (0 < x `div` 10)%N as Hdvp.
    { apply N.div_str_pos; lia. }
    rewrite pretty_N_go_app //.
    pose proof (ZOfString'_app
                  (pretty_N_go (x `div` 10) "")
                  (String (pretty_N_char (x `mod` 10)) "") 0) as Hlp.
    rewrite (IH _ Hltdv Hdvp) in Hlp.
    rewrite Hlp.
    rewrite /= ZOfAscii_pretty; last by apply N.mod_lt.
    replace (x `div` 10 * 10)%N with (10 * x `div` 10)%N by lia.
    rewrite -N.div_mod' //.
Qed.

Lemma pretty_N_go_nnil m s :
  (0 < m)%N → pretty_N_go m s ≠ "".
Proof.
  intros Hlt. revert s.
  induction (lt_acc m) as [? ? IH] => s.
  rewrite !(pretty_N_go_step x) //.
  destruct (decide (x < 10)%N).
  - rewrite N.div_small // pretty_N_go_0 /=.
  - assert (x `div` 10 < x)%N as Hltdv.
    { apply N.div_lt; auto with lia. }
    assert (0 < x `div` 10)%N as Hdvp.
    { apply N.div_str_pos; lia. }
    apply (IH _ Hltdv Hdvp).
Qed.

Lemma pretty_N_go_pos_nneg m s s':
  (0 < m)%N → pretty_N_go m s ≠ String "-" s'.
Proof.
  intros Hlt. revert s.
  induction (lt_acc m) as [? ? IH] => s.
  rewrite !(pretty_N_go_step x) //.
  destruct (decide (x < 10)%N).
  - rewrite N.div_small // pretty_N_go_0 /=.
    destruct x as [|p]; first done.
    destruct p as [[[[]|[]|]|[[]|[]|]|]|[[[]|[]|]|[[]|[]|]|]|]; done.
  - assert (x `div` 10 < x)%N as Hltdv.
    { apply N.div_lt; auto with lia. }
    assert (0 < x `div` 10)%N as Hdvp.
    { apply N.div_str_pos; lia. }
    apply (IH _ Hltdv Hdvp).
Qed.

Lemma StringOfZ_nnil m : StringOfZ m ≠ "".
Proof.
  unfold StringOfZ; simpl.
  destruct m; auto.
  apply pretty_N_go_nnil; lia.
Qed.

Lemma ZOfString_inv (n : Z) : ZOfString (StringOfZ n) = Some n.
Proof.
  unfold ZOfString.
  destruct (StringOfZ n) eqn:Heq;
    first by exfalso; eapply StringOfZ_nnil; eauto.
  destruct n as [|p|p] eqn:Heqn.
  - destruct a as [[] [] [] [] [] [] [] []]; try done.
    rewrite -?Heq //.
  - rewrite -?Heq.
    pose proof (ZOfString'_inv (Pos.to_nat p)) as HZSi.
    rewrite positive_nat_Z in HZSi.
    rewrite HZSi nat_N_Z positive_nat_Z.
    destruct a as [[] [] [] [] [] [] [] []]; auto.
    by rewrite Heq in HZSi.
  - simpl in Heq.
    assert (0 < 1)%nat as Hneq by lia.
    pose proof (append_correct1 "-" (pretty (N.pos p)) 0 Hneq) as Hf;
      simpl in Heq.
    rewrite Heq in Hf; inversion Hf; subst.
    rewrite -(@string_app_inj "-" (pretty (N.pos p)) s Heq).
    pose proof (ZOfString'_inv (Pos.to_nat p)) as HZSi.
    rewrite positive_nat_Z in HZSi.
      by rewrite HZSi nat_N_Z positive_nat_Z.
Qed.

Lemma append_nil_l s :
  "" +:+ s = s.
Proof. done. Qed.

Lemma append_cons s1 :
  ∀ s2 a, String a (s1 +:+ s2) = (String a s1) +:+ s2.
Proof.
  induction s1; intros.
  - by rewrite append_nil_l.
  - rewrite -IHs1. done.
Qed.

Lemma length_Sn a s :
  String.length (String a s) = S (String.length s).
Proof. by cbn. Qed.

Lemma length_app s1 :
  ∀ s2, String.length (s1 +:+ s2) = (String.length s1 + String.length s2)%nat.
Proof.
  induction s1; intros.
  - by rewrite append_nil_l.
  - by rewrite -append_cons !length_Sn IHs1.
Qed.

Lemma prefix_empty_true s :
  String.prefix "" s = true.
Proof. destruct s; cbn; auto. Qed.

Lemma index_0_empty s :
  index 0 "" s = Some 0%nat.
Proof. destruct s; by cbn. Qed.

Lemma index_prefix_true s s' :
  index 0 s s' = Some 0%nat →
  String.prefix s s' = true.
Proof.
  destruct s,s'; simpl; cbn; auto.
  - intro; inversion H.
  - intro; destruct ascii_dec.
    + destruct (String.prefix s s'); auto; destruct (index 0 _ s'); inversion H.
    + destruct (index 0 _ s'); inversion H.
Qed.

Lemma index_cons_0_eq a s s' :
  index 0 s s' = Some 0%nat → index 0 (String a s) (String a s') = Some 0%nat.
Proof.
  intros Hindex.
  cbn. destruct ascii_dec.
  - assert (Hprefix: String.prefix s s' = true).
    { by apply index_prefix_true. }
      by rewrite Hprefix.
  - by destruct n.
Qed.

Lemma index_append_here s t :
  index 0 s (s +:+ t) = Some 0%nat.
Proof.
  induction s.
  - apply index_0_empty.
  - apply index_cons_0_eq.
    apply IHs.
Qed.

Lemma index_0_append_char a t v s :
  s = String a "" →
  index 0 s t = None →
  index 0 s (t +:+ s +:+ v) = Some (String.length t).
Proof.
  induction t; intros.
  - rewrite append_nil_l. apply index_append_here.
  - rewrite H. rewrite -append_cons. cbn.
    destruct ascii_dec; subst. cbn in H0. destruct ascii_dec.
    rewrite prefix_empty_true in H0. inversion H0.
      by destruct n.
      rewrite IHt; auto. cbn in H0. destruct ascii_dec. by destruct n.
      destruct index; auto. inversion H0.
Qed.

Lemma substring_0_length s :
  substring 0 (String.length s) s = s.
Proof. induction s; simpl; auto. by rewrite IHs. Qed.

Lemma substring_Sn a n m s :
  substring (S n) m (String a s) = substring n m s.
Proof. induction s; destruct n,m; simpl; auto. Qed.

Lemma substring_add_length_app n m s1 :
  ∀ s2, substring (String.length s1 + n) m (s1 +:+ s2) = substring n m s2.
Proof. induction s1; destruct n,m; simpl; auto. Qed.

Lemma substring_0_length_append s1 s2 :
  substring 0 (String.length s1) (s1 +:+ s2) = s1.
Proof. apply prefix_correct, index_prefix_true, index_append_here. Qed.

Lemma substring_length_append s1 :
  ∀ s2, substring (String.length s1) (String.length s2) (s1 +:+ s2) = s2.
Proof.
  induction s1; intros s2.
  - rewrite append_nil_l. apply substring_0_length.
  - rewrite length_Sn substring_Sn. apply IHs1.
Qed.

Definition not_number (c : ascii) :=
  (c ≠ "0" ∧ c ≠ "1" ∧ c ≠ "2" ∧ c ≠ "3" ∧ c ≠ "4" ∧
   c ≠ "5" ∧ c ≠ "6" ∧ c ≠ "7" ∧ c ≠ "8" ∧ c ≠ "9")%char.

Lemma get_n_pretty_N_go_ne n N s (c : ascii) :
  not_number c →
  (∀ m, get m s ≠ Some c) → get n (pretty_N_go N s) ≠ Some c.
Proof.
  intros (?&?&?&?&?&?&?&?&?&?). revert s.
  induction (N.lt_wf_0 N) as [x _ IH]. intros s Hs.
  assert (x = 0 ∨ 0 < x < 10 ∨ 10 ≤ x)%N as [->|[[??]|?]] by lia.
  - rewrite pretty_N_go_0. done.
  - rewrite pretty_N_go_step; [|done].
    apply IH.
    { by apply N.div_lt. }
    assert (x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4 ∨ x = 5 ∨ x = 6
            ∨ x = 7 ∨ x = 8 ∨ x = 9)%N as Hx by lia.
    destruct_or! Hx; simplify_eq; intros [];
      simpl; (done || by intros [=]).
  - rewrite pretty_N_go_step; [|lia].
    apply IH.
    { apply N.div_lt; lia. }
    intros []; [|by simpl].
    unfold pretty_N_char;
      repeat (discriminate || case_match); simpl;
        by intros [=].
Qed.

Lemma get_StringOfZ_ne z n c :
  not_number c ∧ c ≠ "-"%char → get n (StringOfZ z) ≠ Some c.
Proof.
  intros [Hc Hdash].
  destruct z.
  - destruct n; intros [=]. by destruct_and! Hc.
  - simpl. unfold pretty, pretty_N.
    destruct decide; [done|]. by eapply get_n_pretty_N_go_ne.
  - destruct n; simpl; [congruence|]. by eapply get_n_pretty_N_go_ne.
Qed.

Lemma append_length_gt (n : nat) s1 s2 :
  String.length s1 < n → get n (s1 +:+ s2) = get (n - String.length s1) s2.
Proof.
  revert s2 n; induction s1; intros s2 n Hgt.
  - rewrite append_nil_l -minus_n_O //.
  - destruct (gt_exists_S_n _ _ Hgt) as [m ->].
    rewrite -append_cons.
    simpl in *. apply IHs1. lia.
Qed.

Lemma get_n_append_ne s1 s2 c n :
  (∀ m, get m s1 ≠ Some c) →
  (∀ m, get m s2 ≠ Some c) →
  get n (s1 +:+ s2) ≠ Some c.
Proof.
  destruct (decide (n < String.length s1)).
  { rewrite -append_correct1 //. }
  destruct (decide (n = String.length s1)) as [-> |].
  { rewrite -(append_correct2 _ _ 0). auto. }
  rewrite append_length_gt //. lia.
Qed.

Lemma get_head_ne_succ a a' n s :
  a ≠ a' → get n (String a s) = Some a' →
  ∃ n', n = S n' ∧ get (S n') (String a s) = Some a'.
Proof. intros Hneq Hget. destruct n; [by inversion Hget|by exists n]. Qed.

Lemma string_length_zero s : String.length s = 0 → s = "".
Proof. by destruct s. Qed.

Lemma append_eq_length_inv (s1 s2 s1' s2' : string) :
  String.length s1 = String.length s2 →
  s1 +:+ s1' = s2 +:+ s2' → s1 = s2 ∧ s1' = s2'.
Proof.
  revert s2; induction s1; simpl.
  - destruct s2; [done|]. intros [=].
  - destruct s2; simpl; [intros [=]|].
    rewrite -!append_cons.
    intros [=] [=]. simplify_eq.
    split; [f_equal|]; by eapply IHs1.
Qed.

Lemma char_splits_l s1 s2 s1' s2' (c : ascii) :
  (∀ n, get n s2 ≠ Some c) →
  (∀ n, get n s2' ≠ Some c) →
  s1 +:+ (String c "") +:+ s1' = s2 +:+ (String c "") +:+ s2' →
  s1 = s2 ∧ s1' = s2'.
Proof.
  intros Hs2 Hs2' Heq.
  apply append_eq_length_inv in Heq as [? [=]]; [done|].
  pose proof ((proj2 (get_correct _ _) Heq (String.length s1))) as Hget.
  rewrite -(append_correct2 _ _ 0) /= in Hget.
  edestruct Nat.lt_trichotomy as [Hlt | [Heq' | Hgt]]; [ |exact Heq'|].
  - rewrite -(append_correct1) //= in Hget.
    symmetry in Hget. by apply Hs2 in Hget.
  - rewrite (append_length_gt _ s2) // in Hget.
    destruct (gt_exists_S_n _ _ Hgt) as [n Hn].
    rewrite Hn in Hget.
    rewrite -minus_Sn_m in Hget; [|lia].
    simpl in Hget. symmetry in Hget.
    by apply Hs2' in Hget.
Qed.

Inductive elem_of_string : ElemOf ascii string :=
| elem_of_string_here (x : ascii) s : elem_of x (String x s)
| elem_of_string_further (x y : ascii) s : elem_of x s → elem_of x (String y s).
Local Existing Instance elem_of_string.

Lemma elem_of_string_cons (a1 a2 : ascii) (s : string)  :
  a1 ∈ String a2 s ↔ a1 = a2 ∨ a1 ∈ s.
Proof. by split; [inversion 1; subst|intros [->|?]]; constructor. Qed.
Lemma not_elem_of_string_cons (s : string) (x y : ascii) :
  x ∉ String y s ↔ x ≠ y ∧ x ∉ s.
Proof. rewrite elem_of_string_cons. tauto. Qed.

(** This lemma is ported from the stdpp library on lists.
    It is very similar to [char_splits_l], although it asserts properties
    about the prefix, rather than suffix.
    The suffix variant has not been ported, as it relies on list reverse,
    which has no analog for strings. *)
Lemma not_elem_of_string_app_cons_inv_l (a1 a2 : ascii) (l1 l2 k1 k2 : string) :
  a1 ∉ k1 → a2 ∉ l1 →
  l1 +:+ String a1 l2 = k1 +:+ String a2 k2 →
  l1 = k1 ∧ a1 = a2 ∧ l2 = k2.
Proof.
  revert k1.
  induction l1 as [|x' l1 IH]; intros [|y' k1] Hx Hy ?; simplify_eq/=;
    try apply not_elem_of_string_cons in Hx as [??];
      try apply not_elem_of_string_cons in Hy as [??]; naive_solver.
Qed.
Lemma get_string_elem_of a s : (∃ n, get n s = Some a) ↔ a ∈ s.
Proof.
  split.
  - intros [n Hget].
    generalize dependent n.
    induction s as [|a' s IHs]; [done|].
    intros n Hget.
    destruct (decide (a=a')) as [<-|]; [apply elem_of_string_here|].
    apply elem_of_string_further.
    apply get_head_ne_succ in Hget; [|done].
    destruct Hget as (n'&->&Hget).
    by eapply IHs.
  - intros Hin.
    induction s as [|a' s IHs]; [by inversion Hin|].
    apply elem_of_string_cons in Hin.
    destruct Hin as [<-|Hin]; [by exists 0|].
    apply IHs in Hin. destruct Hin as [m Hget].
    by exists (S m).
Qed.

(** This is very domain specific. Can maybe be generalised to derive the
    possible values of [a] *)
Lemma StringOfZ_not_sep a n :
  a ∈ StringOfZ n → a ≠ "_"%char.
Proof.
  intros Hin ->.
  rewrite -get_string_elem_of in Hin.
  destruct Hin as [n' Hin].
  assert (not_number "_"%char ∧ "_"%char ≠ "-"%char) as Hnan by done.
  by eapply get_StringOfZ_ne in Hnan.
Qed.


Require Import Data.OldList.
Require Import GHC.Base.
Require Import GHC.Char.
Require GHC.Unicode.
Require Import Omega.

(* -------------------------------------------------------------------- *)

(* Haskell-Coq equivalence *)

Theorem hs_coq_partition {A} (p : A -> bool) (l : list A) :
  Data.OldList.partition p l = Coq.Lists.List.partition p l.
Proof.
  unfold partition; induction l; simpl; auto.
Qed.

Require Coq.Lists.List.

Lemma words_def s : words s =
  match (GHC.List.dropWhile GHC.Unicode.isSpace s) with
    | nil => nil
    | s'  =>
     let 'pair w s'' := GHC.List.break GHC.Unicode.isSpace s' in
     cons w (words s'')
  end.
Admitted.
Lemma lines_def s : lines s =
  if (List.null s) then nil else
  let cons_ := fun '(pair h t) => cons h t in
  cons_ (let 'pair l s' := GHC.List.break
                             (fun arg_4__ =>
                                arg_4__ == newline) s in
         pair l (match s' with | nil => nil | cons _ s'' => lines s'' end)).
Proof.
Admitted.

Lemma words_nil : words nil = nil. Proof. reflexivity. Qed.
Lemma lines_nil : lines nil = nil. reflexivity. Qed.

Lemma words_cons : forall c s, words (cons c s) =
                   if Unicode.isSpace c then words s
                   else let (w, s'') := GHC.List.break Unicode.isSpace (cons c s) in
                        (cons w (words s'')).
Proof. intros.
       rewrite words_def.
       simpl.
       rewrite (words_def s).
       destruct (Unicode.isSpace c) eqn:S.
       - destruct (List.dropWhile Unicode.isSpace s) eqn:D. auto.
         reflexivity.
       - rewrite S.
         reflexivity.
Qed.

Lemma lines_cons : forall c s,
    lines (cons c s) =
    (fun x => match x with | (pair h t) => cons h t end)
      (match GHC.List.break (fun x => x == Char.newline) (cons c s) with
       | (l, s') => (l, match s' with
                       | nil => nil
                       | cons _ s'' => lines s''
                       end)
       end).
Proof.
  intros.
  rewrite lines_def.
  simpl.
  reflexivity.
Qed.

Hint Rewrite words_nil lines_nil words_cons lines_cons : hs_simpl.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Print Acc.
Print Fix.

Lemma acc_ltO : Acc lt O.
constructor; intros.
inversion H.
Qed.

Lemma acc_ltN n : Acc lt n -> Acc lt (S n).
intro H0.
constructor; intros.
unfold lt in H.
inversion H.
- assumption.
- clear m H1.
apply H0.
assumption.
Qed.

Lemma wf_lt : well_founded lt.
intro n.
induction n.
- exact acc_ltO.
- apply acc_ltN. assumption.
Qed.

Require Extraction.

Recursive Extraction Fix.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

(** Experiments with timed proofs *)

From Coq Require Import Bool.Bool.

From Coq Require Import Lists.List.
From Coq Require Import ZArith.
From Coq Require Import btauto.Btauto.
Require Import Program.Basics.
Import ListNotations.
Local Open Scope program_scope.
Local Open Scope list_scope.

Definition Trace (t: Type) := list t.

Fixpoint zipWith {A : Type} {B : Type} {C: Type} f (l : list A) (l' : list B) : list C :=
match l,l' with
  | x::tl, y::tl' => (f x y)::(zipWith f tl tl')
  | _, _ => nil
end.

(** simple expression type *)
Inductive expr: Type :=
| Input: Trace bool -> expr
| Not: expr -> expr
| And: expr -> expr -> expr
| Delay: expr -> expr.

Fixpoint runExpr (e: expr) :=
    match e with
    | Input t => t
    | Not e => map negb (runExpr e)
    | And e1 e2 => zipWith (andb) (runExpr e1) (runExpr e2)
    | Delay e => false :: (runExpr e)
    end.

Definition nand a b := Not (And a b).
Definition xor a b :=
    nand (nand a (nand a b)) (nand b (nand a b)).

(* for combinational expressions, set inputs to singleton lists,
and take the head of the result trace*)
Definition combinational2 e a b: _ :=
    hd_error(runExpr (e
                (Input (a :: nil))
                (Input (b :: nil))
                )).

Lemma xor_is_xorb : forall a b, combinational2 xor a b = Some (xorb a b).
Proof.
    intros a b.
    unfold combinational2.
    simpl.
    f_equal.
    btauto.
Qed.

(* xor with delays *)
Definition pipelined_xor a' b' :=
    let a := Input a' in
    let b := Input b' in
    nand
        (Delay (nand (Delay a) (Delay (nand a b))))
        (Delay (nand (Delay b) (Delay (nand a b)))).

Eval simpl in tl(tl(runExpr (pipelined_xor
        ( [false;false;true;true])
        ( [false;true;false;true])))).
Eval simpl in zipWith xorb
            ( [false;false;true;true])
            ( [false;true;false;true]).

Lemma pipelined_xor_delay_is_2:
    forall (i : Trace (bool * bool)),
    length (runExpr (pipelined_xor (map fst i) (map snd i))) = length i + 2.
Proof.
    intros.
    cbv.
    induction i.
    reflexivity.
    rewrite IHi.
    reflexivity.
Qed.

Lemma pipelined_xor_is_xorb_delayed2_once:
    forall x y,
    tl(tl(runExpr (pipelined_xor [x] [y])))  = zipWith xorb [x] [y].
Proof.
    intros.
    subst.
    simpl.
    f_equal.
    btauto.
Qed.

Lemma lengths': forall {A}{B} (a:A) (b:B) (x: list A) (y: list B),
    length (a :: x) = length (b :: y) -> length x = length y.
Proof.
    intros.
    auto.
Qed.

(* proof that the "pipelined" xor is equivalent to xorb delayed by 2 cycles *)
Lemma pipelined_xor_is_xorb_delayed2:
    forall (x y : Trace bool),
    length x = length y ->
    tl(tl(runExpr (pipelined_xor x y))) = zipWith xorb x y.
Proof.
    induction x.
    trivial.
    intros.
    unfold pipelined_xor.
    cbn [runExpr nand xor].
    destruct y.
    trivial.
    simpl.
    f_equal.
    btauto.
    simpl in IHx.
    rewrite IHx.
    reflexivity.
    auto.
Qed.


From stdpp Require Export vector.
From iris.algebra Require Export ofe.
From iris.algebra Require Import list.
From iris.prelude Require Import options.

Section ofe.
  Context {A : ofe}.

  Local Instance vec_equiv m : Equiv (vec A m) := equiv (A:=list A).
  Local Instance vec_dist m : Dist (vec A m) := dist (A:=list A).

  Definition vec_ofe_mixin m : OfeMixin (vec A m).
  Proof. by apply (iso_ofe_mixin vec_to_list). Qed.
  Canonical Structure vecO m : ofe := Ofe (vec A m) (vec_ofe_mixin m).

  Global Instance list_cofe `{!Cofe A} m : Cofe (vecO m).
  Proof.
    apply: (iso_cofe_subtype (λ l : list A, length l = m)
      (λ l, eq_rect _ (vec A) (list_to_vec l) m) vec_to_list)=> //.
    - intros v []. by rewrite /= vec_to_list_to_vec.
    - intros c. by rewrite (conv_compl 0 (chain_map _ c)) /= vec_to_list_length.
  Qed.

  Global Instance vnil_discrete : Discrete (@vnil A).
  Proof. intros v _. by inv_vec v. Qed.
  Global Instance vcons_discrete n x (v : vec A n) :
    Discrete x → Discrete v → Discrete (x ::: v).
  Proof.
    intros ?? v' ?. inv_vec v'=>x' v'. inversion_clear 1.
    constructor.
    - by apply discrete.
    - change (v ≡ v'). by apply discrete.
  Qed.
  Global Instance vec_ofe_discrete m : OfeDiscrete A → OfeDiscrete (vecO m).
  Proof. intros ? v. induction v; apply _. Qed.
End ofe.

Global Arguments vecO : clear implicits.
Typeclasses Opaque vec_dist.

Section proper.
  Context {A : ofe}.

  Global Instance vcons_ne n :
    Proper (dist n ==> forall_relation (λ x, dist n ==> dist n)) (@vcons A).
  Proof. by constructor. Qed.
  Global Instance vcons_proper :
    Proper (equiv ==> forall_relation (λ x, equiv ==> equiv)) (@vcons A).
  Proof. by constructor. Qed.

  Global Instance vlookup_ne n m :
    Proper (dist n ==> eq ==> dist n) (@Vector.nth A m).
  Proof.
    intros v. induction v as [|x m v IH]; intros v'; inv_vec v'.
    - intros _ x. inv_fin x.
    - intros x' v' EQ i ? <-. inversion_clear EQ. inv_fin i=> // i. by apply IH.
  Qed.
  Global Instance vlookup_proper m :
    Proper (equiv ==> eq ==> equiv) (@Vector.nth A m).
  Proof.
    intros v v' ? x x' ->. apply equiv_dist=> n. f_equiv. by apply equiv_dist.
  Qed.

  Global Instance vec_to_list_ne m : NonExpansive (@vec_to_list A m).
  Proof. by intros v v'. Qed.
  Global Instance vec_to_list_proper m : Proper ((≡) ==> (≡)) (@vec_to_list A m).
  Proof. by intros v v'. Qed.
End proper.

(** Functor *)
Definition vec_map {A B : ofe} m (f : A → B) : vecO A m → vecO B m :=
  @vmap A B f m.
Lemma vec_map_ext_ne {A B : ofe} m (f g : A → B) (v : vec A m) n :
  (∀ x, f x ≡{n}≡ g x) → vec_map m f v ≡{n}≡ vec_map m g v.
Proof.
  intros Hf. eapply (list_fmap_ext_ne f g v) in Hf.
  by rewrite -!vec_to_list_map in Hf.
Qed.
Global Instance vec_map_ne {A B : ofe} m f n :
  Proper (dist n ==> dist n) f →
  Proper (dist n ==> dist n) (@vec_map A B m f).
Proof.
  intros ? v v' H. eapply list_fmap_ne in H; last done.
  by rewrite -!vec_to_list_map in H.
Qed.
Definition vecO_map {A B : ofe} m (f : A -n> B) : vecO A m -n> vecO B m :=
  OfeMor (vec_map m f).
Global Instance vecO_map_ne {A A'} m :
  NonExpansive (@vecO_map A A' m).
Proof. intros n f g ? v. by apply vec_map_ext_ne. Qed.

Program Definition vecOF (F : oFunctor) m : oFunctor := {|
  oFunctor_car A _ B _ := vecO (oFunctor_car F A B) m;
  oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := vecO_map m (oFunctor_map F fg)
|}.
Next Obligation.
  intros F A1 ? A2 ? B1 ? B2 ? n m f g Hfg. by apply vecO_map_ne, oFunctor_map_ne.
Qed.
Next Obligation.
  intros F m A ? B ? l.
  change (vec_to_list (vec_map m (oFunctor_map F (cid, cid)) l) ≡ l).
  rewrite vec_to_list_map. apply listOF.
Qed.
Next Obligation.
  intros F m A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' l.
  change (vec_to_list (vec_map m (oFunctor_map F (f ◎ g, g' ◎ f')) l)
    ≡ vec_map m (oFunctor_map F (g, g')) (vec_map m (oFunctor_map F (f, f')) l)).
  rewrite !vec_to_list_map. by apply: (oFunctor_map_compose (listOF F) f g f' g').
Qed.

Global Instance vecOF_contractive F m :
  oFunctorContractive F → oFunctorContractive (vecOF F m).
Proof.
  by intros ?? A1 ? A2 ? B1 ? B2 ? n ???; apply vecO_map_ne; first apply oFunctor_map_contractive.
Qed.


(** * strategies for rewriting in a term algebra *)

From Coq Require Import List Relations Wellfounded Arith.
From CoLoR Require Import closure decidable_set more_list weaved_relation term_spec
     equational_theory_spec dp rpo.

Module Make (E : EqTh).

  Import E.
  Import T.

Inductive P_step (R : relation term) (P : term -> Prop) : term -> term -> Prop :=
  | P_at_top : forall t s, P t -> axiom R s t -> P_step R P s t
  | P_in_context : forall f lt ls, one_step_list (P_step R P) ls lt -> P_step R P (Term f ls) (Term f lt).

Lemma P_step_one_step :
  forall R P s t, P_step R P s t -> one_step R s t.
Proof.
intros R P s t; generalize s; clear s; pattern t; apply term_rec3; clear t.
intros v s H; inversion H; subst; apply at_top; trivial.
intros f l Hl s H;
inversion H as [t' s' Hnf H' | f' lt ls H'];
clear H; subst.
apply at_top; trivial.
apply in_context.
generalize ls H'; clear ls H';
induction l as [ | t l]; intros ls H';
inversion H' as [t1 t2 l' H'' | t' l1 l2 H'']; clear H'; subst.
apply head_step; apply Hl; trivial; left; trivial.
apply tail_step; apply IHl; trivial; intros; apply Hl; trivial; right; trivial.
Qed.

Lemma P_context_cons :
  forall R P f t1 t2 l, trans_clos (P_step R P) t1 t2 ->
      trans_clos (P_step R P) (Term f (t1 :: l)) (Term f (t2 :: l)).
Proof.
intros R P f t1 t2 l H;
induction H as [ | t1 t2 t3 Trans1 Trans2].
apply t_step; apply P_in_context; left; trivial.
apply t_trans with (Term f (t2 :: l)); trivial.
apply P_in_context; left; trivial.
Qed.

Lemma P_step_context_in :
  forall R P t1 t2 f l l', P_step R P t1 t2 ->
   P_step R P (Term f (l ++ t1 :: l')) (Term f (l ++ t2 :: l')).
Proof.
intros R P t1 t2 f l l' H; apply P_in_context;
induction l as [ | t l ]; simpl; [ left | right ]; trivial.
Qed.

Lemma P_context_in :
  forall R P t1 t2, trans_clos (P_step R P) t1 t2 ->
  forall f l l', trans_clos (P_step R P) (Term f (l ++ t1 :: l')) (Term f (l ++ t2 :: l')).
Proof.
intros R P t1 t2 H;
induction H as [ t1 t2 Step
                          | t1 t2 t3 Trans1 Trans2].
intros f l l'; apply t_step; apply P_step_context_in; trivial.
intros f l l'; apply trans_clos_is_trans with (Term f (l ++ t2 :: l')); trivial.
apply t_step; apply P_step_context_in; trivial.
Qed.

Lemma P_general_context :
  forall R P f l1 l2, trans_clos (one_step_list (P_step R P)) l1 l2 -> trans_clos (P_step R P) (Term f l1) (Term f l2).
Proof.
intros R P f l1 l2 H; induction H as [l1 l2 H | l1 l2 l3 H1 H2 H3].
left; right; assumption.
right with (Term f l2); trivial.
right; assumption.
Qed.

Lemma nf_P_step_subterm:
  forall R P t, nf (P_step R P) t -> forall s, direct_subterm s t -> nf (P_step R P) s.
Proof.
intros R P t; pattern t; apply term_rec3; clear t.
intros v _ s H; contradiction.
simpl; intros f l IH Hnf s s_in_l u H.
destruct (In_split _ _ s_in_l) as [l' [l'' H']]; subst.
apply (Hnf (Term f (l' ++ u :: l''))).
apply P_in_context; clear IH Hnf s_in_l; induction l' as [ | s' l']; simpl.
left; trivial.
right; apply IHl'.
Qed.

Lemma P_acc_subterms :
  forall R P, (forall x t, ~ (R t (Var x))) ->
  forall f l, (forall t, In t l -> Acc (P_step R P) t) -> constructor R f ->
                   Acc (P_step R P) (Term f l).
Proof.
intros R P HR f l Acc_l Cf'; inversion Cf' as [f' Cf]; clear Cf'; subst f'.
rewrite acc_one_step_list in Acc_l.
pattern l; refine (@Acc_ind _ (one_step_list (P_step R P)) _ _ l Acc_l).
clear l Acc_l; intros l Acc_l IH.
apply Acc_intro.
intros t H; inversion H as [t' s Hnf H' | f' l1 l2 H']; subst.
inversion H' as [t1 t2 sigma H'' H3 H''']; subst; destruct t2 as [x2 | f2 l2].
absurd (R t1 (Var x2)); trivial; apply HR.
simpl in H'''; injection H'''; clear H'''; intros; subst;
absurd (R t1 (Term f l2)); trivial; apply Cf.
apply IH.
generalize l2 l H'.
intro k; induction k as [ | s k]; intros k' K; inversion K; subst.
left; trivial.
right; trivial.
Qed.

Lemma P_acc_subterms_1 :
   forall R P t s, Acc (P_step R P) t -> direct_subterm s t -> Acc (P_step R P) s.
Proof.
intros R P t s Acc_t; generalize s; clear s; pattern t;
refine (@Acc_ind _ (P_step R P) _ _ t Acc_t).
clear t Acc_t; intros t Acc_t IH s H; destruct t as [ x | f l]; simpl in H.
contradiction.
apply Acc_intro; intros u H';
destruct (In_split _ _ H) as [l1 [l2 H'']]; subst l;
apply (IH (Term f (l1 ++ u :: l2))).
apply P_step_context_in; trivial.
simpl; apply in_or_app; right; left; trivial.
Qed.

Lemma P_acc_subterms_3 :
   forall R P p t s, Acc (P_step R P) t -> subterm_at_pos t p = Some s ->  Acc (P_step R P) s.
Proof.
intros R P p; induction p as [ | i p]; intros t s Acc_t H; simpl in H.
injection H; intro; subst; trivial.
destruct t as [ x | f l].
discriminate.
assert (H' := nth_error_ok_in i l); destruct (nth_error l i) as [ s' | ].
generalize (H' _ (eq_refl _)); clear H'; intro s'_in_l.
apply (IHp s'); trivial; apply (P_acc_subterms_1 R P (Term f l)); trivial.
destruct s'_in_l as [l1 [l2 [_ H']]]; subst l; simpl;
apply in_or_app; right; left; trivial.
discriminate.
Qed.

Lemma var_P_acc :
   forall R P l x sigma, In x (var_list_list l) ->
   (forall t, In t (map (apply_subst sigma) l) -> Acc (P_step R P) t) ->
   Acc (P_step R P) (apply_subst sigma (Var x)).
Proof.
intros R P l; pattern l; apply (list_rec3 size); clear l;
intro n; induction n as [ | n]; intros [ | t l] Sl x sigma H Acc_l.
simpl in H; contradiction.
simpl in Sl; absurd (1 <= 0); auto with arith.
apply le_trans with (size t).
apply size_ge_one.
refine (le_trans _ _ _ _ Sl); auto with arith.
simpl in H; contradiction.
assert (Sl' : list_size size l <= n).
apply le_S_n; refine (le_trans _ _ _ _ Sl); simpl;
apply (plus_le_compat_r 1 (size t) (list_size size l)); apply size_ge_one.
destruct t as [y | g k].
simpl in H; destruct H as [y_eq_x | x_in_l].
subst y; apply Acc_l; simpl map; left; trivial.
apply (IHn l); trivial; intros; apply Acc_l; simpl map; right; trivial.
assert (Sk : list_size size k <= n).
apply le_S_n; refine (le_trans _ _ _ _ Sl); simpl; rewrite (list_size_fold size k);
apply le_n_S; apply le_plus_l.
assert (Acc_k : forall t, In t (map (apply_subst sigma) k) -> Acc (P_step R P) t).
intros t H'; apply P_acc_subterms_1 with (Term g (map (apply_subst sigma) k)).
apply Acc_l; simpl map; left; trivial.
trivial.
replace (var_list_list (Term g k :: l)) with (var_list (Term g k)  ++ var_list_list l) in H; trivial.
rewrite var_list_unfold in H.
generalize (IHn _ Sk x sigma).
destruct (in_app_or _ _ _ H) as [x_in_k | x_in_l].
clear H; intro H; generalize (H x_in_k); clear H; intro H; apply H.
intros t H'; apply Acc_k; trivial.

simpl in H; intros _; apply (IHn l); trivial.
intros t H'; apply Acc_l; right; trivial.
Qed.

Lemma P_acc_with_subterm_subterms :
  forall R P t, Acc (union _ (P_step R P) direct_subterm) t ->
                 forall s, direct_subterm s t -> Acc (union _ (P_step R P) direct_subterm) s.
Proof.
intros R P t Acc_t; induction Acc_t as [t Acc_t IH].
intros s H; apply Acc_t; right; trivial.
Qed.

Lemma P_acc_with_subterm :
  forall R P t, Acc (P_step R P) t <->  Acc (union _ (P_step R P) direct_subterm) t.
Proof.
intros R P t; split.
intro Acc_t; induction Acc_t as [t Acc_t IH].
generalize Acc_t IH; clear Acc_t IH; pattern t; apply term_rec2; clear t.
intro n; induction n as [ | n]; intros t size_t Acc_t IH.
absurd (1 <= 0); auto with arith; apply le_trans with (size t); trivial;
apply size_ge_one.
apply Acc_intro.
intros u H; destruct H as [H | H].
(* 1/2 one_step R *)
apply IH; trivial.
(* 1/1 direct_subterm *)
apply IHn.
apply le_S_n; apply le_trans with (size t); trivial.
apply size_direct_subterm; trivial.
assert (H' : Acc (P_step R P) u).
apply P_acc_subterms_1 with t; trivial.
apply Acc_intro; apply Acc_t.
inversion H'; trivial.
intros v v_R_u.
destruct t as [ x | f l].
contradiction.
destruct (In_split _ _ H) as [l' [l'' H'']]; clear H; subst l.
apply (P_acc_with_subterm_subterms R P (Term f (l' ++ v :: l''))).
apply IH; apply P_step_context_in; trivial.
simpl; apply in_or_app; right; left; trivial.
apply Acc_incl; intros t1 t2 H; left; trivial.
Qed.

Lemma P_step_in_list :
  forall R P l l', one_step_list (P_step R P) l' l ->
  exists t, exists t', exists l1, exists l2, P_step R P t' t /\  l = l1 ++ t :: l2 /\ l' = l1 ++ t' :: l2.
Proof.
intros R P l l' H'; induction H'.
exists t2; exists t1; exists (@nil term); exists l; repeat split; trivial.
destruct IHH' as [u [u' [l3 [l4 [H1 [H2 H3]]]]]]; subst.
exists u; exists u'; exists (t :: l3); exists l4; repeat split; trivial.
Qed.

Definition inner (R : relation term) (t : term) :=
  forall s, direct_subterm s t -> nf (one_step R) s.

Lemma one_step_nf_inner_step_nf :
  forall (R : relation term), (forall t v, R t (Var v) -> False) ->
  forall t, nf (one_step R) t <-> nf (P_step R (inner R)) t.
Proof.
intros R Rvar t; split.
intros H s H'; apply (H s); apply (P_step_one_step R (inner R)); trivial.
pattern t; apply term_rec3; clear t.
intros v _ s H'; inversion H' as [t1 t2 H'' | f' l1 l2 H'']; clear H'; subst.
inversion H''; clear H''; subst.
destruct t2 as [v2 | f2 l2].
apply (Rvar t1 v2); trivial.
discriminate.
intros f l IH H s H'.
apply (H s); apply P_at_top.
intros t t_in_l; apply IH; trivial.
apply nf_P_step_subterm with (Term f l); trivial.
inversion H' as [t1 t2 H'' | f' l1 l2 H'']; clear H'; subst; trivial.
assert (H' : forall t, In t l -> nf (one_step R) t).
intros t t_in_l; apply IH; trivial.
apply nf_P_step_subterm with (Term f l); trivial.
assert False.
generalize l1 H'' H'; clear IH H l1 H'' H';
induction l as [ | t l]; intros l1 H'' H';
inversion H'' as [t1 t2' l' H3 | t' l1' l2' H3]; clear H''; subst.
apply (H' t (or_introl _ (eq_refl _)) t1); trivial.
apply (IHl l1'); trivial.
intros s s_in_l; apply H'; right; trivial.
contradiction.
Qed.

Lemma nf_dec_inner_dec :
  forall R, (forall t, {nf (one_step R) t}+{~ nf (one_step R) t}) ->
  forall t, {inner R t}+{~inner R t}.
Proof.
intros R nf_dec [v | f l].
left; intro s; simpl; contradiction.
unfold inner; simpl; induction l as [ | t l].
left; intro s; simpl; contradiction.
destruct (nf_dec t) as [nf_t | red_t].
destruct IHl as [nf_l | red_l].
left; intros s [s_eq_t | s_in_l]; [subst | apply nf_l]; trivial.
right; intro nf_tl; apply red_l; intros s s_in_l; apply nf_tl; right; trivial.
right; intro nf_tl; apply red_t; apply nf_tl; left; trivial.
Defined.

Section Context_sensitive.
Parameter mu : F.Symb.A -> list nat.

(*
Parameter mu_ok :
forall f, forall i, In i (mu f) -> i < match F.arity f with Free n => n | _ => 2 end.
*)

Inductive C_step (R : relation term) : term -> term -> Prop :=
  | C_at_top : forall t s, axiom R s t -> C_step R s t
  | C_in_context :
     forall f n lt ls, C_list R n ls lt -> In n (mu f) -> C_step R (Term f ls) (Term f lt)

   with C_list (R : relation term) : nat -> list term -> list term -> Prop :=
    | C_head_step : forall t1 t2 l, C_step R t1 t2 -> C_list R 0 (t1 :: l) (t2 :: l)
    | C_tail_step : forall t l1 l2 i, C_list R i l1 l2 -> C_list R (S i) (t :: l1) (t :: l2).

Definition shifted_active_in_list shift f l (s : term) :=
exists i, In (shift + i) (mu f) /\ nth_error l i = Some s.

Definition active_in_list f l (s : term) := shifted_active_in_list 0 f l s.

Definition active_direct_subterm s t :=
  match t with
  | Var _ => False
  | Term f l => active_in_list f l s
  end.

Definition active_subterm s t := refl_trans_clos active_direct_subterm s t.

Fixpoint active_position t p {struct p} : bool :=
match p with
| nil => true
| i :: q =>
   match t with
   | Var _ => false
   | Term f l =>
        andb (mem_bool beq_nat i (mu f))
                 (match nth_error l i with
                 | None => false
                 | Some ti => active_position ti q
                 end)
   end
end.

Lemma active_is_active :
  forall s t, active_subterm s t <-> (exists p, active_position t p = true /\ subterm_at_pos t p = Some s).
Proof.
intros s t; split.
intro H; inversion H as [u | s' t' H']; clear H.
subst; exists nil; simpl; split; apply eq_refl.
subst s' t'; rewrite trans_clos_trans_clos_alt in H'; induction H' as [x y H | x y z H1 H2].
destruct y as [v | f l].
contradiction.
destruct H as [i [K1 K2]].
exists (i :: nil); simpl; split.
generalize (mem_bool_ok _ _ beq_nat_ok i (mu f)); case (mem_bool beq_nat i (mu f)).
intros _; simpl; rewrite K2; apply eq_refl.
intro i_not_in_mu_f; apply False_rect; apply i_not_in_mu_f.
apply (in_impl_mem (@eq _) (fun a => eq_refl a) i (mu f) K1).
rewrite K2; apply eq_refl.
destruct z as [v | f l].
contradiction.
destruct H as [i [K1 K2]].
destruct H2 as [p [K3 K4]].
exists (i :: p); simpl; split.
generalize (mem_bool_ok _ _ beq_nat_ok i (mu f)); case (mem_bool beq_nat i (mu f)).
intros _; simpl; rewrite K2; assumption.
intro i_not_in_mu_f; apply False_rect; apply i_not_in_mu_f.
apply (in_impl_mem (@eq _) (fun a => eq_refl a) i (mu f) K1).
rewrite K2; assumption.
intros [p [H1 H2]].
revert s t H1 H2; induction p as [ | i p]; intros s t H1 H2.
simpl in H2; injection H2; clear H2; intros; subst; left.
destruct t as [x | f l].
discriminate.
simpl in H1; simpl in H2.
revert H1 H2; generalize (nth_error_ok_in i l); case (nth_error l i).
intros ti H; destruct (H _ (eq_refl _)) as [l1 [l2 [L H']]]; clear H.
generalize (mem_bool_ok _ _ beq_nat_ok i (mu f)); case (mem_bool beq_nat i (mu f)).
intro i_in_mu_f; simpl; intros H1 H2.
apply refl_trans_clos_is_trans with ti.
apply IHp; trivial.
right; left; exists i; split.
apply mem_impl_in with (@eq _); trivial.
subst l i; rewrite nth_error_at_pos; apply eq_refl.
intros; discriminate.
intros; discriminate.
Qed.

Lemma context_acc_subterms_1 :
   forall R t s, Acc (C_step R) t -> active_direct_subterm s t -> Acc (C_step R) s.
Proof.
intros R t s Acc_t; generalize s; clear s; pattern t.
refine (@Acc_ind _ (C_step R) _ _ t Acc_t).
clear t Acc_t; intros t Acc_t IH s H.
 destruct t as [ x | f l]; simpl in H.
contradiction.
apply Acc_intro; intros u H'.
destruct H as [i [H1 H2]].
destruct (nth_error_ok_in _ _ H2) as [l1 [l2 [L H'']]]; subst l.
apply (IH (Term f (l1 ++ u :: l2))).
apply C_in_context with i; trivial.
subst i; revert H'; clear; induction l1 as [ | a1 l1]; intro H.
left; assumption.
right; apply IHl1; assumption.
exists (length l1); split.
subst; trivial.
rewrite nth_error_at_pos; apply eq_refl.
Qed.

Lemma context_acc_subterms_2 :
   forall R t s, Acc (C_step R) t -> active_subterm s t -> Acc (C_step R) s.
Proof.
intros R t s Acc_t H.
inversion H as [u | s' t' H']; clear H.
assumption.
subst.
rewrite trans_clos_trans_clos_alt in H'.
induction H' as [x y | x y z].
apply context_acc_subterms_1 with y; trivial.
apply IHH'.
apply context_acc_subterms_1 with z; trivial.
Qed.

Lemma instanciated_active_subterm :
  forall s t sigma, active_subterm s t -> active_subterm (apply_subst sigma s) (apply_subst sigma t).
Proof.
intros s t sigma H; inversion H as [u | s' t' H']; clear H.
left.
subst; rewrite trans_clos_trans_clos_alt in H'; induction H' as [x y | x y z].
right; left.
destruct y as [v | f l].
contradiction.
destruct H as [i [H1 H2]].
exists i; split; trivial.
generalize (nth_error_map (apply_subst sigma) l i); rewrite H2.
case (nth_error (map (apply_subst sigma) l) i).
intros ti Hi; rewrite Hi; apply eq_refl.
contradiction.
apply refl_trans_clos_is_trans with (apply_subst sigma y); trivial.
right; left; destruct z as [v | f l].
contradiction.
destruct H as [i [H1 H2]].
exists i; split; trivial.
generalize (nth_error_map (apply_subst sigma) l i); rewrite H2.
case (nth_error (map (apply_subst sigma) l) i).
intros ti Hi; rewrite Hi; apply eq_refl.
contradiction.
Qed.

Lemma active_position_in_instanciated_term :
  forall p t s sigma, active_position (apply_subst sigma t) p = true -> subterm_at_pos t p = Some s ->
  active_position t p = true.
Proof.
intro p; induction p as [ | i p].
intros; trivial.
intros [v | f l] s sigma; simpl.
intros; discriminate.
case (mem_bool beq_nat i (mu f)); [idtac | intros; discriminate].
generalize (nth_error_map (apply_subst sigma) l i).
case (nth_error (map (apply_subst sigma) l) i); [idtac | intros; discriminate]; simpl.
generalize (nth_error_ok_in i l); case (nth_error l i); [idtac | contradiction].
intros t H s' H'; destruct (H _ (eq_refl _)) as [l1 [l2 [L K]]]; clear H; subst.
apply IHp; apply in_or_app; right; left; apply eq_refl.
Qed.

Inductive cdp (R : relation term) : term -> term -> Prop:=
  | Cdp : forall t1 t2 f2 l2, R t2 t1 ->
                active_subterm (Term f2 l2) t2 ->
                defined R f2 ->
                cdp R (Term f2 l2) t1.

Inductive vdp (R : relation term) : term -> term -> Prop:=
  | Vdp : forall t1 t2 x, R t2 t1 ->
                active_subterm (Var x) t2 -> (not (active_subterm (Var x) t1)) ->
                vdp R (Var x) t1.

Definition c_in_context R shift f ls lt := exists n, C_list R n ls lt /\ In (shift + n) (mu f).

Inductive cdp_step (R : relation term) : term -> term -> Prop :=
   | Cdp_step :
       forall f l1 l2 t3,
       refl_trans_clos (c_in_context R 0 f) l2 l1 -> axiom (cdp R) t3 (Term f l2) ->
       cdp_step R t3 (Term f l1)
  | Vdp_step :
       forall f l1 l2 t3 w,
       refl_trans_clos (c_in_context R 0 f) l2 l1 -> axiom (vdp R) t3 (Term f l2) ->
       active_subterm w t3 ->
       cdp_step R w (Term f l1).

Lemma Context_Acc_var :
  forall R, (forall x t, ~ (R t (Var x))) -> forall x, Acc (C_step R) (Var x).
Proof.
intros R HR x; apply Acc_intro.
intros y H; inversion H; clear H; subst.
inversion H0; clear H0; subst.
destruct t2 as [x2 | f2 l2].
apply False_rect; apply (HR _ _ H2).
discriminate.
Qed.

Fixpoint actives f n l : list term :=
match l with
| nil => nil
| t :: l => if mem_bool beq_nat n (mu f) then t :: (actives f (S n) l) else (actives f (S n) l)
end.

Lemma actives_ok :
  forall f n l s, In s (actives f n l) <-> shifted_active_in_list n f l s.
Proof.
intros f n l; revert n; induction l as [ | t l]; intros n s; simpl; split.
contradiction.
intros [[ | i] [_ H]]; discriminate.
generalize (mem_bool_ok _ _ beq_nat_ok n (mu f)).
case (mem_bool beq_nat n (mu f)).
intro n_in_mu_f.
simpl; intros [s_eq_t | s_in_actives].
subst s; exists 0; split; trivial.
rewrite plus_comm; apply mem_impl_in with (@eq _); trivial.
rewrite IHl in s_in_actives; destruct s_in_actives as [i [H1 H2]].
exists (S i); split; trivial.
rewrite plus_comm; simpl; rewrite plus_comm; assumption.
intro n_not_in_mu_f.
rewrite IHl; intros [i [H1 H2]].
exists (S i); split; trivial.
rewrite plus_comm; simpl; rewrite plus_comm; assumption.
generalize (mem_bool_ok _ _ beq_nat_ok n (mu f)).
case (mem_bool beq_nat n (mu f)).
intro n_in_mu_f.
intros [[ | i] [H1 H2]].
simpl in H2; injection H2; clear H2; intro; subst s; left; apply eq_refl.
right; rewrite IHl.
exists i; split; trivial.
revert H1; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
intro n_not_in_mu_f.
intros [[ | i] [H1 H2]].
rewrite plus_comm in H1; apply False_rect; apply n_not_in_mu_f; apply in_impl_mem; trivial.
rewrite IHl; exists i; split; trivial.
revert H1; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
Qed.

Lemma shifting_context :
forall R f shift l',
Acc (c_in_context R shift f) l' ->
Acc (c_in_context R (S shift) f) (match l' with nil => nil | _ :: l => l end).
Proof.
intros R f shift l Acc_l; induction Acc_l as [l Acc_l IH].
destruct l as [ | t l].
apply Acc_intro; intros y [n [H _]]; inversion H.
apply Acc_intro; intros k H.
apply (IH (t :: k)).
unfold c_in_context in *.
destruct H as [n [H1 H2]].
exists (S n); split.
apply C_tail_step; assumption.
rewrite plus_comm; simpl; rewrite plus_comm; assumption.
Qed.

Lemma shifting_head :
forall R f shift l, Acc (c_in_context R shift f) l ->
mem eq shift (mu f) -> (forall t, (exists k, l = t::k) -> Acc (C_step R) t).
Proof.
intros R f shift l Acc_l; induction Acc_l as [l Acc_l IH].
destruct l as [ | t l].
intros _ t [l H]; discriminate.
intros shift_in_mu_f.
intros s [l' H].
injection H; clear H; intros; subst s l'.
apply Acc_intro; intros s H.
apply (IH (s :: l)).
exists 0; split.
left; trivial.
rewrite plus_comm; simpl.
apply mem_impl_in with (@eq _); trivial.
assumption.
exists l; apply eq_refl.
Qed.

Lemma filtering :
  forall R shift f l l1,
    c_in_context R shift f l1 l ->
    one_step_list (C_step R) (actives f shift l1) (actives f shift l).
Proof.
intros R shift f l; revert f shift.
induction l as [ | t l]; simpl; intros f shift l1.
(* 1/4 nil *)
intros [n [H _]]; inversion H.
(* 1/2 t :: l *)
intros [n [K H]]; inversion K; clear K; subst; simpl.
generalize (mem_bool_ok _ _ beq_nat_ok shift (mu f)); case (mem_bool beq_nat shift (mu f)).
intro shift_in_mu_f; left; assumption.
intro shift_not_in_mu; apply False_rect; rewrite plus_comm in H;
apply shift_not_in_mu; apply in_impl_mem; trivial.
generalize (mem_bool_ok _ _ beq_nat_ok shift (mu f)); case (mem_bool beq_nat shift (mu f)).
intros _; right; apply IHl.
exists i; split; trivial.
revert H; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
intros _; apply IHl.
exists i; split; trivial.
revert H; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
Qed.

Lemma acc_filtering :
  forall R shift f l, Acc (c_in_context R shift f) l <-> Acc (one_step_list (C_step R)) (actives f shift l).
Proof.
intros R shift f l; revert f shift.
induction l as [ | t l]; simpl; split.
(* 1/4 nil -> *)
intro Acc_nil; apply Acc_intro; intros y H; inversion H.
(* 1/3 nil <- *)
intro Acc_nil; apply Acc_intro; intros y [n [H _]]; inversion H.
(* 1/2 t :: l -> *)
intro Acc_l.
apply Acc_intro.
generalize (mem_bool_ok _ _ beq_nat_ok shift (mu f)); case (mem_bool beq_nat shift (mu f)).
(* 1/3 shift belongs to (mu f) *)
intro shift_in_mu_f.
intros k H.
inversion H; clear H; subst.
(* 1/4 reduction at head position t1 <- t *)
rewrite <- acc_one_step_list.
simpl; intros u [u_eq_t1 | u_in_actives].
subst; apply Acc_inv with t; trivial.
apply (shifting_head _ _ _ _ Acc_l); trivial.
exists l; apply eq_refl.
revert u u_in_actives.
rewrite acc_one_step_list.
rewrite <- IHl.
revert Acc_l; clear.
apply shifting_context.
(* 1/3 reduction in the tail *)
rewrite <- acc_one_step_list.
simpl; intros u [u_eq_t1 | u_in_actives].
subst u; apply (shifting_head _ _ _ _ Acc_l); trivial.
exists l; apply eq_refl.
revert u u_in_actives; rewrite acc_one_step_list.
apply Acc_inv with (actives f (S shift) l); trivial.
rewrite <- IHl.
apply (shifting_context _ _ _ _ Acc_l).
(* 1/2 shift DOES NOT belong to (mu f) *)
intros shift_not_in_mu_f.
intros k H.
apply Acc_inv with (actives f (S shift) l); trivial.
rewrite <- IHl.
apply (shifting_context _ _ _ _ Acc_l).
(* 1/1 t :: l <-  *)
generalize (mem_bool_ok _ _ beq_nat_ok shift (mu f)); case (mem_bool beq_nat shift (mu f)).
(* 1/2 shift belongs to (mu f) *)
intro shift_in_mu_f.
rewrite <- acc_one_step_list.
intros Acc_tl.
assert (Acc_l := tail_prop _ Acc_tl).
rewrite acc_one_step_list in Acc_l.
rewrite <- IHl in Acc_l.
assert (Acc_t := Acc_tl _ (or_introl _ (eq_refl _))).
clear Acc_tl.
clear IHl; revert l Acc_l.
induction Acc_t as [t Acc_t IH].
intros l Acc_l.
revert t Acc_t IH; induction Acc_l as [l Acc_l IHl].
intros t Acc_t IHt.
apply Acc_intro; intros k H.
destruct H as [n [H1 H2]].
inversion H1; clear H1; subst.
(* 1/3 reduction at the head *)
apply IHt; trivial.
apply Acc_intro; assumption.
(* 1/2 reduction in the tail *)
apply IHl; trivial.
exists i; split; trivial.
revert H2; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
(* 1/1 shift DOES NOT belong to (mu f) *)
intros shift_not_in_mu_f.
rewrite <- IHl.
clear IHl.
intro Acc_l; induction Acc_l as [l Acc_l IH].
apply Acc_intro; intros k H.
destruct H as [n [H1 H2]].
inversion H1; clear H1; subst.
apply False_rect; apply shift_not_in_mu_f.
apply in_impl_mem; trivial.
rewrite plus_comm in H2; assumption.
apply IH; exists i; split; trivial.
revert H2; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
Qed.

Lemma Acc_C_step_acc_c_in_context :
forall R f l, (forall s, active_in_list f l s -> Acc (C_step R) s) -> Acc (c_in_context R 0 f) l.
Proof.
intros R f l Acc_l.
rewrite acc_filtering.
rewrite <- acc_one_step_list.
intros s s_in_actives; apply Acc_l.
unfold active_in_list.
revert s s_in_actives; clear.
intros s H; rewrite <- actives_ok; assumption.
Qed.

Lemma context_acc_subterms :
  forall R, (forall x t, ~ (R t (Var x))) ->
  forall f l, (forall t, active_in_list f l t -> Acc (C_step R) t) -> constructor R f ->
                   Acc (C_step R) (Term f l).
Proof.
intros R HR f l Acc_l Cf'; inversion Cf' as [f' Cf]; clear Cf'; subst f'.
assert (Acc_l' := Acc_C_step_acc_c_in_context _ _ _ Acc_l); clear Acc_l.
induction Acc_l' as [l Acc_l IH].
apply Acc_intro.
intros t H; inversion H as [t1 t2 H' | f' n l1 l2 H']; subst.
inversion H' as [t1 t2 sigma H'' H3 H''']; subst; destruct t2 as [x2 | f2 l2].
absurd (R t1 (Var x2)); trivial; apply HR.
simpl in H'''; injection H'''; clear H'''; intros; subst;
absurd (R t1 (Term f l2)); trivial; apply Cf.
apply IH.
exists n; split; trivial.
Qed.

Lemma active_dec : forall s t, {active_subterm s t}+{~ active_subterm s t}.
Proof.
intros s t; revert s; pattern t; apply term_rec3.
(* 1/2 variable case *)
intros v s; generalize (eq_bool_ok s (Var v)); case (eq_bool s (Var v)).
intros s_eq_v; left; subst s; left.
intros s_diff_v; right; intro A; apply s_diff_v.
inversion A; subst; trivial.
rewrite trans_clos_trans_clos_alt in H.
inversion H; clear H; subst.
inversion H0.
inversion H1.
(* compound term case (Term f l) *)
intros f l IH s.
generalize (eq_bool_ok s (Term f l)); case (eq_bool s (Term f l)).
(* 1/2 s is equal to (Term f l) *)
intro s_eq_fl; left; subst s; left.
(* 1/1 s is different from (Term f l) *)
intros s_diff_fl.
assert (H : {ti | In ti l /\ active_subterm s ti /\ active_direct_subterm ti (Term f l)}+
                  {forall ti, In ti l -> active_direct_subterm ti (Term f l) -> active_subterm s ti -> False}).
(* 1/2 main proof on l *)
clear s_diff_fl; simpl.
unfold active_in_list; generalize 0.
revert s; induction l as [ | t1 l].
(* 1/3 l is equal to nil *)
intros s n; right; intros; contradiction.
(* 1/2 l is equal to (t1 :: l) *)
intros s n; simpl.
generalize (mem_bool_ok _ _ beq_nat_ok n (mu f)); case (mem_bool beq_nat n (mu f)).
(* 1/3 n is in (mu f) *)
intro n_in_mu_f; destruct (IH _ (or_introl _ (eq_refl _)) s) as [A1 | not_A1].
(* 1/4 s is active in t1 *)
left; exists t1; split.
left; apply eq_refl.
split; trivial.
exists 0; split.
rewrite plus_comm; apply mem_impl_in with (@eq _); trivial.
apply eq_refl.
(* 1/3 s is NOT active in t1 *)
destruct (IHl (tail_set _ IH) s (S n)) as [Ai | not_Al].
(* 1/4 there is a ti such that s is active in ti *)
destruct Ai as [ti [ti_in_l [Ai Al]]].
left; exists ti; split; [idtac | split].
right; assumption.
assumption.
destruct Al as [i [H1 H2]].
exists (S i); split; trivial.
rewrite plus_comm; simpl; rewrite plus_comm; trivial.
(* 1/3 there is no ti such that s is active in ti *)
right; intros ti [t1_eq_ti | ti_in_l] Al Ai.
apply not_A1; subst ti; assumption.
destruct Al as [[ | i] [H1 H2]].
injection H2; clear H2; intro; subst ti.
apply not_A1; assumption.
apply (not_Al ti ti_in_l); trivial.
exists i; split; trivial.
revert H1; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
(* 1/2 n in NOT in (mu f) *)
intro not_mem_n_mu_f.
destruct (IHl (tail_set _ IH) s (S n)) as [Ai | not_Al].
(* 1/3 there is a ti such that s is active in ti *)
destruct Ai as [ti [ti_in_l [Ai Al]]].
left; exists ti; split; [idtac | split].
right; assumption.
assumption.
destruct Al as [i [H1 H2]].
exists (S i); split; trivial.
rewrite plus_comm; simpl; rewrite plus_comm; trivial.
(* 1/2 there is no ti such that s is active in ti *)
right; intros ti [t1_eq_ti | ti_in_l] Al Ai.
(* 1/3 proof of the right alternative for t1 *)
destruct Al as [[ | i] [H1 H2]].
rewrite plus_comm in H1; apply not_mem_n_mu_f; apply in_impl_mem; trivial.
apply (not_Al ti); trivial.
simpl in H2; destruct (nth_error_ok_in _ _ H2) as [l1 [l2 [L H]]];
subst l; apply in_or_app; right; left; apply eq_refl.
exists i; split; trivial.
revert H1; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
(* 1/2 proof of the right alternative for ti *)
apply (not_Al ti); trivial.
destruct Al as [[ | i] [H1 H2]].
apply False_rect; rewrite plus_comm in H1; apply not_mem_n_mu_f; apply in_impl_mem; trivial.
simpl in H2; exists i; split; trivial.
revert H1; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
(* 1/1 application of the main proof *)
destruct H as [[ti [ti_in_l [Ai Al]]] | H].
left; apply refl_trans_clos_is_trans with ti; trivial.
right; left; trivial.
right; intro A; inversion A as [u | x y A']; clear A.
subst; apply s_diff_fl; apply eq_refl.
rewrite trans_clos_trans_clos_alt in A'; inversion A' as [x' y' A'' | x' y' z' A1 A2]; clear A'; subst.
apply (H s); trivial.
destruct A'' as [i [H1 H2]].
simpl in H2; destruct (nth_error_ok_in _ _ H2) as [l1 [l2 [L H3]]];
subst l; apply in_or_app; right; left; apply eq_refl.
left.
apply (H y'); trivial.
destruct A2 as [i [H1 H2]].
simpl in H2; destruct (nth_error_ok_in _ _ H2) as [l1 [l2 [L H3]]];
subst l; apply in_or_app; right; left; apply eq_refl.
rewrite <- trans_clos_trans_clos_alt in A1; right; trivial.
Qed.

Lemma cdp_criterion_local :
  forall R, (forall x t, ~ (R t (Var x))) ->
  (forall s t, R s t -> forall x, In x (var_list s) -> In x (var_list t)) ->
  (forall f, {constructor R f} + {defined R f}) ->
  forall t,   Acc (cdp_step R) t -> (forall s, active_direct_subterm s t -> Acc (C_step R) s) ->
              Acc (C_step R) t.
Proof.
intros R HR RR CD.
(* main proof *)
intros t Acc_t; induction Acc_t as [t Acc_t IH].
intros Acc_l; destruct t as [x | f l].
apply Context_Acc_var; assumption.
simpl active_direct_subterm in Acc_l.
assert (Acc_l' := Acc_C_step_acc_c_in_context _ _ _ Acc_l).
rewrite acc_filtering in Acc_l'.
clear Acc_l; rename Acc_l' into Acc_l.
set (actives_l := actives f 0 l).
generalize (eq_refl actives_l).
unfold actives_l at 2.
clearbody actives_l.
intro H; rewrite <- H in Acc_l.
revert l H IH Acc_t.
induction Acc_l as [actives_l Acc_l IHl]; intros l AH IH Acc_t.
assert (Acc_l' : Acc (one_step_list (C_step R)) actives_l).
apply Acc_intro; assumption.
clear Acc_l; rename Acc_l' into Acc_l.
rewrite <- acc_one_step_list in Acc_l.
apply Acc_intro;
intros s H; destruct s as [x1 | f1 l1].
apply Context_Acc_var; assumption.
inversion H as [t1 t2 H' | f' n l1' l2 H']; clear H; subst.
(* 1/2 rewrite step at the top *)
inversion H' as [t1 t2 sigma t1_R_t2 H1 H2]; clear H'.
destruct t2 as [x | g k].
absurd (R t1 (Var x)); trivial; apply HR.
simpl in H2; injection H2; clear H2; intros; subst g l.
assert (H'' : forall n t, size t <= n -> active_subterm t (apply_subst sigma t1) ->
                                                        Acc (C_step R) t).
intro n; induction n as [ | n].
intros t St; absurd (1 <= 0); auto with arith;
apply le_trans with (size t); trivial; apply size_ge_one.
intros [x | g h] St A.
(* 1/4 t is a variable *)
apply Context_Acc_var; trivial.
(* 1/3 t = Term g h *)
assert (Acc_h : forall t, In t h -> active_subterm t (apply_subst sigma t1) -> Acc (C_step R) t).
intros t t_in_h At; apply IHn; trivial.
apply le_S_n; refine (le_trans _ _ _ _ St); apply size_direct_subterm; simpl; trivial.
destruct (CD g) as [Cg | Dg].
(* 1/4 g is a constructor symbol *)
simpl; apply context_acc_subterms; trivial.
intros t t_in_h; apply Acc_h.
revert t_in_h; clear; unfold active_in_list, shifted_active_in_list; generalize 0.
induction h as [ | s h].
simpl; intros n [[ | i] [_ H]]; discriminate.
intros n [[ | i] [H1 H2]]; simpl in H2.
injection H2; clear H2; intros; left; assumption.
right; apply IHh with (S n).
exists i; split; trivial.
revert H1; rewrite plus_comm; simpl; rewrite plus_comm; trivial.
apply refl_trans_clos_is_trans with (Term g h); trivial.
right; left; trivial.
(* 1/3 g is a defined symbol *)
rewrite active_is_active in A.
destruct A as [p [Ap Sub]].
generalize (subterm_in_instantiated_term _ _ _ Sub).
case_eq (subterm_at_pos t1 p).
(* 1/4 almost standard case, p is a position of t1 *)
intros u Sub' H.
destruct u as [xu | g' lu].
(* 1/5 u is a variable xu *)
destruct (active_dec (Var xu) (Term f k)) as [Axu_in_k | not_Axu_in_k].
(* 1/6 xu is active in (Term f k),  *)
inversion Axu_in_k as [xu' | xu' fk' Axu_in_k']; clear Axu_in_k; subst.
rewrite trans_clos_trans_clos_alt in Axu_in_k'; inversion Axu_in_k' as [xu' fk' Axu_in_k | xu' y fk' A1 A2]; subst.
apply Acc_l.
destruct Axu_in_k as [i [K1 K2]].
rewrite actives_ok; exists i; split; trivial.
generalize (nth_error_map (apply_subst sigma) k i); rewrite K2.
case (nth_error (map (apply_subst sigma) k) i).
intros ti Hi; rewrite H; rewrite Hi; apply eq_refl.
contradiction.
apply context_acc_subterms_2 with (apply_subst sigma y).
apply Acc_l.
destruct A2 as [i [K1 K2]].
rewrite actives_ok; exists i; split; trivial.
generalize (nth_error_map (apply_subst sigma) k i); rewrite K2.
case (nth_error (map (apply_subst sigma) k) i).
intros ti Hi; rewrite Hi; apply eq_refl.
contradiction.
rewrite H; apply instanciated_active_subterm; rewrite <- trans_clos_trans_clos_alt in A1; right; assumption.
(* 1/5 xu is not active in (Term f k) *)
apply IH.
apply Vdp_step with (map (apply_subst sigma) k) (Term g h).
left.
rewrite H.
replace (Term f (map (apply_subst sigma) k)) with (apply_subst sigma (Term f k)); trivial.
apply instance; apply Vdp with t1; trivial.
rewrite active_is_active; exists p; split; trivial.
apply active_position_in_instanciated_term with (Var xu) sigma; trivial.
left.
intros s s_in_h; apply Acc_h.
destruct s_in_h as [i [K1 K2]].
destruct (nth_error_ok_in _ _ K2) as [h1 [h2 [L K3]]]; subst; apply in_or_app; right; left; apply eq_refl.
apply refl_trans_clos_is_trans with (Term g h); trivial.
right; left; trivial.
assert (Dummy : active_subterm (Term g h) (apply_subst sigma t1)).
rewrite active_is_active.
exists p; split; trivial.
assumption.
(* 1/4 us is a compound term (Term g' lu) *)
rewrite H.
apply IH.
apply Cdp_step with (map (apply_subst sigma) k).
left.
replace (Term f (map (apply_subst sigma) k)) with (apply_subst sigma (Term f k)); trivial.
apply instance.
apply Cdp with t1; trivial.
rewrite active_is_active; exists p; split; trivial.
apply active_position_in_instanciated_term with (Term g' lu) sigma; trivial.
injection H; clear H; intros; subst; assumption.
intros s As; apply Acc_h.
rewrite <- H in As; destruct As as [i [K1 K2]].
destruct (nth_error_ok_in _ _ K2) as [h1 [h2 [L K3]]]; subst; apply in_or_app; right; left; apply eq_refl.
apply refl_trans_clos_is_trans with (Term g h); trivial.
right; left; rewrite H; assumption.
assert (Dummy : active_subterm (Term g h) (apply_subst sigma t1)).
rewrite active_is_active; exists p; split; trivial.
unfold active_subterm in Dummy; assumption.
(* 1/3 special case, p is a NOT position of t1 *)
intros Sub' [v [q [q' [J1 [v_in_t1 [Sub'' J2]]]]]]; subst p.
destruct (active_dec (Var v) (Term f k)) as [Av_in_k | not_Av_in_k].
(* 1/4 v is active in (Term f k)  *)
apply context_acc_subterms_2 with (apply_subst sigma (Var v)).
inversion Av_in_k as [v' | v' fk' Av_in_k']; clear Av_in_k; subst.
rewrite trans_clos_trans_clos_alt in Av_in_k'; inversion Av_in_k' as [v' fk' Av_in_k | v' y fk' A1 A2]; subst.
apply Acc_l.
destruct Av_in_k as [i [K1 K2]].
rewrite actives_ok; exists i; split; trivial.
generalize (nth_error_map (apply_subst sigma) k i); rewrite K2.
case (nth_error (map (apply_subst sigma) k) i).
intros ti Hi; rewrite Hi; apply eq_refl.
contradiction.
apply context_acc_subterms_2 with (apply_subst sigma y).
apply Acc_l.
destruct A2 as [i [K1 K2]].
rewrite actives_ok; exists i; split; trivial.
generalize (nth_error_map (apply_subst sigma) k i); rewrite K2.
case (nth_error (map (apply_subst sigma) k) i).
intros ti Hi; rewrite Hi; apply eq_refl.
contradiction.
apply refl_trans_clos_is_trans with (apply_subst sigma (Var v)).
assert (Dummy : active_subterm (Term g h) (apply_subst sigma (Var v))).
rewrite active_is_active; exists q'; split; trivial.
generalize (subterm_at_pos_apply_subst_apply_subst_subterm_at_pos t1 q sigma).
rewrite Sub''; trivial.
revert Ap.
generalize (apply_subst sigma t1) (apply_subst sigma (Var v)); clear.
revert q'; induction q as [ | i q]; simpl.
intros q' t s A H; injection H; clear H; intros; subst; trivial.
intros q' [v | f l] s.
intros; discriminate.
case (mem_bool beq_nat i (mu f)); [idtac | intros; discriminate].
simpl; case (nth_error l i); [idtac | intros; discriminate].
intro t; apply IHq.
left.
assert (Dummy : active_subterm (apply_subst sigma (Var v)) (apply_subst sigma y)).
apply instanciated_active_subterm; rewrite <- trans_clos_trans_clos_alt in A1; right; assumption.
assumption.
rewrite active_is_active; exists q'; split; trivial.
assert (Sub''' : subterm_at_pos (apply_subst sigma t1) q  = Some (apply_subst sigma (Var v))).
generalize (subterm_at_pos_apply_subst_apply_subst_subterm_at_pos t1 q sigma).
rewrite Sub''; trivial.
revert Ap Sub'''.
generalize (apply_subst sigma t1) (apply_subst sigma (Var v)); clear.
revert q'; induction q as [ | i q]; simpl.
intros q' t s A H; injection H; clear H; intros; subst; trivial.
intros q' [v | f l] s.
intros; discriminate.
case (mem_bool beq_nat i (mu f)); [idtac | intros; discriminate].
simpl; case (nth_error l i); [idtac | intros; discriminate].
intro t; apply IHq.
(* 1/3 v is not active in (Term f k) *)
apply IH.
apply Vdp_step with (map (apply_subst sigma) k) (apply_subst sigma (Var v)).
left.
replace (Term f (map (apply_subst sigma) k)) with (apply_subst sigma (Term f k)); trivial.
apply instance; apply Vdp with t1; trivial.
rewrite active_is_active; exists q; split; trivial.
apply active_position_in_instanciated_term with (Var v) sigma; trivial.
revert Ap; generalize (apply_subst sigma t1); clear.
revert q'; induction q as [ | i q]; intro q'.
simpl; trivial.
intros [v | f l].
intros; discriminate.
simpl; case (mem_bool beq_nat i (mu f)); [idtac | intros; discriminate].
case (nth_error l i); [idtac | intros; discriminate].
intros t; simpl; apply IHq.
rewrite active_is_active; exists q'; split; trivial.
assert (Sub''' : subterm_at_pos (apply_subst sigma t1) q  = Some (apply_subst sigma (Var v))).
generalize (subterm_at_pos_apply_subst_apply_subst_subterm_at_pos t1 q sigma).
rewrite Sub''; trivial.
revert Ap Sub'''.
generalize (apply_subst sigma t1) (apply_subst sigma (Var v)); clear.
revert q'; induction q as [ | i q]; simpl.
intros q' t s A H; injection H; clear H; intros; subst; trivial.
intros q' [v | f l] s.
intros; discriminate.
case (mem_bool beq_nat i (mu f)); [idtac | intros; discriminate].
simpl; case (nth_error l i); [idtac | intros; discriminate].
intro t; apply IHq.
intros s s_in_h; apply Acc_h.
destruct s_in_h as [i [K1 K2]].
destruct (nth_error_ok_in _ _ K2) as [h1 [h2 [L K3]]]; subst; apply in_or_app; right; left; apply eq_refl.
apply refl_trans_clos_is_trans with (Term g h); trivial.
right; left; trivial.
assert (Dummy : active_subterm (Term g h) (apply_subst sigma t1)).
rewrite active_is_active.
exists (q ++ q'); split; trivial.
assumption.
(* 1/2 *)
apply (H'' (size (apply_subst sigma t1))).
apply le_n.
left.
(* 1/1 rewrite step NOT at the top *)
apply IHl with (actives f 0 l1); trivial.
apply filtering.
exists n; split; trivial.

intros s H'' H'''; apply IH; trivial.
inversion H'' as [f' l1' l2 s' K1 K2 | f' l1' l2 s' K1 K2]; subst.
apply Cdp_step with l2; [idtac | trivial].
apply refl_trans_clos_is_trans with l1.
assumption.
right; left; exists n; split; trivial.
apply Vdp_step with l2 s'; [idtac | trivial | trivial].
apply refl_trans_clos_is_trans with l1.
assumption.
right; left; exists n; split; trivial.

intros t H; apply Acc_t.
inversion H as [f' l1' l2 s' K1 K2 | f' l1' l2 s' K1 K2]; subst.
apply Cdp_step with l2; [idtac | trivial].
apply refl_trans_clos_is_trans with l1.
assumption.
right; left; exists n; split; trivial.
apply Vdp_step with l2 s'; [idtac | trivial | trivial].
apply refl_trans_clos_is_trans with l1.
assumption.
right; left; exists n; split; trivial.
Qed.

Lemma cdp_criterion :
  forall R, (forall x t, ~ (R t (Var x))) ->
  (forall s t, R s t -> forall x, In x (var_list s) -> In x (var_list t)) ->
  (forall f, {constructor R f} + {defined R f}) ->
  well_founded (cdp_step R) -> well_founded (C_step R).
Proof.
intros R HR RR CD Wf t; pattern t; apply term_rec3; clear t.
intro x; apply Context_Acc_var; trivial.
intros; apply cdp_criterion_local; trivial.
simpl; intros s As; apply H.
destruct As as [n [_ As]].
revert n As; clear; induction l as [ | t l]; intros [ | n] H.
discriminate.
discriminate.
injection H; intros; left; assumption.
right; apply IHl with n; trivial.
Qed.

(* http://zenon.dsic.upv.es/muterm *)
End Context_sensitive.

End Make.


(** * The type of the unital lBsystems

By Vladimir Voevodsky, started on Jan. 18, 2015 *)

Unset Automatic Introduction.

Require Export lBsystems.lB_non_unital.
Require Export lBsystems.lB0.

(** Condition dltT *)

Definition dltT_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.dltT_type ( @T_ax0 BB ) ( @T_ax1b BB ) ( @Tt_op BB ) ( dlt_ax1 dlt ) .

(** Condition dltS *)

Definition dltS_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.dltS_type ( @T_ax1b BB ) ( @S_ax0 BB ) ( @St_op BB ) ( dlt_ax1 dlt ) .

(** Condition SdltT *)

Definition SdltT_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.SdltT_type ( @T_ax0 BB ) ( @T_ax1a BB ) ( dlt_ax1 dlt ) ( @S_op BB ) .

(** Condition StdltTt *)

Definition StdltTt_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.StdltTt_type ( @T_ax0 BB ) ( @T_ax1a BB ) ( dlt_ax1 dlt ) ( @Tt_ax1 BB ) ( @St_op BB ) .

(** Condition dltSid *)

Definition dltSid_type { BB : lB_nu } ( dlt : dlt_layer ( @T_op BB ) ) :=
  dlt.dltSid_type ( @T_ax1b BB ) ( dlt_ax1 dlt ) ( @St_op BB ) .

(** Unital lBsystem *)

Definition lB :=
  total2 ( fun BB : lB_nu =>
             total2 ( fun dlt : dlt_layer ( @T_op BB ) =>
             dirprod
               ( dirprod
                   ( dirprod ( dltT_type dlt ) ( dltS_type dlt ) )
                   ( dirprod ( SdltT_type dlt ) ( StdltTt_type dlt ) ) )
               ( dltSid_type dlt ) ) ) .

Definition lB_to_lB_nu : lB -> lB_nu := pr1 .
Coercion lB_to_lB_nu : lB >-> lB_nu .

Definition lB_to_lB0 ( BB : lB ) : lB0system :=
  tpair ( fun BB : lB0system_non_unital => dlt_layer ( @T_op BB ) ) BB ( pr1 ( pr2 BB ) ) .
Coercion lB_to_lB0 : lB >-> lB0system .

Definition dltT { BB : lB } : dltT_type BB := pr1 ( pr1 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition dltS { BB : lB } : dltS_type BB := pr2 ( pr1 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition SdltT { BB : lB } : SdltT_type BB := pr1 ( pr2 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition StdltTt { BB : lB } : StdltTt_type BB := pr2 ( pr2 ( pr1 ( pr2 ( pr2 BB ) ) ) ) .

Definition dltSid { BB : lB } : dltSid_type BB := pr2 ( pr2 ( pr2 BB ) ) .

(* End of the file lB.v *)


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                    Fieska_Closed.v                                 *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.
Require Import IntensionalLib.Fieska_calculus.Fieska_Tactics.
Require Import IntensionalLib.Fieska_calculus.Fieska_reduction.
Require Import IntensionalLib.Fieska_calculus.Fieska_Normal.

(* closed terms *)

Fixpoint maxvar (M: Fieska) :=
match M with
| Ref i => S i
| Op o  => 0
| App M1 M2 => max (maxvar M1) (maxvar M2)
end.

Lemma maxvar_app : forall M N, maxvar (App M N) = max (maxvar M) (maxvar N).
Proof. split_all. Qed.

Definition decreases  (rank: Fieska  -> nat) (red:termred):=
forall M N, red M N -> rank M >= rank N.

Lemma decreases_multi_step:
forall rank red, decreases rank red -> decreases rank (multi_step red).
Proof.
red. intros rank red D M N R;  induction R; split_all.
assert(rank M >= rank N) by eapply2 D.
assert(rank N >= rank P) by eapply2 IHR.
omega.
Qed.

Lemma left_component_preserves_maxvar : forall M, compound M ->
maxvar(left_component M) <= maxvar M.
Proof.
split_all.
inversion H; split_all; try omega; eapply2 max_is_max.
Qed.

Lemma right_component_preserves_maxvar : forall M, compound M ->
maxvar(right_component M) <= maxvar M.
Proof. split_all. inversion H; split_all; try omega; eapply2 max_is_max.
Qed.

Ltac max_l :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= m) by eapply2 max_is_max;
cut(m >= p); split_all; try omega
end.
Ltac max_r :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= n) by eapply2 max_is_max;
cut(n >= p); split_all; try omega
end.

Lemma closed_implies_passive : forall M, maxvar M = 0 -> status M = Passive.
Proof.
match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H |
intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
]
end .
induction M; split_all; try omega.
generalize IHM1 H H0; clear IHM1 H H0; case M1; intros; try (auto; omega).
simpl in *. gen_case H0 (maxvar M2); noway.
(* 1 *)
rewrite IHM1. 2: omega. 2: max_out.
gen2_case H H0 f; split_all. case o; split_all. rewrite IHp. rewrite IHM2. auto. omega. max_out.
simpl in H; omega. max_out.
(* 1 *)
gen2_case H H0  f1; split_all. case o; split_all. rewrite IHp. auto. omega. max_out. max_out.
Qed.

Lemma decreases_maxvar_sf_seqred1: decreases maxvar sf_seqred1.
(*
forall M N, lamF_red1 M N -> maxvar N <= maxvar M.
*)
Proof.
cut(forall M N, sf_seqred1 M N -> maxvar N <= maxvar M).
split_all; red.

intros M N R; induction R; split_all; eauto; try (repeat (eapply2 max_monotonic); fail); try omega; repeat (eapply2 max_max2); try (max_r; fail); try (repeat max_l; fail).
(* 5 *)
assert(max(maxvar M) (maxvar N) >= maxvar N) by max_r.
assert(max (max (maxvar M) (maxvar N)) (maxvar P) >= (max (maxvar M) (maxvar N))) by max_l.
omega.
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
(* 2 *)
max_l. max_l. eapply2 left_component_preserves_maxvar.
max_l. max_l. eapply2 right_component_preserves_maxvar.
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l.
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l.
assert(maxvar M >= maxvar (left_component M)) by eapply2 left_component_preserves_maxvar. omega.
assert(max(maxvar M) (maxvar N) >= maxvar N) by max_r.
assert(maxvar N >= maxvar (left_component N)) by eapply2 left_component_preserves_maxvar. omega.
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l.
assert(maxvar M >= maxvar (right_component M)) by eapply2 right_component_preserves_maxvar. omega.
assert(max(maxvar M) (maxvar N) >= maxvar N) by max_r.
assert(maxvar N >= maxvar (right_component N)) by eapply2 right_component_preserves_maxvar. omega.
Qed.

Lemma decreases_maxvar_lamF_red : decreases maxvar sf_seqred.
Proof. eapply2 decreases_multi_step. eapply2 decreases_maxvar_sf_seqred1. Qed.

Definition program M := normal M /\ maxvar M = 0.

Lemma components_monotonic:
forall M N, program M -> program N ->
left_component M = left_component N ->
right_component M = right_component N -> M = N.
Proof.
induction M; unfold program; split_all; inversion H0.
(* 3 *)
gen4_case H1 H2 H3 H4 N; try discriminate.
subst. simpl in *. noway.
(* 2 *)
gen3_case H1 H2 H3 N. subst.
 unfold i_op in *. inversion H3.  simpl in *; discriminate.
inversion H7.
(* 1 *)
gen4_case H1 H2 H3 H4 N; inversion H0; auto. noway.
subst. inversion H. inversion H1; inversion H11.
subst. auto.
Qed.

Definition factorable M := (exists o, M = Op o) \/ compound M.

Theorem programs_are_factorable : forall M, program M  -> factorable M.
Proof.
match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H |
intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
]
end .
unfold program, factorable; induction M;  split_all; eauto.
inversion H0; noway.
right.
assert((exists o : operator, M1 = Op o) \/ compound M1). eapply2 IHM1.
omega.
split. inversion H0; inversion H1; auto.
assert(max(maxvar M1) (maxvar M2) >= maxvar M1) by max_l. omega.
inversion H0.
(* 1 *)
inversion H2; split_all; subst; eauto.
assert(status (App M1 M2) = Passive). eapply2 closed_implies_passive.
rewrite H4 in H8; discriminate.
Qed.


From mm Require Import util.
Set Implicit Arguments.

Module Type MAP.
  Parameter key : Type.
  Parameter key_eq_dec : forall (k1 k2 : key), {k1 = k2} + {k1 <> k2}.

  Parameter t : Type -> Type.

  Parameter empty : forall {V}, t V.
  Parameter get : forall V, key -> t V -> option V.
  Parameter set : forall V, key -> V -> t V -> t V.
  Parameter rem : forall V, key -> t V -> t V.
  Parameter fresh : forall V, t V -> key.

  Parameter ge : forall V k, get(V:=V) k empty = None.

  Parameter gr : forall V (m : t V) (k1 k2 : key),
      get k2 (rem k1 m) = if key_eq_dec k2 k1 then None else get k2 m.

  Parameter gss : forall V (k : key) (v : V) m, get k (set k v m) = Some v.
  Parameter gso : forall V (k1 k2 : key) (v : V) m, k1 <> k2 -> get k2 (set k1 v m) = get k2 m.

  Parameter gs : forall V (m : t V) (k1 k2 : key) (v : V),
      get k2 (set k1 v m) = if key_eq_dec k2 k1 then Some v else get k2 m.

  Parameter grs : forall V (k : key) (m : t V), get k (rem k m) = None.
  Parameter gro : forall V (k1 k2 : key) (m : t V), k1 <> k2 -> get k2 (rem k1 m) = get k2 m.

  Parameter gf : forall V (m : t V), get (fresh m) m = None.

  Parameter ext : forall V (m1 m2 : t V), (forall k, get k m1 = get k m2) -> m1 = m2.
End MAP.

Module Type OrderedType.
  Parameter t : Type.
  Parameter lt : t -> t -> Prop.
  Parameter irrefl : forall x, ~ lt x x.
  Parameter trans : forall x y z, lt x y -> lt y z -> lt x z.
  Parameter trich_dec : forall x y, {lt x y} + {x = y} + {lt y x}.
  Parameter eq_dec : forall (k1 k2 : t), {k1 = k2} + {k1 <> k2}.

  Parameter init : t.

  Parameter bigger : t -> t.
  Parameter bigger_lt : forall x, lt x (bigger x).

  Parameter lt_irrelevant : forall x y (pf1 pf2 : lt x y), pf1 = pf2.
End OrderedType.

Module NatOrderedType : OrderedType with Definition t := nat.
  Definition t := nat.
  Definition lt := Peano.lt.

  Definition irrefl : forall x, ~ lt x x := Nat.lt_irrefl.
  Definition trans : forall x y z, lt x y -> lt y z -> lt x z := Nat.lt_trans.
  Definition trich_dec : forall x y, {lt x y} + {x = y} + {lt y x} := lt_eq_lt_dec.
  Definition eq_dec : forall (k1 k2 : t), {k1 = k2} + {k1 <> k2} := Nat.eq_dec.

  Definition init := 0.

  Definition bigger := S.
  Definition bigger_lt : forall x, lt x (bigger x) := Nat.lt_succ_diag_r.

  Fixpoint le_irrelevant x y (pf1 : Peano.le x y) : forall pf2 : Peano.le x y, pf1 = pf2.
    refine match pf1 with
           | le_n _ => _
           | le_S _ _ _ => _
           end; clear pf1.
    - clear le_irrelevant.
      assert (forall (y : nat) (pf : x <= y) (e : y = x),
                 le_n x = eq_rect y (fun z : nat => x <= z) pf x e).
      {
        clear y.
        intros y pf.
        destruct pf; intros e.
        - now rewrite Eqdep_dec.UIP_refl_nat with (x := e).
        - exfalso. subst. lia.
      }
      intros pf2.
      apply (H x pf2 eq_refl).
    - intros pf2.
      generalize (fun l2 => le_irrelevant _ _ l l2).
      revert l.
      refine (match pf2 as pf20 in _ <= n0
                   return match n0 with
                          | 0 => fun _ => True
                          | S n1 => fun pf21 => forall (l : x <= n1), (forall l2 : x <= n1, l = l2) ->
                                                             le_S x n1 l = pf21
                          end pf20
             with
             | le_n _ => _
             | le_S _ _ l2 => _
             end).
      + destruct x.
        * exact I.
        * intros l1 IH. exfalso. lia.
      + intros l1 IH.
        f_equal.
        apply IH.
  Defined.

  Definition lt_irrelevant : forall x y (pf1 pf2 : lt x y), pf1 = pf2.
    intros.
    apply le_irrelevant.
  Defined.
  Print Assumptions lt_irrelevant.
End NatOrderedType.

Module SortedMap (K : OrderedType) : MAP with Definition key := K.t.
  Definition key := K.t.

  Definition key_eq_dec := K.eq_dec.

  Module Type INTERNAL.
    Parameter t : Type -> Type.
    Parameter wf : forall V, t V -> Prop.

    Parameter empty : forall {V}, t V.
    Parameter get : forall V, key -> t V -> option V.
    Parameter set : forall V, key -> V -> t V -> t V.
    Parameter rem : forall V, key -> t V -> t V.
    Parameter fresh : forall V, t V -> key.

    Parameter wf_empty :
      forall V,
        wf empty(V:=V).

    Parameter wf_set :
      forall V k (v : V) m,
        wf m ->
        wf (set k v m).

    Parameter wf_rem :
      forall V k (m : t V),
        wf m ->
        wf (rem k m).

    Parameter wf_irrelevant :
      forall V (m : t V) (pf1 pf2 : wf m),
        pf1 = pf2.

    Parameter ge : forall V k, get(V:=V) k empty = None.

    Parameter gs : forall V (m : t V) (k1 k2 : key) (v : V),
        wf m ->
        get k2 (set k1 v m) = if K.eq_dec k2 k1 then Some v else get k2 m.

    Parameter gss : forall V (k : key) (v : V) m, wf m -> get k (set k v m) = Some v.
    Parameter gso : forall V (k1 k2 : key) (v : V) m,
        wf m -> k1 <> k2 -> get k2 (set k1 v m) = get k2 m.

    Parameter gr : forall V (m : t V) (k1 k2 : key),
        wf m ->
        get k2 (rem k1 m) = if K.eq_dec k2 k1 then None else get k2 m.

    Parameter grs : forall V (k : key) (m : t V), wf m -> get k (rem k m) = None.
    Parameter gro : forall V (k1 k2 : key) (m : t V),
        wf m -> k1 <> k2 -> get k2 (rem k1 m) = get k2 m.

    Parameter gf : forall V (m : t V), wf m -> get (fresh m) m = None.

    Parameter ext : forall V (m1 m2 : t V),
        wf m1 -> wf m2 -> (forall k, get k m1 = get k m2) -> m1 = m2.
  End INTERNAL.

  Module Internal : INTERNAL.
    Definition t V := list (key * V).

    Fixpoint wf_aux V (k : key) (m : t V) : Prop :=
      match m with
      | [] => True
      | (k1,_) :: m =>
        K.lt k k1 /\ wf_aux k1 m
      end.
    Definition wf V (m : t V) : Prop :=
      match m with
      | [] => True
      | (k1, _) :: m =>
        wf_aux k1 m
      end.

    Lemma wf_aux_irrelevant :
      forall V (m : t V) k (pf1 pf2 : wf_aux k m),
        pf1 = pf2.
    Proof.
      induction m as [|[k1 v1] m]; simpl; intros k [] [].
      - reflexivity.
      - f_equal.
        + apply K.lt_irrelevant.
        + apply IHm.
    Qed.

    Lemma wf_irrelevant :
      forall V (m : t V) (pf1 pf2 : wf m),
        pf1 = pf2.
    Proof.
      unfold wf.
      intros V [|[k1 v1] m].
      - intros [][]. reflexivity.
      - apply wf_aux_irrelevant.
    Qed.

    Definition wf' V (m : t V) : Prop :=
      forall i j k1 k2 v1 v2,
        i < j ->
        nth_error m i = Some (k1, v1) ->
        nth_error m j = Some (k2, v2) ->
        K.lt k1 k2.

    Definition empty {V} : t V := [].

    Fixpoint get V (k : key) (m : t V) : option V :=
      match m with
      | [] => None
      | (k1, v1) :: m =>
        if K.eq_dec k k1 then Some v1
        else get k m
      end.

    Fixpoint set V (k : key) (v : V) (m : t V) : t V :=
      match m with
      | [] => [(k, v)]
      | (k1, v1) :: m =>
        match K.trich_dec k k1 with
        | inleft (left LT) => (k, v) :: (k1, v1) :: m
        | inleft (right EQ) => (k, v) :: m
        | inright GT => (k1, v1) :: set k v m
        end
      end.

    Fixpoint rem V (k : key) (m : t V) : t V :=
      match m with
      | [] => []
      | (k1, v1) :: m =>
        if K.eq_dec k k1 then m
        else (k1, v1) :: rem k m
      end.

    Fixpoint max_key V (acc : key) (m : t V) : key :=
      match m with
      | [] => acc
      | (k, _) :: m =>
        max_key (if K.trich_dec k acc then acc else k) m
      end.

    Definition fresh V (m : t V) : key :=
      match m with
      | [] => K.init
      | (k, _) :: m => K.bigger (max_key k m)
      end.

    Lemma wf_empty :
      forall V,
        wf empty(V:=V).
    Proof.
      unfold wf, empty.
      intros.
      exact I.
    Qed.

    Lemma wf_aux_set :
      forall V m k (v : V) k0,
        wf_aux k0 m ->
        K.lt k0 k ->
        wf_aux k0 (set k v m).
    Proof.
      induction m as [|[]]; simpl; intros k1 v1 acc.
      + intuition.
      + intros [LT WF] GT.
        destruct (K.trich_dec k1 k) as [[|]|]; simpl.
        * intuition.
        * subst. intuition.
        * intuition.
    Qed.

    Lemma wf_set :
      forall V k (v : V) m,
        wf m ->
        wf (set k v m).
    Proof.
      unfold wf.
      intros V k v m.
      destruct m as [|[]]; simpl; auto.
      intros WF.
      destruct (K.trich_dec k k0) as [[LT|EQ]|GT]; simpl.
      - auto.
      - subst. auto.
      - auto using wf_aux_set.
    Qed.

    Lemma wf_aux_lt :
      forall V (m : t V) k1 k2,
        K.lt k1 k2 ->
        wf_aux k2 m ->
        wf_aux k1 m.
    Proof.
      induction m as [|[k v] m]; simpl; auto; intros k1 k2 LT12 [LT2 WF].
      split; eauto using K.trans.
    Qed.

    Lemma wf_aux_rem :
      forall V (m : t V) k k0,
        wf_aux k0 m ->
        wf_aux k0 (rem k m).
    Proof.
      induction m as [|[k1 v1] m]; simpl; intros k k0.
      - auto.
      - intros [LT WF].
        destruct (K.eq_dec k k1).
        + subst. eauto using wf_aux_lt.
        + simpl. auto.
    Qed.

    Lemma wf_rem :
      forall V k (m : t V),
        wf m ->
        wf (rem k m).
    Proof.
      unfold wf.
      intros V k m.
      destruct m as [|[]]; simpl; auto.
      intros WF.
      destruct (K.eq_dec k k0).
      - subst. destruct m as [|[]].
        + exact I.
        + simpl in WF. intuition.
      - auto using wf_aux_rem.
    Qed.

    Lemma ge : forall V k, get(V:=V) k empty = None.
    Proof.
      intros.
      reflexivity.
    Qed.

    Lemma key_eq_dec_yes :
      forall A k1 k2 (x y : A),
        k1 = k2 ->
        (if K.eq_dec k1 k2 then x else y) = x.
    Proof.
      intros.
      destruct K.eq_dec; congruence.
    Qed.

    Lemma key_eq_dec_no :
      forall A k1 k2 (x y : A),
        k1 <> k2 ->
        (if K.eq_dec k1 k2 then x else y) = y.
    Proof.
      intros.
      destruct K.eq_dec; congruence.
    Qed.

    Lemma lt_neq :
      forall k1 k2,
        K.lt k1 k2 ->
        k1 <> k2.
    Proof.
      intros k1 k2 H E.
      subst.
      eapply K.irrefl; eauto.
    Qed.

    Lemma gs_aux : forall V (m : t V) (k1 k2 k' : key) (v : V),
        wf_aux k' m ->
        get k2 (set k1 v m) = if K.eq_dec k2 k1 then Some v else get k2 m.
    Proof.
      induction m as [|[k3 v3] m]; simpl; intros k1 k2 k' v.
      - auto.
      - intros [LT WF].
        destruct K.trich_dec as [[|]|]; simpl.
        + reflexivity.
        + subst.
          now destruct K.eq_dec.
        + apply lt_neq in LT.
          apply lt_neq in l.
          erewrite IHm by eassumption.
          repeat destruct K.eq_dec; congruence.
    Qed.

    Lemma gs : forall V (m : t V) (k1 k2 : key) (v : V),
        wf m ->
        get k2 (set k1 v m) = if K.eq_dec k2 k1 then Some v else get k2 m.
    Proof.
      intros V m k1 k2 v.
      destruct m as [|[]]; simpl.
      - reflexivity.
      - intros WF.
        destruct K.trich_dec as [[|]|]; simpl.
        + reflexivity.
        + subst.
          now destruct K.eq_dec.
        + apply lt_neq in l.
          erewrite gs_aux by eassumption.
          repeat destruct K.eq_dec; try congruence.
    Qed.

    Lemma gss : forall V (k : key) (v : V) (m : t V), wf m -> get k (set k v m) = Some v.
    Proof.
      intros V k v m WF.
      now rewrite gs, key_eq_dec_yes.
    Qed.

    Lemma gso : forall V (k1 k2 : key) (v : V) (m : t V),
        wf m ->
        k1 <> k2 ->
        get k2 (set k1 v m) = get k2 m.
    Proof.
      intros V k1 k2 v m WF NE.
      now rewrite gs, key_eq_dec_no; auto using not_eq_sym.
    Qed.

    Lemma get_wf_aux_lt_None :
      forall V (m : t V) (k1 k2 : key),
        K.lt k1 k2 ->
        wf_aux k2 m ->
        get k1 m = None.
    Proof.
      induction m as [|[k3 v3] m]; simpl; intros k1 k2.
      - reflexivity.
      - intros LT12 [LT23 WF].
        rewrite key_eq_dec_no; eauto using K.trans, lt_neq.
    Qed.

    Lemma get_wf_aux_None :
      forall V (m : t V) k,
        wf_aux k m ->
        get k m = None.
    Proof.
      destruct m as [|[k1 v1] m]; simpl.
      - reflexivity.
      - intros k [LT WF].
        rewrite key_eq_dec_no by auto using lt_neq.
        now eauto using get_wf_aux_lt_None.
    Qed.

    Lemma gr_aux : forall V (m : t V) (k1 k2 k' : key),
        wf_aux k' m ->
        get k2 (rem k1 m) = if K.eq_dec k2 k1 then None else get k2 m.
    Proof.
      induction m as [|[k3 v3] m]; simpl; intros k1 k2 k'.
      - destruct K.eq_dec; auto.
      - intros [LT WF].
        destruct K.eq_dec; simpl.
        + subst.
          destruct K.eq_dec.
          * subst.
            auto using get_wf_aux_None.
          * auto.
        + erewrite IHm by eassumption.
          repeat destruct K.eq_dec; congruence.
    Qed.

    Lemma gr : forall V (m : t V) (k1 k2 : key),
        wf m ->
        get k2 (rem k1 m) = if K.eq_dec k2 k1 then None else get k2 m.
    Proof.
      destruct m as [|[k3 v3] m]; intros k1 k2; simpl.
      - destruct K.eq_dec; reflexivity.
      - intros WF.
        destruct K.eq_dec; simpl.
        + subst.
          destruct K.eq_dec.
          * subst.
            auto using get_wf_aux_None.
          * auto.
        + erewrite gr_aux by eassumption.
          repeat destruct K.eq_dec; congruence.
    Qed.

    Lemma grs : forall V (k : key) (m : t V), wf m -> get k (rem k m) = None.
    Proof.
      intros.
      now rewrite gr, key_eq_dec_yes.
    Qed.

    Lemma gro : forall V (k1 k2 : key) (m : t V),
        wf m ->
        k1 <> k2 ->
        get k2 (rem k1 m) = get k2 m.
    Proof.
      intros.
      rewrite gr, key_eq_dec_no; auto using not_eq_sym.
    Qed.

    Lemma lt_max_key_inv :
      forall V (m : t V) k1 k2,
        K.lt (max_key k1 m) k2 ->
        K.lt k1 k2.
    Proof.
      induction m as [|[k3 v3] m]; simpl; intros k1 k2 LT.
      - auto.
      - destruct K.trich_dec as [[|]|]; eauto using K.trans.
    Qed.

    Lemma get_max_key_None :
      forall V (m : t V) k1 k2,
        K.lt (max_key k1 m) k2 ->
        get k2 m = None.
    Proof.
      induction m as [|[k3 v3] m]; simpl; intros k1 k2 LT.
      - reflexivity.
      - rewrite key_eq_dec_no
          by (apply not_eq_sym; apply lt_neq;
              destruct K.trich_dec as [[|]|]; subst; eauto using K.trans, lt_max_key_inv).
        eauto.
    Qed.

    Definition le (k1 k2 : key) : Prop :=
      K.lt k1 k2 \/ k1 = k2.

    Lemma le_lt_trans :
      forall k1 k2 k3,
        le k1 k2 ->
        K.lt k2 k3 ->
        K.lt k1 k3.
    Proof.
      unfold le.
      intros k1 k2 k3 LT12 LT23.
      intuition; subst; eauto using K.trans.
    Qed.

    Lemma lt_le_trans :
      forall k1 k2 k3,
        K.lt k1 k2 ->
        le k2 k3 ->
        K.lt k1 k3.
    Proof.
      unfold le.
      intros k1 k2 k3 LT12 LT23.
      intuition; subst; eauto using K.trans.
    Qed.

    Lemma max_key_le_acc :
      forall V (m : t V) k,
        le k (max_key k m).
    Proof.
      induction m as [|[k1 v1] m]; simpl; intros k.
      - right. reflexivity.
      - destruct K.trich_dec.
        + auto.
        + left.
          eauto using lt_le_trans.
    Qed.

    Lemma gf : forall V (m : t V), wf m -> get (fresh m) m = None.
    Proof.
      unfold wf, fresh.
      destruct m as [|[k1 v1] m].
      - reflexivity.
      - intros WF.
        simpl.
        rewrite key_eq_dec_no
        by (apply not_eq_sym;
            apply lt_neq;
            eapply le_lt_trans; [|apply K.bigger_lt];
            apply max_key_le_acc).
        now eauto using get_max_key_None, K.bigger_lt.
    Qed.

    Lemma ext_aux : forall V (m1 m2 : t V) k,
        wf_aux k m1 ->
        wf_aux k m2 ->
        (forall k, get k m1 = get k m2) ->
        m1 = m2.
    Proof.
      induction m1 as [|[k1 v1] m1]; destruct m2 as [|[k2 v2] m2]; simpl; intros k.
      - reflexivity.
      - intros _ _ E.
        specialize (E k2).
        rewrite key_eq_dec_yes in E by reflexivity.
        discriminate.
      - intros _ _ E.
        specialize (E k1).
        rewrite key_eq_dec_yes in E by reflexivity.
        discriminate.
      - intros [LT1 WF1] [LT2 WF2] E.
        destruct (K.trich_dec k1 k2) as [[|]|].
        + pose proof E k1.
          rewrite key_eq_dec_yes in H by reflexivity.
          rewrite key_eq_dec_no in H by auto using lt_neq.
          erewrite get_wf_aux_lt_None in H by eauto.
          discriminate.
        + subst k2.
          assert (v1 = v2).
          {
            specialize (E k1).
            rewrite !key_eq_dec_yes in E by auto.
            congruence.
          }
          subst v2.
          f_equal.
          eapply IHm1; eauto.
          intros k0.
          specialize (E k0).
          destruct K.eq_dec.
          * subst k0. clear E.
            now rewrite !get_wf_aux_None by assumption.
          * auto.
        + pose proof E k2.
          rewrite key_eq_dec_yes with (k2 := k2) in H by reflexivity.
          rewrite key_eq_dec_no in H by auto using lt_neq.
          erewrite get_wf_aux_lt_None in H by eauto.
          discriminate.
    Qed.

    Lemma ext : forall V (m1 m2 : t V),
        wf m1 ->
        wf m2 ->
        (forall k, get k m1 = get k m2) ->
        m1 = m2.
    Proof.
      intros V m1 m2 WF1 WF2 E.
      destruct m1 as [|[k1 v1] m1], m2 as [|[k2 v2]].
      - auto.
      - specialize (E k2). simpl in *. rewrite key_eq_dec_yes in * by auto. discriminate.
      - specialize (E k1). simpl in *. rewrite key_eq_dec_yes in * by auto. discriminate.
      - unfold wf in *.
        simpl in *.
        destruct (K.trich_dec k1 k2) as [[|]|].
        + pose proof E k1.
          rewrite key_eq_dec_yes in H by reflexivity.
          rewrite key_eq_dec_no in H by auto using lt_neq.
          erewrite get_wf_aux_lt_None in H by eauto.
          discriminate.
        + subst k2.
          pose proof (E k1).
          rewrite !key_eq_dec_yes in * by reflexivity.
          invc H.
          f_equal.
          eapply ext_aux; eauto.
          intros k.
          specialize (E k).
          destruct K.eq_dec.
          * subst k. clear E.
            now rewrite !get_wf_aux_None by assumption.
          * auto.
        + pose proof E k2.
          rewrite key_eq_dec_yes with (k2 := k2) in H by reflexivity.
          rewrite key_eq_dec_no in H by auto using lt_neq, not_eq_sym.
          erewrite get_wf_aux_lt_None in H by eauto.
          discriminate.
    Qed.
  End Internal.

  Definition t V := { m : Internal.t V | Internal.wf m }.

  Definition empty {V} : t V :=
    exist _ Internal.empty (Internal.wf_empty _).

  Definition get V (k : key) (m : t V) : option V :=
    let (i, _) := m in
    Internal.get k i.

  Definition set V (k : key) (v : V) (m : t V) : t V :=
    let (i, pf) := m in
    exist _ (Internal.set k v i) (Internal.wf_set k v pf).

  Definition rem V (k : key) (m : t V) : t V :=
    let (i, pf) := m in
    exist _ (Internal.rem k i) (Internal.wf_rem k pf).

  Definition fresh V (m : t V) : key :=
    let (i, _) := m in
    Internal.fresh i.

  Lemma ge : forall V k, get(V:=V) k empty = None.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V k.
    apply Internal.ge.
  Qed.

  Lemma gs : forall V (m : t V) (k1 k2 : key) (v : V),
      get k2 (set k1 v m) = if K.eq_dec k2 k1 then Some v else get k2 m.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V [i pf] k1 k2 v.
    now apply Internal.gs.
  Qed.

  Lemma gss : forall V (k : key) (v : V) m, get k (set k v m) = Some v.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V k v [i pf].
    now apply Internal.gss.
  Qed.

  Lemma gso : forall V (k1 k2 : key) (v : V) m, k1 <> k2 -> get k2 (set k1 v m) = get k2 m.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V k1 k2 v [i pf] NE.
    now apply Internal.gso.
  Qed.

  Lemma gr : forall V (m : t V) (k1 k2 : key),
      get k2 (rem k1 m) = if K.eq_dec k2 k1 then None else get k2 m.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V [i pf] k1 k2.
    now apply Internal.gr.
  Qed.

  Lemma grs : forall V (k : key) (m : t V), get k (rem k m) = None.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V k [i pf].
    now apply Internal.grs.
  Qed.

  Lemma gro : forall V (k1 k2 : key) (m : t V), k1 <> k2 -> get k2 (rem k1 m) = get k2 m.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V k1 k2 [i pf] NE.
    now apply Internal.gro.
  Qed.

  Lemma gf : forall V (m : t V), get (fresh m) m = None.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V [i pf].
    now apply Internal.gf.
  Qed.

  Lemma ext : forall V (m1 m2 : t V), (forall k, get k m1 = get k m2) -> m1 = m2.
  Proof.
    unfold empty, get, set, rem, fresh.
    intros V [i1 pf1] [i2 pf2] Hext.
    assert (i1 = i2) by now apply Internal.ext.
    subst.
    f_equal.
    apply Internal.wf_irrelevant.
  Qed.
End SortedMap.

Module NatMap := SortedMap NatOrderedType.