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 : A → Type), 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 : A ⇒ y)%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 A → B → Prop with
| ty0, ty0 ⇒ lt
| ty1, ty1 ⇒ fun l l' ⇒ length l < length l'
| ty0, ty1 ⇒ fun n l ⇒ n < length l
| ty1, ty0 ⇒ fun l n ⇒ length 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 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. 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 x ⇒ S (measure_abc x)
| C x ⇒ S (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 x ⇒ S (measure_abc' x)
| B x ⇒ S (measure_abc' x)
| C x ⇒ S (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 : A → Set), 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 A → B → Prop with
| ty0, ty0 ⇒ fun '(l0, l1) '(l0', l1') ⇒ (* length l0 < length l0' *) False
| ty1, ty1 ⇒ fun '(l0, n, l1) '(l0', n', l1') ⇒ (* length l0 < length l0' *) False
| ty0, ty1 ⇒ fun '(l0, l1) '(l0', l1', l2') ⇒ length l0 ≤ length l0'
| ty1, ty0 ⇒ fun '(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 : type → type → Prop :=
| 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 nat ⇒ list nat), ty1, (l, l0, n :: l))
&((list nat × list nat)%type, (fun _ : list nat × list nat ⇒ list 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 : A → B) (x y : A), f x = f y → x = y.
Polymorphic Lemma simpl_f A B (f : A → B) (x y : A) (P : x = y → Type) :
(∀ 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 : A → Set), ty A P → A → Prop :=
| fg_dom_equation_1 :
∀ l0 : list nat,
fg_dom (list nat × list nat) (fun _ : list nat × list nat ⇒ list 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 nat ⇒ list nat) ty1 (l, l0, n :: l) →
fg_dom (list nat × list nat) (fun _ : list nat × list nat ⇒ list nat) ty0
(n :: l, l0)
| fg_dom_equation_3 : ∀ l0 l1 l : list nat,
fg_dom (list nat × list nat) (fun _ : list nat × list nat ⇒ list nat) ty0
(l0, l1 ++ l) →
fg_dom (list nat × list nat × list nat)
(fun _ : list nat × list nat × list nat ⇒ list 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