From Equations Require Import Equations.
Require Import Lia.
Set Equations Transparent.
Equations evenodd (b : bool) (n : nat) : Prop by wf n lt :=
  evenodd true 0 := True;
  evenodd true (S n) := evenodd false n;
  evenodd false 0 := False;
  evenodd false (S n) := evenodd true n.

Eval vm_compute in evenodd true 4.

Require Import List Wellfounded.
Set Asymmetric Patterns.

Polymorphic Inductive ty : (A : Type) (P : AType), Type :=
| ty0 : ty nat (fun _nat)
| ty1 : ty (list nat) (fun _bool).

Polymorphic Derive Signature NoConfusion for ty.

Notation "{ x : A & y }" := (@sigma A (fun x : Ay)%type) (x at level 99) : type_scope.
Notation "{ x & y }" := (@sigma _ (fun x : _y)%type) (x at level 99) : type_scope.

Notation "&( x , .. , y , z )" :=
  (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
    (right associativity, at level 4,
     format "&( x , .. , y , z )").

Polymorphic Equations rel : {A &{ P &{ _ : A & ty A P }}} → {A & { P & {_ : A & ty A P}}} → Prop :=
  rel &(A, P, a, ta) &(B, Q, b, tb) ⇒
  match ta in ty A P, tb in ty B Q return ABProp with
  | ty0, ty0lt
  | ty1, ty1fun l l'length l < length l'
  | ty0, ty1fun n ln < length l
  | ty1, ty0fun l nlength l < n
  end a b.

Polymorphic Instance: WellFounded rel.
Proof. Admitted.
Require Import Arith.

Polymorphic Definition pack {A} {P} (x : A) (t : ty A P) :=
  (&(A, P, x, t)) : {A & {P & {_ : A & ty A P}}}.

Polymorphic Equations double_fn {A} {P} (t : ty A P) (x : A) : P x by wf (pack x t) rel :=
  double_fn ty0 n := n + 0;
  double_fn ty1 nil := true;
  double_fn ty1 (x :: xs) := 0 <? length xs + double_fn ty0 (length xs).
Next Obligation. Transparent rel. unfold rel. simp rel. cbn. auto with arith. Qed.

Definition fn0 := double_fn ty0.
Definition fn1 := double_fn ty1.

Lemma fn0_unfold n : fn0 n = n + 0.
Proof.
  unfold fn0. simp double_fn.
Qed.

Lemma fn1_unfold l : fn1 l = match l with niltrue | x :: xs ⇒ 0 <? length xs + fn0 (length xs) end.
Proof.
  unfold fn1; simp double_fn. destruct l. simp double_fn. simp double_fn. now rewrite fn0_unfold.
Qed.

(* Polymorphic Equations double_fn' {A} {P} (t : ty A P) (x : A) : P x by wf (pack x t) rel := *)
(*   double_fn' ty0 n := n + 0; *)
(*   double_fn' ty1 l := aux l _ *)
(*     where aux l' (H : length l' <= length l)  : _ by struct l' := *)
(*     aux nil _ := true; *)
(*     aux (x :: xs) H := 0 <? length xs + double_fn' ty0 (length xs) + if aux xs _ then 0 else 1. *)
(* Obligation Tactic := idtac. *)
(* Next Obligation. intros. cbn. auto with arith. Defined. *)
(* Next Obligation. intros. cbn. auto with arith. Defined. *)
(* Next Obligation. auto with arith. Defined. *)

(* Definition fn0' := Eval compute in double_fn' ty0. *)
(* Definition fn1' := double_fn' ty1. *)

(* Lemma fn0'_unfold n : fn0' n = n + 0. *)
(* Proof. *)
(*   unfold fn0'; simp double_fn'. *)
(* Qed. *)

(* Lemma fn1'_unfold l : fn1' l = match l with nil => true | x :: xs => 0 <? length xs + fn0' (length xs) end. *)
(* Proof. *)
(*   unfold fn1'; simp double_fn'. destruct l. simp double_fn. simp double_fn'. *)
(*   destruct double_fn'_unfold_obligation_1. rewrite fn0'_unfold.  auto. *)
(*   rewrite fn0'_unfold. *)
(* Admitted. *)

Require Import Equations.Subterm.

Equations ack (m n : nat) : nat by wf (m, n) (lexprod _ _ lt lt) :=
  ack 0 0 := 1;
  ack 0 (S n) := S (S n);
  ack (S m) 0 := ack m 1;
  ack (S m) (S n) := ack m (ack (S m) n).

Module Abc.

Inductive abc : Set :=
| abc0
  | A (a : abc)
  | B (b : abc)
  | C (c : abc).

(* Inductive sct0_rel : abc -> abc -> Prop := *)
(* | sct0_bc x : sct0_rel (B (C x)) (A x) *)
(* | sct0_a x : sct0_rel x (A x) *)
(* | sct0_b x : sct0_rel x (B x) *)
(* | sct0_c x : sct0_rel x (C x). *)
(* Hint Constructors sct0_rel : rec_decision. *)
(* Instance: WellFounded sct0_rel. *)
(* Admitted. *)

Fixpoint measure_abc (x : abc) :=
  match x with
  | abc0 ⇒ 0
  | A x ⇒ 3 + measure_abc x
  | B xS (measure_abc x)
  | C xS (measure_abc x)
  end.

Equations sct0 (x : abc) : nat by wf (measure_abc x) lt :=
  sct0 abc0 := 0;
  sct0 (A x) := sct0 (B (C x)) + sct0 x;
  sct0 (B x) := sct0 x;
  sct0 (C x) := sct0 x.
Solve Obligations with program_simpl; lia.

Fixpoint measure_abc' (x : abc) :=
  match x with
  | abc0 ⇒ 0
  | A xS (measure_abc' x)
  | B xS (measure_abc' x)
  | C xS (measure_abc' x)
  end.

Equations f1g1 (x : abc) : unit by wf (measure_abc' x) lt :=
  f1g1 (A (A x)) := f1 x _
    where f1 x' (H : measure_abc' x' < measure_abc' (A x)) : _ := { f1 x _ := f1g1 (A x) };
  f1g1 _ := tt.
Next Obligation. auto with arith. Defined.

Equations f1g1' (x : abc) : unit by wf (measure_abc' x) lt :=
  f1g1' (A (A x)) := f1g1' (A x);
  f1g1' _ := tt.
End Abc.

Require Import Telescopes.

Module sct2.

  (* Definition signature := { t : tele & tele_type t }. *)

  (* Definition params (f : signature) := f.(pr1). *)
  (* Definition param_type (f : signature) := tele_sigma f.(pr1). *)

  (* Equations nevec (A : Type) (n : nat) : Type := *)
  (*   nevec A 0 := A; *)
  (*   nevec A (S n) := A * nevec A n. *)

  (* Definition signatures := @nevec signature. *)

  (* Polymorphic Equations fns {n} (t : signatures n) :  (x : A) : P x by wf (pack t x) rel' := *)
  (*   fg ty0 (nil, x) := x; *)
  (*   fg ty0 (cons y ys, x) := 1 :: fg ty1 (ys, x, (cons y ys)); *)
  (*   fg ty1 (a, b, c) := 2 :: fg ty0 (a, app b c). *)

  Polymorphic Inductive ty : (A : Set) (P : ASet), Set :=
  | ty0 : ty (list nat × list nat)%type (fun _list nat)
  | ty1 : ty (list nat × list nat × list nat) (fun _list nat).
  Polymorphic Derive Signature NoConfusion for ty.

  Polymorphic Definition type := {A &{ P &{ _ : ty A P & A }}}.

  (* Equations measure (x : type) : nat := *)
  (*   measure &(_, _, ty0, (l, l')) := length l; *)
  (*   measure &(_, _, ty1, (l, l', l'')) := length l. *)

  Polymorphic Equations rel' : {A &{ P &{ _ : ty A P & A }}} → {A & { P & {_ : ty A P & A}}} → Prop :=
  rel' &(A', P, ta, a) &(_, Q, tb, b) ⇒
  match ta in ty A P, tb in ty B Q return ABProp with
  | ty0, ty0fun '(l0, l1) '(l0', l1') ⇒ (* length l0 < length l0' *) False
  | ty1, ty1fun '(l0, n, l1) '(l0', n', l1') ⇒ (* length l0 < length l0' *) False
  | ty0, ty1fun '(l0, l1) '(l0', l1', l2') ⇒ length l0length l0'
  | ty1, ty0fun '(l0, l1, l2) '(l0', l1') ⇒ length l0 < length l0'
  end a b.

  (* rel' is not well-founded, we should rather have a relation between calls
     f -> g.
   *)


  Transparent rel'.
  Polymorphic Instance: WellFounded rel'.
  Proof. Admitted.
    (* red. intros a. dependent elimination a as &(A, P, ta, a). *)
    (* simpl in *. constructor. intros y. *)
    (* dependent elimination y as &(A', P', tb, a'); *)
    (* simpl in *. *)
    (* intros rel'. unfold sct2.rel' in rel'. destruct tb. destruct ta; simpl in *. *)
    (* simpl in *. destruct a, a'. simpl in *. destruct rel'. *)
    (* destruct a, a'. destruct p. *)
    (* constructor. intros (A'&P'&t'&a'). *)

  Polymorphic Definition pack {A} {P} (t : ty A P) (x : A) :=
  (&(A, P, t, x)) : {A & {P & {_ : ty A P & A}}}.

  Polymorphic Equations fg {A} {P} (t : ty A P) (x : A) : P x by wf (pack t x) rel' :=
    fg ty0 (nil, x) := x;
    fg ty0 (cons y ys, x) := 1 :: fg ty1 (ys, x, (cons y ys));
    fg ty1 (a, b, c) := 2 :: fg ty0 (a, app b c).

  (* TODO find order! *)
  Next Obligation. unfold rel'. cbn. auto with arith. Qed.
  Next Obligation. unfold rel'. cbn. reflexivity. Qed.

  Inductive fg_graph : typetypeProp :=
  | fg_dom_equation_2 : (n : nat) (l l0 : list nat),
      fg_graph &((list nat × list nat × list nat)%type,
              (fun _ : list nat × list nat × list natlist nat), ty1, (l, l0, n :: l))
             &((list nat × list nat)%type, (fun _ : list nat × list natlist nat), ty0,
              (n :: l, l0))
  | fg_dom_equation_3 : l0 l1 l : list nat,
                        fg_graph &((list nat × list nat)%type, _, ty0, (l0, l1 ++ l))
                        &((list nat × list nat × list nat)%type, _, ty1, (l0, l1, l)).

  Polymorphic Axiom ap_f_inv : (A B : Type) (f : AB) (x y : A), f x = f yx = y.

  Polymorphic Lemma simpl_f A B (f : AB) (x y : A) (P : x = yType) :
    ( e : f x = f y, P (ap_f_inv _ _ f x y e)) →
    ( e, P e).
  Admitted.
  Derive Signature for fg_graph.
  Lemma wf_fg_graph : WellFounded fg_graph.
  Proof.
    split; intros. depind H.
    constructor. intros.
    depelim H.

    revert H.
    pose (simpl_f type {prot : { idx : { A : Set & A_} & ty idx.(pr1) idx.(pr2)} & prot.(pr1).(pr1)}
     (fun '&(A, P, t, x) ⇒ &(&(&(A, P), t), x) : {prot : { idx : { A : Set & A_} &
                                                                                 ty idx.(pr1) idx.(pr2)} & prot.(pr1).(pr1)})).
    simpl in p.

    refine (p _ _ _ _); clear p.
    refine (eq_simplification_sigma1_dep _ _ _ _ _).
    simpl.
    simplify ×.
    revert H.
    pose (simpl_f type {prot : { idx : { A : Set & A_} & ty idx.(pr1) idx.(pr2)} & prot.(pr1).(pr1)}
     (fun '&(A, P, t, x) ⇒ &(&(&(A, P), t), x) : {prot : { idx : { A : Set & A_} &
                                                                                 ty idx.(pr1) idx.(pr2)} & prot.(pr1).(pr1)})).
    simpl in p.

    refine (p _ _ _ _); clear p.
    refine (eq_simplification_sigma1_dep _ _ _ _ _).
    simpl.
    simplify ×.
    Show Proof.

    pose (apply_noConfusion).

  Inductive fg_graph' : (bool × nat) → (bool × nat) → Prop :=
  | decrf n : fg_graph' (false, n) (true, S n)
  | decrg n : fg_graph' (true, n) (false, n).

  Inductive fg_graph_equiv : (bool × nat) → (bool × nat) → Prop :=
  | decrfg n : fg_graph_equiv (true, n) (true, S n)
  | decrgf n : fg_graph_equiv (false, n) (false, S n).
  Require Import Relations.
  Lemma wf_fg_graph f x y : (* clos_trans _ *) fg_graph' (f, x) (f, y) ↔ fg_graph_equiv (f, x) (f, y).
  Proof.
    intros. split; intros. depind H. depelim H.
    intro. destruct a as (A&P&t&a).
    destruct t. constructor. intros.
    destruct a. destruct l. depelim H.
    revert H. admit.
    admit.
    depelim H.

  Inductive fg_dom : (A : Set) (P : ASet), ty A PAProp :=
  | fg_dom_equation_1 :
       l0 : list nat,
        fg_dom (list nat × list nat) (fun _ : list nat × list natlist nat) ty0 (nil, l0)
  | fg_dom_equation_2 : (n : nat) (l l0 : list nat),
      fg_dom (list nat × list nat × list nat)
             (fun _ : list nat × list nat × list natlist nat) ty1 (l, l0, n :: l) →

      fg_dom (list nat × list nat) (fun _ : list nat × list natlist nat) ty0
                          (n :: l, l0)
  | fg_dom_equation_3 : l0 l1 l : list nat,
                        fg_dom (list nat × list nat) (fun _ : list nat × list natlist nat) ty0
                          (l0, l1 ++ l) →
                        fg_dom (list nat × list nat × list nat)
                          (fun _ : list nat × list nat × list natlist nat) ty1 (l0, l1, l).

  Lemma fg_ind_inh : A P t x, fg_dom A P t x.
  Proof.
    intros.s


destruct t. destruct x. destruct l. econstructor.
    econstructor.

End sct2.

This page has been generated by coqdoc