├── README.md ├── .#q.v ├── trace ├── .csdp.cache ├── .lia.cache ├── .nia.cache ├── .nra.cache ├── #q.v# ├── diff2.v ├── fintype.v ├── dvec.v ├── vec.v ├── matrix.v ├── rat.v ├── #vec2.v# ├── vec2.v ├── realplay.v ├── diff.v └── realvec.v /README.md: -------------------------------------------------------------------------------- 1 | # coq-vector 2 | -------------------------------------------------------------------------------- /.#q.v: -------------------------------------------------------------------------------- 1 | philip@FartMachine7.fios-router.home.17655 -------------------------------------------------------------------------------- /trace: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/philzook58/coq-vector/master/trace -------------------------------------------------------------------------------- /.csdp.cache: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/philzook58/coq-vector/master/.csdp.cache -------------------------------------------------------------------------------- /.lia.cache: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/philzook58/coq-vector/master/.lia.cache -------------------------------------------------------------------------------- /.nia.cache: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/philzook58/coq-vector/master/.nia.cache -------------------------------------------------------------------------------- /.nra.cache: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/philzook58/coq-vector/master/.nra.cache -------------------------------------------------------------------------------- /#q.v#: -------------------------------------------------------------------------------- 1 | Require Import QArith. 2 | Goal forall y z : Q, (Qplus y z) == (Qplus z y). intros. Search (_ + _). apply Qplus_comm. -------------------------------------------------------------------------------- /diff2.v: -------------------------------------------------------------------------------- 1 | Require Import QArith. 2 | 3 | Require Import Psatz. 4 | 5 | Require Import Ring. 6 | 7 | 8 | Definition dt := (1 # 100). 9 | 10 | Definition step x := x + dt * x. 11 | 12 | Definition step2 x := step (step x). 13 | 14 | Goal forall x, x >= 0 -> x <= 2 * x + 1. intros. lra. Qed. 15 | 16 | Definition step2' x := (1 + 3 * dt) * x. 17 | Goal forall x, 0 <= x -> step2 x <= step2' x. unfold step2. unfold step2'. unfold step. unfold dt. intros. lra. Qed. 18 | 19 | 20 | Goal forall x, x >= 0 -> step x >= x. intros. unfold step. unfold dt. lra. Qed. 21 | 22 | (* Induction 23 | 24 | 25 | Manual building the proof for individual guys. 26 | *) 27 | 28 | -------------------------------------------------------------------------------- /fintype.v: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | https://www.ps.uni-saarland.de/~menz/finalTalktex.pdf 4 | Why am I even fighting the a -> R form of vectors. 5 | It's kind of nice. 6 | 7 | 8 | https://github.com/bmsherman/finite 9 | https://github.com/tchajed/cardinality 10 | 11 | There is of course the Fin n type. That'll probably suck to use 12 | 13 | uustalu firsov agda 14 | http://firsov.ee/finset/finset.pdf 15 | 16 | https://math-comp.github.io/htmldoc/mathcomp.ssreflect.fintype.html 17 | 18 | *) 19 | 20 | Class BEnum a := { 21 | enumAll : list a 22 | }. 23 | 24 | Instance unitbenum : BEnum unit := {| enumAll := cons tt nil |}. 25 | Instance boolbenum : BEnum bool := {| enumAll := (cons true ( cons false nil)) |}. 26 | 27 | 28 | Instance pairbenum `{BEnum a} `{BEnum b} : BEnum (a * b) := 29 | {| enumAll := 30 | |}. 31 | Instance unitbenum : BEnum unit := {| enumAll := cons tt nil |}. 32 | -------------------------------------------------------------------------------- /dvec.v: -------------------------------------------------------------------------------- 1 | 2 | 3 | Require Import Ring. 4 | Definition v2 (A : Type) := A -> A -> A. 5 | (* Really it should be a linear function. *) 6 | 7 | Definition xhat {A : Type} : v2 A := fun x y => x. 8 | Definition yhat {A : Type} : v2 A := fun x y => y. 9 | 10 | Class SemiRing (A : Type) := 11 | { 12 | plus : A -> A -> A ; 13 | one : A ; 14 | zero : A ; 15 | times : A -> A -> A ; 16 | (* Plus all the laws. *) 17 | 18 | }. 19 | 20 | Search Nat.add. 21 | Locate "+". 22 | Instance seminat : SemiRing nat := { 23 | plus := Nat.add; 24 | one := 1; 25 | zero := 0; 26 | times := Nat.mul 27 | }. 28 | Definition vadd {A : Type} {ringa : SemiRing A} (v : v2 A) (w : v2 A) : v2 A := 29 | fun x1 y1 => plus (v x1 y1) (w x1 y1). 30 | 31 | Compute vadd xhat yhat 1 2. 32 | 33 | Definition smul {A : Type} {ringa : SemiRing A} (s : A) (v : v2 A) : v2 A := 34 | fun x1 y1 => times s (v x1 y1). 35 | 36 | Definition dot {A : Type} {ringa : SemiRing A} (v : v2 A) (w : v2 A) : A := 37 | plus (times (v one zero) (w one zero)) (times (v zero one ) (w zero one)). 38 | 39 | Compute dot xhat yhat. 40 | Compute dot xhat xhat. 41 | 42 | -------------------------------------------------------------------------------- /vec.v: -------------------------------------------------------------------------------- 1 | Require Import Ring_theory. 2 | Print ring_theory. 3 | 4 | Inductive V0 (A : Type) : Type := V0Make. 5 | Inductive V1 (A : Type) : Type := V1Make : A -> V1 A. 6 | Inductive V2 (A : Type) : Type := V2Make : A -> A -> V2 A. 7 | Inductive Kron (f : Type -> Type) (g : Type -> Type) (a : Type) := MkKron : (f (g a)) -> Kron f g a. 8 | Inductive DSum (f : Type -> Type) (g : Type -> Type) (a : Type) := MkDSum : f a -> g a -> DSum f g a. 9 | (* We need to get the ring theory in there. *) 10 | Class Linear (f : Type -> Type) (A : Type) := { 11 | vsum : f A -> f A -> f A ; 12 | smul : A -> f A -> f A; 13 | vzero : f A 14 | }. 15 | 16 | Notation "s *^ v" := (smul s v) (at level 75, right associativity). 17 | Notation "v ^+^ w" := (vsum v w) (at level 70, right associativity). 18 | 19 | Instance linearV1 : Linear V1 nat := { 20 | vsum := fun v w => match v,w with 21 | | (V1Make _ x), (V1Make _ y) => V1Make _ (x + y) 22 | end; 23 | smul s v := match v with 24 | | (V1Make _ x) => V1Make _ (s * x) 25 | end; 26 | vzero := V1Make _ 0 27 | }. 28 | Instance linearDSum (f : Type -> Type) (g : Type -> Type) `{Linear f nat} `{Linear g nat} : Linear (DSum f g) nat := { 29 | vsum := fun v w => match v,w with 30 | | (MkDSum _ _ _ f g), (MkDSum _ _ _ f' g') => MkDSum _ _ _ (f ^+^ f') (g ^+^ g') 31 | end; 32 | smul s v := match v with 33 | | (MkDSum _ _ _ f g) => MkDSum _ _ _ (s *^ f) (s *^ g) 34 | end; 35 | vzero := MkDSum _ _ _ vzero vzero 36 | }. 37 | 38 | Definition v1one := V1Make _ 1. 39 | Compute v1one ^+^ v1one. 40 | Definition v2one := MkDSum _ _ _ v1one v1one. 41 | Compute v2one ^+^ v2one. 42 | 43 | 44 | 45 | 46 | 47 | (* 48 | Class Ring (A : Type) := { 49 | eq : 50 | plus 51 | theory : ring_theory eq 52 | 53 | 54 | } 55 | 56 | Record LinOp (f : v A -> w A) { 57 | is_linear : f (v ^+^ w) = (f v) ^+^ (f w) 58 | 59 | 60 | } 61 | 62 | *) 63 | (* 64 | dist_smul : smul s (vsum x y) = vsum (smul s x) (smul s y); 65 | assoc_vsum : (vsum (vsum x y) z) = vsum (vsum x y) z; 66 | assoc_smul : smul s (smul s' v) = smul (s * s') v; 67 | dist_smul : smul (s + s') v = vsum (smul s v) (smul s' v); 68 | vsum_comm : vsum x y = vsum y x; 69 | smul_id : smul 1 v = v; 70 | vzero_id : vsum v vzero = v 71 | 72 | *) 73 | -------------------------------------------------------------------------------- /matrix.v: -------------------------------------------------------------------------------- 1 | (*Require Import stdpp.base stdpp.numbers. 2 | *) 3 | Require Import QArith. 4 | Record V2 (a : Type) := { 5 | x2 : a; 6 | y2 : a 7 | }. 8 | 9 | Arguments x2 {a}. 10 | Arguments y2 {a}. 11 | 12 | 13 | 14 | Record M2 := { 15 | c1 : V2 Q; 16 | c2 : V2 Q 17 | }. 18 | 19 | Open Scope Q_scope. 20 | Definition vadd v w : V2 Q := {| x2 := v.(x2) + w.(x2) ; y2 := v.(y2) + w.(y2) |}. 21 | 22 | Definition smul s v : V2 Q := {| x2 := s * v.(x2) ; y2 := s * v.(y2) |}. 23 | 24 | Definition dot v w : Q := v.(x2) * w.(x2) + v.(y2) * w.(y2). 25 | 26 | Definition mapply m v := vadd (smul v.(x2) m.(c1)) (smul v.(y2) m.(c2)). 27 | 28 | 29 | 30 | Require Import Ring. 31 | Require Import Psatz. 32 | Require Import Lqa. 33 | 34 | Goal forall x y , x + y == x + y. intros. lra. Qed. 35 | 36 | Definition VEq v w := v.(x2) == w.(x2) /\ v.(y2) == w.(y2). 37 | Notation "x == y" := (VEq x y). 38 | Notation " x + y " := (vadd x y). 39 | Notation " s * y " := (smul s y). 40 | 41 | 42 | 43 | Definition vzero := {| x2 := 0 ; y2 := 0 |}. 44 | 45 | Definition xhat := {| x2 := 1 ; y2 := 0 |}. 46 | 47 | Definition yhat := {| x2 := 0 ; y2 := 1 |}. 48 | Check vzero. 49 | Check vzero == vzero. 50 | Theorem vadd_comm : forall v w, v + w == w + v. Proof. intros. split; simpl; lra. Qed. 51 | 52 | (* This is a setoid equality. :/ Does lra not work on Qc? *) 53 | 54 | Theorem linop : forall v w m, mapply m (vadd v w) == (vadd (mapply m v) (mapply m w)). 55 | intros. unfold mapply. unfold vadd. simpl. split; simpl; lra. Qed. 56 | 57 | Theorem linop2 : forall s v m, mapply m (smul s v) == smul s (mapply m v). 58 | intros. unfold mapply. unfold smul. simpl. split; simpl; lra. Qed. 59 | 60 | Definition mcompose m n := {| 61 | c1 := mapply m n.(c1); 62 | c2 := mapply m n.(c2) 63 | 64 | |}. 65 | 66 | Notation " m @@ n " := (mcompose m n) (at level 50) . 67 | Notation " m @ v " := (mapply m v) (at level 50) . 68 | 69 | 70 | 71 | Theorem matrixgood : forall m n v, mapply m (mapply n v) == mapply ( mcompose m n ) v. 72 | intros. unfold mapply. unfold mcompose. simpl. split; simpl; lra. Qed. 73 | 74 | Definition madd m n := {| 75 | c1 := vadd m.(c1) n.(c1); 76 | c2 := vadd m.(c2) n.(c2) 77 | |}. 78 | 79 | Notation "<< a b >>" := {| x2 := a ; y2 := b |}. 80 | Notation "<< a b , c d >>" := {| c1 := {| x2 := a ; y2 := c|} ; c2 := {| x2 := b ; y2 := d |} |}. 81 | 82 | Check << 1 0 >> . 83 | 84 | (* 85 | 86 | https://www.labri.fr/perso/casteran/CoqArt/TypeClassesTut/typeclassestut.pdf 87 | He does a 2x2 matrix type 88 | *) 89 | 90 | Require Import Extraction. 91 | Require Import Coq.extraction.ExtrOcamlNatInt Coq.extraction.ExtrOcamlZInt. 92 | Recursive Extraction vadd. 93 | Recursive Extraction smul. 94 | 95 | Goal dot vzero vzero <= 1. cbn. unfold dot. simpl. lra. Qed. 96 | 97 | 98 | 99 | 100 | Theorem vadd_comm : forall v w, vadd v w = vadd w v. Proof. 101 | intros v w. destruct v. destruct w. unfold vadd. cbn. assert (x3 + x4 = x4 + x3). ring. assert (y3 + y4 = y4 + y3). ring. rewrite H. rewrite H0. auto. Qed. 102 | 103 | Theorem smul_assoc : forall a b v, smul a (smul b v) = smul (a * b) v. Proof. 104 | intros. destruct v. unfold smul. cbn. assert (a * (b * x3) = a * b * x3). ring. assert (a * (b * y3) = a * b * y3). ring. rewrite H. rewrite H0. auto. Qed. 105 | 106 | 107 | -------------------------------------------------------------------------------- /rat.v: -------------------------------------------------------------------------------- 1 | 2 | Compute 1 + 1. 3 | Require Import ZArith. 4 | 5 | Compute 2 + 3. 6 | Compute (2+3)%Z. 7 | 8 | Require Import QArith. 9 | Compute 1 # 2. 10 | Compute 7 # 8. 11 | 12 | Compute (1 # 2 == 2 # 4). 13 | (* https://coq.inria.fr/distrib/current/stdlib/Coq.QArith.QArith_base.html# *) 14 | 15 | 16 | Theorem simplq : (1 # 2 == 2 # 4). 17 | Proof. 18 | reflexivity. 19 | Qed. 20 | 21 | Theorem simpq2 (x : Q) : x + 1 == x + 1. 22 | Proof. 23 | reflexivity. 24 | Qed. 25 | 26 | Record V2 : Set := V2make {x : Q; y : Q }. 27 | Record V2' (a : Set) : Set := V2make' {x' : a; y' : a}. 28 | 29 | Definition V2'' := V2' Q. 30 | 31 | Definition xhat := V2make 1 0. 32 | Definition yhat := V2make 0 1. 33 | 34 | Compute x xhat. 35 | 36 | Definition vsum (v1 v2 : V2) := V2make (x v1 + x v2) (y v1 + y v2). 37 | Compute vsum xhat yhat. 38 | Definition dot (v1 v2 : V2) := (x v1 * x v2) + (y v1 * y v2). 39 | Compute dot xhat yhat. 40 | Compute dot xhat xhat. 41 | 42 | 43 | 44 | Definition smul ( s : Q) (v : V2) := V2make (s * x v) (s * y v). 45 | 46 | Definition vnegate (v : V2) := V2make (Qopp (x v)) (Qopp (y v)). 47 | 48 | 49 | 50 | Definition vsub (v1 v2 : V2) := vsum v1 (vnegate v2). 51 | (* or define vsub via an entirely new definition? using Qminus *) 52 | Definition vEq (v1 v2 : V2) := (x v1) == (x v2) /\ (y v1) == (y v2). 53 | 54 | Theorem negatedist (v1 v2 : V2) : vEq (vnegate (vsum v1 v2)) (vsum (vnegate v1) (vnegate v2)). 55 | Admitted. 56 | 57 | 58 | Theorem symvEq (v1 v2 : V2) (e : vEq v1 v2) : (vEq v2 v1). 59 | Proof. 60 | unfold vEq. unfold vEq in e. destruct e. split. apply Qeq_sym. rewrite H. reflexivity. apply Qeq_sym. rewrite H0. reflexivity. 61 | Qed. 62 | 63 | 64 | 65 | Theorem smuldist (s : Q) (v1 v2 : V2) : vEq (smul s (vsum v1 v2)) (vsum (smul s v1) (smul s v2)). 66 | Proof. 67 | unfold vEq. simpl. split. rewrite Qmult_plus_distr_r. reflexivity. 68 | rewrite Qmult_plus_distr_r. reflexivity. 69 | Qed. 70 | 71 | Definition Pos a := exists b, a = Zpos b. 72 | Definition NonNeg a := (a = Z0) \/ Pos a. 73 | 74 | Theorem squarenonneg (x : Z) : NonNeg (x * x). 75 | Proof. 76 | unfold NonNeg. destruct x. left. reflexivity. right. unfold Pos. simpl. eauto. simpl. unfold Pos. right. eauto. Qed. 77 | 78 | 79 | Definition QNonNeg x := exists b, exists c, NonNeg b /\ x = Qmake b c. 80 | 81 | 82 | Theorem squarenonnegQ (x : Q) : QNonNeg (x * x). 83 | Proof. 84 | unfold QNonNeg. destruct x as [ n d ]. unfold Qmult. simpl. unfold Qmult. 85 | exists (Zmult n n). exists (Pmult d d). split. apply squarenonneg. reflexivity. Qed. 86 | 87 | Theorem QNonNegSum (x y : Q) (p1 : QNonNeg x) (p2 : QNonNeg y) : QNonNeg (x + y). 88 | Proof. 89 | Admitted. 90 | 91 | (* unfold QNonNeg. unfold QNonNeg in p1. *) 92 | 93 | Theorem dotpos (v : V2) : QNonNeg (dot v v). 94 | Proof. 95 | Admitted. 96 | 97 | Definition project (v1 v2 : V2) := vsub v1 (smul (Qdiv (dot v1 v2) (dot v1 v1)) v2). 98 | 99 | Definition vzero : V2 := V2make 0 0. 100 | 101 | Theorem projectgone (v1 v2 : V2) : (dot v1 (project v2 v1)) == 0. 102 | unfold dot. unfold project. unfold vsub. unfold vnegate. unfold vsum. unfold dot. unfold smul. simpl. Abort. 103 | 104 | 105 | (* I need to introduce a new variable for x v1. Then it hsould be obvious by the ring solver. *) 106 | 107 | Definition InHalfSpace (l v : V2) := QNonNeg (dot l v). 108 | 109 | 110 | (* 111 | 112 | Definition Cone (P : V2 -> Prop) := forall x1 x2 : V2, forall NonNeg l, NonNeg l2, P x1 -> P x2 -> P (l * x1 + l * x2) 113 | 114 | Definition Support (l : V2) P := forall x, P x -> InHalfSpace l x 115 | 116 | Definition 117 | 118 | forall x1 x2 119 | 120 | *) 121 | 122 | 123 | (* normsquare -> positive rational 124 | Should we perhaps make a positive rationals type? 125 | QPos = {N , positive} 126 | 127 | Leading to the obvious question : how to abstract over V2 128 | how to abtract over Q 129 | how to write automation for these proofs. because they are mega trivial. 130 | 131 | projection 132 | gram schmidt 133 | cuachy-schwartz 134 | 135 | *) 136 | 137 | (* 138 | Theorem qpos (x : Q) : x * x >= 0. 139 | Proof. 140 | destruct x. destruct Qnum. rewrite Qmult_0_l. 141 | 142 | 143 | 144 | Compute V2make 1 0. 145 | Compute V2make 0 1. 146 | 147 | 148 | Require Import Reals. 149 | Print Z_scope. 150 | Compute Z0. 151 | Compute 0. 152 | 153 | Compute QArith. 154 | *) -------------------------------------------------------------------------------- /#vec2.v#: -------------------------------------------------------------------------------- 1 | From stdpp Require Import finite vector numbers. 2 | 3 | Locate vec. 4 | Compute vec. 5 | Compute vec bool 1. 6 | Compute [# true ; false ]. 7 | 8 | Class Vector (v : Type) (s : Type) := 9 | { 10 | vsum : v -> v -> v; 11 | smul : s -> v -> v; 12 | vzero : v; 13 | dist : forall s x y, smul s (vsum x y) = vsum (smul s x) (smul s y) 14 | 15 | }. 16 | Print Vector. 17 | 18 | Require Import QArith. 19 | Search Q. 20 | Print Qmult. 21 | Print Qmult'. 22 | Print Scope Q_scope. 23 | 24 | Instance zerovect {a} : Vector unit a. refine {| 25 | vsum x y := tt; 26 | smul _ _ := tt; 27 | vzero := tt 28 | 29 | 30 | |}. 31 | intros. auto. Qed. 32 | 33 | 34 | Search ring_theory. 35 | 36 | Goal forall y z, (Qplus y z) = (Qplus z y). intros. Search (_ + _). apply Qplus_comm. 37 | 38 | 39 | 40 | Instance qvect : Vector Q Q. refine {| 41 | vsum := Qplus; 42 | smul := Qmult; 43 | vzero := 0 44 | |}. 45 | intros. ring. 46 | 47 | Instance tupvect `{Vector v s} : Vector (v * v) s := {| 48 | vsum u w := match u,w with (x,y), (a,b) => (vsum x a, vsum y b) end; 49 | smul s v := match v with (x,y) => (smul s x, smul s y) end; 50 | vzero := (vzero, vzero) 51 | 52 | |}. 53 | (* 54 | Instance arrvect {a} `{Vector s s} : Vector (a -> s) s := {| 55 | vsum u w := fun z => vsum (u z) (w z) ; 56 | smul s v := fun z => smul s (v z) ; 57 | vzero := ? 58 | 59 | |}. 60 | *) 61 | Class Norm (v : Type) (s : Type) := 62 | { 63 | norm : v -> s 64 | }. 65 | 66 | Search Q. 67 | (* Instance qnorm : Norm Q Q := 68 | {| 69 | norm := Qabs 70 | |}. 71 | *) 72 | 73 | Class Inner (v : Type) (s : Type) := 74 | { 75 | dot : v -> v -> s 76 | }. 77 | 78 | Instance dotQ : Inner Q Q := 79 | {| 80 | dot := Qmult 81 | |}. 82 | 83 | Instance tupQ `{Inner a Q} `{Inner b Q} : Inner (a * b) Q := 84 | {| 85 | dot x y := match x, y with | (a,b),(c,d) => (dot a c) + (dot b d) end 86 | |}. 87 | 88 | Print nat. 89 | 90 | Fixpoint vec n a : Type := match n with | S n' => (a * (vec n' a)) | O => unit end. 91 | 92 | Compute vec 10 Q. 93 | 94 | 95 | 96 | Definition norm2 `{Inner v s} (x : v) := dot x x. 97 | 98 | (* Instance sumvect `{Vector v s} `{Vector w s} := Vector (v + w) s := {| 99 | vsum 100 | 101 | |}. 102 | Nope, that's silly. 103 | 104 | Thes definitions make it rather difficult to define kroncker product. 105 | I guess 106 | class Kron a b c s := { 107 | kron : a -> b -> c 108 | } 109 | 110 | *) 111 | Class Kron (a b c : Type) := { 112 | kron : a -> b -> c 113 | }. 114 | 115 | Instance scalarkron `{Vector b s} : Kron s b b := {| 116 | kron := smul 117 | |}. 118 | 119 | Instance dsumkron `{Kron a c d} `{Kron b c e} : Kron (prod a b) c (d * e) := {| 120 | kron x y := match x with | (a,b) => (kron a y, kron b y) end 121 | (* : Vector d s *) 122 | |}. 123 | 124 | Compute kron (vzero : (Q * Q) ) (vzero : (Q * Q)). 125 | 126 | 127 | Fixpoint e {a} n : vec n a. := match n with 128 | 129 | 130 | 131 | 132 | (* 133 | 134 | I definitely want to use the decidable typeclass technology. 135 | ??? 136 | 137 | Can I get psatz to fire on this stuff? 138 | 139 | Decidable (a = a) for 140 | 141 | What about Decision (smul s (vsum ) = ) 142 | 143 | 144 | We could write a Ring normalizer using typeclases 145 | 146 | Class Ring a { 147 | mul : a -> a -> a; 148 | plus : a -> a -> a; 149 | zero : a -> a -> a; 150 | one : a -> a -> a; 151 | negate : a -> a 152 | } 153 | 154 | 155 | *) 156 | -------------------------------------------------------------------------------- /vec2.v: -------------------------------------------------------------------------------- 1 | From stdpp Require Import finite vector numbers. 2 | 3 | Locate vec. 4 | Compute vec. 5 | Compute vec bool 1. 6 | Compute [# true ; false ]. 7 | 8 | Class Vector (v : Type) (s : Type) := 9 | { 10 | vsum : v -> v -> v; 11 | smul : s -> v -> v; 12 | vzero : v; 13 | dist : forall s x y, smul s (vsum x y) = vsum (smul s x) (smul s y) 14 | 15 | }. 16 | Print Vector. 17 | 18 | Require Import QArith. 19 | Search Q. 20 | Print Qmult. 21 | Print Qmult'. 22 | Print Scope Q_scope. 23 | 24 | Instance zerovect {a} : Vector unit a. refine {| 25 | vsum x y := tt; 26 | smul _ _ := tt; 27 | vzero := tt 28 | 29 | 30 | |}. 31 | intros. auto. Qed. 32 | 33 | 34 | Search ring_theory. 35 | 36 | Goal forall y z, (Qplus y z) = (Qplus z y). intros. Search (_ + _). apply Qplus_comm. 37 | 38 | 39 | 40 | Instance qvect : Vector Q Q. refine {| 41 | vsum := Qplus; 42 | smul := Qmult; 43 | vzero := 0 44 | |}. 45 | intros. ring. 46 | 47 | Instance tupvect `{Vector v s} : Vector (v * v) s := {| 48 | vsum u w := match u,w with (x,y), (a,b) => (vsum x a, vsum y b) end; 49 | smul s v := match v with (x,y) => (smul s x, smul s y) end; 50 | vzero := (vzero, vzero) 51 | 52 | |}. 53 | (* 54 | Instance arrvect {a} `{Vector s s} : Vector (a -> s) s := {| 55 | vsum u w := fun z => vsum (u z) (w z) ; 56 | smul s v := fun z => smul s (v z) ; 57 | vzero := ? 58 | 59 | |}. 60 | *) 61 | Class Norm (v : Type) (s : Type) := 62 | { 63 | norm : v -> s 64 | }. 65 | 66 | Search Q. 67 | (* Instance qnorm : Norm Q Q := 68 | {| 69 | norm := Qabs 70 | |}. 71 | *) 72 | 73 | Class Inner (v : Type) (s : Type) := 74 | { 75 | dot : v -> v -> s 76 | }. 77 | 78 | Instance dotQ : Inner Q Q := 79 | {| 80 | dot := Qmult 81 | |}. 82 | 83 | Instance tupQ `{Inner a Q} `{Inner b Q} : Inner (a * b) Q := 84 | {| 85 | dot x y := match x, y with | (a,b),(c,d) => (dot a c) + (dot b d) end 86 | |}. 87 | 88 | Print nat. 89 | 90 | Fixpoint vec n a : Type := match n with | S n' => (a * (vec n' a)) | O => unit end. 91 | 92 | Compute vec 10 Q. 93 | 94 | 95 | 96 | Definition norm2 `{Inner v s} (x : v) := dot x x. 97 | 98 | (* Instance sumvect `{Vector v s} `{Vector w s} := Vector (v + w) s := {| 99 | vsum 100 | 101 | |}. 102 | Nope, that's silly. 103 | 104 | Thes definitions make it rather difficult to define kroncker product. 105 | I guess 106 | class Kron a b c s := { 107 | kron : a -> b -> c 108 | } 109 | 110 | *) 111 | Class Kron (a b c : Type) := { 112 | kron : a -> b -> c 113 | }. 114 | 115 | Instance scalarkron `{Vector b s} : Kron s b b := {| 116 | kron := smul 117 | |}. 118 | 119 | Instance dsumkron `{Kron a c d} `{Kron b c e} : Kron (prod a b) c (d * e) := {| 120 | kron x y := match x with | (a,b) => (kron a y, kron b y) end 121 | (* : Vector d s *) 122 | |}. 123 | 124 | Compute kron (vzero : (Q * Q) ) (vzero : (Q * Q)). 125 | 126 | 127 | Fixpoint e {a} n : vec n a. := match n with 128 | 129 | 130 | 131 | 132 | (* 133 | 134 | I definitely want to use the decidable typeclass technology. 135 | ??? 136 | 137 | Can I get psatz to fire on this stuff? 138 | 139 | Decidable (a = a) for 140 | 141 | What about Decision (smul s (vsum ) = ) 142 | 143 | 144 | We could write a Ring normalizer using typeclases 145 | 146 | Class Ring a { 147 | mul : a -> a -> a; 148 | plus : a -> a -> a; 149 | zero : a -> a -> a; 150 | one : a -> a -> a; 151 | negate : a -> a 152 | } 153 | 154 | 155 | *) 156 | -------------------------------------------------------------------------------- /realplay.v: -------------------------------------------------------------------------------- 1 | Require Import Reals. 2 | Require Import ZArith. 3 | 4 | 5 | Open Scope Z_scope. 6 | 7 | Goal forall x y, x + y = y + x. debug auto with zarith. Qed. 8 | (* ok the next one basically did it by omega *) 9 | Goal forall x y z, (x + y) + z = y + (x + z). debug auto with zarith. Qed. 10 | 11 | Goal forall x y z, x * (y + z) = x * y + x * z. debug auto with zarith. Qed. 12 | 13 | 14 | Open Scope R_scope. 15 | Require Import Psatz. 16 | 17 | About R. 18 | Goal 1 + 1 = 2. lra. Qed. 19 | Variable x y z : R. 20 | 21 | Goal x + y = y + x. lra. Qed. 22 | Goal (x + y) + z = x + (y + z). lra. Qed. 23 | Goal x - x = 0. lra. Qed. 24 | Goal (x + 0 = x). lra. Qed. 25 | Goal x*x >= 0. nra. Qed. 26 | 27 | Locate "<=?". 28 | 29 | Inductive abs : Prop -> R -> R -> Prop := 30 | | LE0 : abs (x <= 0) x (-x) 31 | | GE0 : abs (x >= 0) x x 32 | . 33 | 34 | (* Theorem zsplit : (x <= 0) + (x >= 0). assert ((x <= 0) \/ (x >= 0)). lra. 35 | *) 36 | 37 | Record I {a} := mk_I { l : a; r : a}. 38 | 39 | Require Import QArith. 40 | Definition IQ := I (a := Q). 41 | 42 | Check (mk_I Q 0 0). 43 | Definition iadd (x : IQ) (y : IQ) : IQ := 44 | mk_I Q (x.(l) + y.(l) ) ( x.(r) + y.(r)) . 45 | (* Search (R -> R -> ). *) 46 | 47 | Definition ilift (x : Q) : IQ := {| l := x ; r := x |}. 48 | 49 | Definition i0 := ilift 0. 50 | Definition i1 := ilift 1. 51 | Definition iu := {| l := 0 ; r := 1 |}. 52 | Compute iadd i1 i0. 53 | Compute iadd iu iu. 54 | Open Scope Q_scope. 55 | Print Scope Q_scope. 56 | 57 | 58 | 59 | Locate "&&". 60 | 61 | Definition ile (x : IQ) (y : IQ) := 62 | Qle_bool x.(l) y.(l) && Qle_bool y.(r) x.(r) 63 | . 64 | 65 | (* Theorem iadd_iso : forall ia ib, ile (iadd ia ib) *) 66 | Close Scope Q_scope. 67 | Definition baby_iter (x : R) (y : R) := (x / y + y) / 2%R. 68 | 69 | Compute baby_iter 3 7. 70 | 71 | Goal Rabs 3 = 3. Proof. unfold Rabs. destruct (Rcase_abs 3); lra. Qed. 72 | 73 | 74 | Definition near eps x y := (x - y < eps) /\ (y - x < eps). 75 | 76 | 77 | Definition cont f := forall x y del, del > 0 -> exists eps, R_dist x y < eps -> R_dist (f x) (f y) < del. 78 | (* using near is more automatable that R_dist which ises Rabs which is a branch *) 79 | Definition cont2 f := forall x del, del > 0 -> exists eps, forall y, near eps x y -> near del (f x) (f y). 80 | 81 | Goal cont2 (fun x => x). unfold cont2. unfold near. intros. eexists. intros. eauto. 82 | Qed. 83 | (* exists del. intros. lra. Qed. *) 84 | Goal cont2 (fun x => 2*x). unfold cont2. unfold near. intros. exists (del / 2). intros. lra. Qed. 85 | Theorem relabs x : exists z, z >= 0 /\ ((z = x) \/ z = -x). assert ((x >= 0) \/ (x <= 0)). lra. destruct H. exists x. lra. exists (-x). lra. Qed. 86 | 87 | Theorem relmax x y : exists z, z >= x /\ z >= y /\ (z = x \/ z = y). assert ((x >= y) \/ (y >= x)). lra. destruct H. exists x; lra. exists y; lra. Qed. 88 | 89 | 90 | Theorem relabs2 x : { z | z >= 0 /\ ((z = x) \/ z = -x)}. destruct (total_order_T x (-x)). destruct s. exists (-x). lra. exists 0. lra. exists x. lra. Qed. 91 | 92 | (* can't destruct H because H is prop. Tougher to prove assert, can't use lra. *) 93 | 94 | 95 | (* 96 | 97 | The subset type notation. 98 | Check { | e >= 0 }. 99 | 100 | These existential things are a lot like 101 | return z, cs 102 | 103 | *) 104 | 105 | Locate "exists". 106 | Print ex. 107 | Locate "/\". 108 | Print and. 109 | Locate ",". 110 | Locate "&". 111 | Print R. 112 | Print prod. 113 | Definition R2 : Set := R * R. 114 | Theorem reflAbs : forall x, (Rabs x = x) \/ (Rabs x = -x). intros. unfold Rabs. destruct (Rcase_abs x0); lra. Qed. 115 | 116 | Definition proj1 : forall A P, { x : A | P x} -> A := fun A P z => let (x, pf) := z in x. 117 | 118 | 119 | 120 | Theorem norm (x : R2) : {z | z = relmax (relabs (fst x)) (relabs (snd x)) }. 121 | 122 | {z | z >= (relabs (fst x)) } let (z1, pf1) := (relabs2 (fst x)) in 123 | let (z2, pf2) := (relabs2 (snd x)) in 124 | let (z3, pf3) := relmax z1 z2 in 125 | { z3 | pf1 /\ pf2 /\ pf3}. 126 | 127 | 128 | 129 | (* 130 | https://github.com/coq/coq/wiki/Talkin'-with-the-Rooster 131 | 132 | eexists 133 | eauto 134 | replace 135 | info auto 136 | debug eauto 137 | specialize 138 | congruence 139 | ring field 140 | firstorder 141 | cut 142 | autorewrite 143 | fourier 144 | 145 | intuition? 146 | Hint Resolve 147 | Hint 148 | 149 | info auto 150 | debug eauto 151 | 152 | 153 | https://github.com/VERIMAG-Polyhedra/VplTactic 154 | 155 | 156 | 157 | *) 158 | 159 | Print Hint *. (* Prints all hints *) 160 | Print HintDb real. 161 | Print HintDb arith. 162 | Print HintDb zarith. 163 | 164 | (* 165 | 166 | 167 | core: This special database is automatically used by auto, except when pseudo-database nocore is given to auto. The core database contains only basic lemmas about negation, conjunction, and so on. Most of the hints in this database come from the Init and Logic directories. 168 | arith: This database contains all lemmas about Peano’s arithmetic proved in the directories Init and Arith. 169 | zarith: contains lemmas about binary signed integers from the directories theories/ZArith. When required, the module Omega also extends the database zarith with a high-cost hint that calls omega on equations and inequalities in nat or Z. 170 | bool: contains lemmas about booleans, mostly from directory theories/Bool. 171 | datatypes: is for lemmas about lists, streams and so on that are mainly proved in the Lists subdirectory. 172 | sets: contains lemmas about sets and relations from the directories Sets and Relations. 173 | typeclass_instances: 174 | contains all the typeclass instances declared in the environment, including those used for setoid_rewrite, from the Classes directory. 175 | fset: 176 | 177 | 178 | *) 179 | 180 | (* 181 | Theorem between x y : exists z, (y <= z /\ z <= x) \/ (x <= z /\ z <= y). 182 | *) 183 | 184 | 185 | (* a piecewise function that is relationally defined. 186 | Take in a list of intervals. default value. 187 | Theorem piecewise ls : exists z, ( -1 <= x <= 2 /\ z = 3 * x ) \/ 188 | 189 | Or should we take a reflect style approach? 190 | Instance {Reflect 191 | 192 | 193 | *) 194 | 195 | 196 | Locate Rsqrt. 197 | 198 | Goal cont (fun x => x). unfold cont. intros. exists del. auto. Qed. 199 | Goal cont (fun x => 2*x). unfold cont. intros. exists (del / 2). Search R_dist. intros. rewrite R_dist_mult_l. assert (2 * R_dist x0 y0 < del). lra. unfold Rabs. destruct (Rcase_abs 2); lra. Qed. 200 | 201 | 202 | Goal cont (fun x => x * x). unfold cont. intros. exists (del / (Rabs x + Rabs y)). intros. unfold R_dist. unfold Rabs. destruct RCase_abs . Qed. 203 | 204 | Record ContLens a b := { f : a -> (b * (b -> a)) } . 205 | Check Build_ContLens. 206 | Check {| f := fun x => (x , fun _ => x ) |}. 207 | 208 | (** BEGIN **) 209 | Require Import Reals. 210 | Require Import Interval.Interval_tactic. 211 | 212 | Open Scope R_scope. 213 | 214 | Goal 215 | forall x, -1 <= x <= 1 -> 216 | sqrt (1 - x) <= 3/2. 217 | Proof. 218 | intros. 219 | interval. 220 | Qed. 221 | 222 | Goal 223 | forall x, -1 <= x <= 1 -> 224 | sqrt (1 - x) <= 141422/100000. 225 | Proof. 226 | intros. 227 | interval. 228 | Qed. 229 | 230 | Goal 231 | forall x, -1 <= x <= 1 -> 232 | sqrt (1 - x) <= 141422/100000. 233 | Proof. 234 | intros. 235 | interval_intro (sqrt (1 - x)) upper as H'. 236 | apply Rle_trans with (1 := H'). 237 | interval. 238 | Qed. 239 | 240 | Goal 241 | forall x, 3/2 <= x <= 2 -> 242 | forall y, 1 <= y <= 33/32 -> 243 | Rabs (sqrt(1 + x/sqrt(x+y)) - 144/1000*x - 118/100) <= 71/32768. 244 | Proof. 245 | intros. 246 | interval with (i_prec 19, i_bisect x). 247 | Qed. 248 | 249 | Goal 250 | forall x, 1/2 <= x <= 2 -> 251 | Rabs (sqrt x - (((((122 / 7397 * x + (-1733) / 13547) * x 252 | + 529 / 1274) * x + (-767) / 999) * x 253 | + 407 / 334) * x + 227 / 925)) 254 | <= 5/65536. 255 | Proof. 256 | intros. 257 | interval with (i_bisect_taylor x 3). 258 | Qed. 259 | 260 | Goal 261 | forall x, -1 <= x -> 262 | x < 1 + powerRZ x 3. 263 | Proof. 264 | intros. 265 | interval with (i_bisect_diff x). 266 | Qed. 267 | 268 | Require Import Coquelicot.Coquelicot. 269 | 270 | Goal 271 | Rabs (RInt (fun x => atan (sqrt (x*x + 2)) / (sqrt (x*x + 2) * (x*x + 1))) 0 1 272 | - 5/96*PI*PI) <= 1/1000. 273 | Proof. 274 | interval with (i_integral_prec 9, i_integral_depth 1, i_integral_deg 5). 275 | Qed. 276 | 277 | Goal 278 | RInt_gen (fun x => 1 * (powerRZ x 3 * ln x^2)) 279 | (at_right 0) (at_point 1) = 1/32. 280 | Proof. 281 | refine ((fun H => Rle_antisym _ _ (proj2 H) (proj1 H)) _). 282 | interval. 283 | Qed. 284 | 285 | Goal 286 | Rabs (RInt_gen (fun t => 1/sqrt t * exp (-(1*t))) 287 | (at_point 1) (Rbar_locally p_infty) 288 | - 2788/10000) <= 1/1000. 289 | Proof. 290 | interval. 291 | Qed. 292 | (*** END ***) 293 | 294 | 295 | 296 | 297 | 298 | Definition abs x := if zsplit then -x else x . 299 | 300 | (* 301 | 302 | Continuity Lens 303 | Differentiation and continuity aren't all that different. 304 | In each case we're describing something about how a function is in the neighborhood of a point 305 | 306 | A traditional definition of continuity is using the epsilon-delta definition. 307 | 308 | 309 | *) 310 | 311 | 312 | 313 | Definition cont (f : R -> R) : forall del x y, exists eps, abs (x - y) < eps -> abs (f x) - (f y) < del 314 | 315 | (* 316 | We can skolemize this definition however, to bring a new fresh function out front 317 | exists f, forall del, 318 | 319 | f is now a function of del, x, y 320 | 321 | 322 | (f, c) 323 | a -> (b, b -> a) 324 | evauate the function, and give a pull back of nerughborhoods as described by radii, or as described by l1 norm. 325 | Along with a proof 326 | forall x y del, |x - y| < (snd (f x) del) -> (fst f x) - (fst f y) < del 327 | and vice verse for y. 328 | 329 | Record ContLens a b := { f : a -> (b, b -> a) ; pf : } 330 | 331 | *) 332 | -------------------------------------------------------------------------------- /diff.v: -------------------------------------------------------------------------------- 1 | From stdpp Require Import base numbers. 2 | 3 | (* 4 | The spec of a "differentail" equation 5 | 6 | Defining what differentiation means is difficilt. 7 | 8 | We're better off with difference equations 9 | 10 | This is a matter of spec choice. If your spec TRULY requires a differential equation rather than a difference equation of dt = 10^-100000000, I am very suspicious that you are in a physically relevant regime of that differential equation. 11 | 12 | Differential equations are only used in physics and engineering so far as they are usefl. They compactly describe systems and have occasional useful closed form solutions. Other times they are discretized in some manner for numerical simulation. 13 | 14 | If the differential equation is not numerically simulatable, then it is highly suspicious. 15 | 16 | For the purspoes of usage inside a system like Coq, the differential equation is no longer convenenitn. To explcility state what differentiation means makes things very difficult. 17 | 18 | A mathemticaitica may be interested in a differential equaiton for it's own sake 19 | 20 | 21 | 22 | 23 | Ok 24 | 25 | I really want somewhat autmated lia/lra. 26 | But 27 | 28 | Q can be basically fixed point arithmetic. If the denominator is static and the numerator is dynamic. 29 | 30 | I'd have to overload all the operations. 31 | And then I'd use lia to discharge facts. 32 | Maybe sometimes one could use lra too. 33 | 34 | Record Qa := { nominal : Q; err : nat }. 35 | 36 | I feel like we kind of want err to be a Qa also...? 37 | 38 | Maybe err is with resepct to the same system of denominatrs. That makes sense. 39 | 40 | Qa.plus (x y) 41 | 42 | 43 | It would be kind of nice for a good denominator to be inferred. 44 | 45 | 46 | 47 | The error term would then also be static. 48 | 49 | We'd also probably want to be able to bound 50 | 51 | This seems fun. MetaOcaml for fixed poit 52 | 53 | The point of Qc is 54 | 1. keep the numbers from getting out of control 55 | 2. Being able to use actual equality 56 | 57 | 1. Could build a correspondence system of some kinf/ reflection between Q and Qc. 58 | 2. 59 | 3. 60 | 61 | 62 | The analog in Z3 might be to use an Int64 symbol with a python int as a denominator 63 | 64 | The python in lives at the meta level and can be lifted to z3 level but not vice versa. 65 | 66 | 67 | Yeah, If you make x dynamic and err static, then err is related to uniform continuity, unifrom error bounds. 68 | 69 | *) 70 | 71 | (* 72 | Definition example (x : bool) : nat := 4 + (if x then 2 else 3). 73 | Definition example_cps (b : Type) (x : bool) (k : nat -> b) : b := 74 | let k' := fun n => k (4 + n) in if x then k' 2 else k' 3. 75 | 76 | Eval cbv in example. 77 | (* = λ x : bool, S (S (S (S (if x then 2 else 3)))) 78 | : bool → nat *) 79 | 80 | Eval cbv in example_cps. 81 | *) 82 | 83 | 84 | 85 | (* 86 | = λ (b : Type) (x : bool) (k : nat → b), if x then k 6 else k 7 87 | : ∀ b : Type, bool → (nat → b) → b 88 | *) 89 | 90 | (* 91 | Inductive my_gadt (o : Type) : Type := 92 | | myint : nat -> my_gadt nat 93 | | mybool : bool -> my_gadt bool. 94 | 95 | 96 | Definition thing {a} (x : my_gadt a) := 97 | match x in my_gadt a return (a -> a) -> a with 98 | | myint x => fun f => f x 99 | | mybool x => fun f => f x 100 | end. 101 | 102 | Definition thing {a} (x : my_gadt a) (f : a -> a) : a:= 103 | match x in my_gadt b return nat with 104 | | myint x => f (x + 1) 105 | | mybool x => f (negb x) 106 | end. 107 | *) 108 | Require Import QArith. 109 | Require Import QArith.Qcanon. 110 | Search Qc. 111 | Print Scope Q_scope. 112 | 113 | (*Print Scope Qc_scope.*) 114 | Check Q2Qc. 115 | 116 | Require Import Ascii. 117 | Print ascii. 118 | 119 | Require Import ZArith. 120 | 121 | Open Scope Z_scope. 122 | 123 | Goal forall x, x < x + 1. lia. Qed. 124 | 125 | Compute 1 / 2. 126 | Compute 2/2. 127 | 128 | (* Goal forall x, 2 * (x / 2) <= x. Aborted. *) 129 | Print Scope Q_scope. 130 | Print Qle. 131 | Goal forall (x y : Z) (z : positive), (x <= y) -> ((x # z) <= (y # z))%Q. intros. unfold Qle. simpl. nia. Qed. 132 | Search "div". 133 | Compute -8 / 4. 134 | Search Z.div. 135 | Print Hint *. 136 | Goal forall n m c, n > 0 -> m <= c * n -> (m / n) <= c. intros. Search ((_ / _) <= _). apply Z.div_le_upper_bound. lia. lia. Qed. 137 | 138 | 139 | Search (positive -> Z). 140 | Definition approx ( x : Q) (d : positive) : Q := ((x.(Qnum) * (Zpos d)) / Zpos (x.(Qden))) # d. 141 | | _ => 142 | Compute approx (1 # 4) 8. 143 | Compute approx (1 # 4) 13. 144 | Search Z.div. 145 | 146 | Lemma div_lemma : forall x y z, y > 0 -> z * y <= x + y -> z <= 1 + x / y. intros. pose Z.mul_div_le. 147 | 148 | Lemma appox_lemma : forall x d, (x - (1 # d) <= (approx x d) <= x )%Q. 149 | Proof. 150 | intros. split. Focus 2. 151 | unfold approx. unfold Qle. simpl. Search Z.div. Search ( _ * _ = _ * _ ). rewrite ( Z.mul_comm _ (Z.pos (Qden x))). 152 | 153 | Require Import Psatz. 154 | Search ( _ * (_ / _) ). apply Z.mul_div_le. Search (0 < Zpos _). auto with zarith. 155 | Search Qle. assert ( forall x y z, x <= z + y -> x - y <= z)%Q. intros. lra. apply H. unfold Qle. unfold approx. simpl . clear H. assert ((((Qnum x) * Z.pos d) `div` Z.pos (Qden x)) * Z.pos (Qden x) <= ((Qnum x) * Z.pos d)). Search Z.div. 156 | 157 | 158 | Check Z.div_le_lower_bound. pose (Z.div_le_lower_bound (x.(Qnum) * (Zpos d)) (Zpos (x.(Qden))) . unfold Qle. unfold Qge. split. simpl. 159 | 160 | 161 | Compute (div 1 2). 162 | 163 | 164 | forall x, 165 | 166 | 167 | 168 | Open Scope Q_scope. 169 | Print Q. 170 | Locate positive. 171 | 172 | Require Import Ring. 173 | Print Scope positive_scope. 174 | (* If you need more than 1/ 2^128 sized dt, what are you even doing? *) 175 | Print Module QArith. 176 | Definition dt_spec := Eval cbv in Qinv (Qmake (Z.shiftl 1 128) 1). 177 | Print dt_spec. 178 | (* Definition dt_spec : Q := ( 1 # 100 ). *) 179 | Print dt_spec. 180 | (* The differnetial equations xdot = x *) 181 | Definition next_spec (x : Q) := (1 + dt_spec) * x. 182 | Definition step2 (x : Q) : Q := next_spec (next_spec x). 183 | Search (Q -> Q). 184 | Definition approx (x : Q) : Q := (Pos.shiftl 1 128) * x 185 | 186 | Definition step2' (x : Q) : {z : Q| exists e, 0 <= e /\ z <= (step2 x) + e /\ (step2 x) - e <= z }. {| Qnum := _ ; Qden := (Pos.shiftl 1 128) |}. 187 | Compute next_spec 1. 188 | Eval cbn in fun x => next_spec (next_spec x). 189 | 190 | 191 | 192 | 193 | 194 | Check {x : Q | x.(Qden) = 100%positive}. 195 | 196 | Definition Fixed n := {x : Q | x.(QDen) = n}. 197 | 198 | Definition approx_add (x y : Fixed 100) : {z : Fixed 100 | exists e, 199 | x + y == z * (1 + e)}. 200 | 201 | Definition approx_add (x y : Q) (p : x.(Qden) = 100%positive): {z : Q | exists e, x + y == z * (1 + e) (* /\ z.(Qden) = 100%positive *) }. eexists. exists 0. cbn. ring_simplify. auto. unfold "==". auto. Qed. 202 | 203 | Definition approx_add x y : {z : Q | exists e, x + y == z * (1 + e) }. 204 | 205 | 206 | Print Z. 207 | Print Q. 208 | 209 | Search (Z -> _ -> Z). 210 | Eval cbv in Z.shiftl 1 8. 211 | Definition dt_spec := Eval cbv in Qinv (Qmake (Z.shiftl 1 8) 1). 212 | Print dt_spec. 213 | Definition dt_spec : Q := ( 1 # 100 ). 214 | 215 | Print Q. 216 | Require Import Ascii. 217 | 218 | let branch t = if t = 'a' then 'a' 219 | else if t = 'b' then 'b' 220 | else if t = 'c' then b 221 | else failwith "unexpected token" 222 | let fast_branch = if ('a' <= t && t <= 'c' the return t else failwith "unexpected token" 223 | 224 | 225 | 226 | 227 | 228 | (* The differnetial equations xdot = x *) 229 | Definition next_spec (x : Q) := x + x * dt_spec. 230 | 231 | (* This is the recursion principle for nat *) 232 | Fixpoint iterate {a} (n : nat) (f : a -> a) (x0 : a) := 233 | match n with 234 | | O => x0 235 | | S n' => iterate n' f (f x0) 236 | end. 237 | 238 | 239 | Eval vm_compute in iterate 9 next_spec 1. (* getting slow around 10 240 | The exponential is doubling with every op. *) 241 | 242 | Close Scope Q_scope. 243 | 244 | Definition dt_spec : Q := ( 1 # 100 ). 245 | 246 | Print Q. 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | (* The differnetial equations xdot = x *) 255 | Definition next_spec (x : Q) := x + x * dt_spec. 256 | 257 | (* This is the recursion principle for nat *) 258 | Fixpoint iterate {a} (n : nat) (f : a -> a) (x0 : a) := 259 | match n with 260 | | O => x0 261 | | S n' => iterate n' f (f x0) 262 | end. 263 | 264 | 265 | Eval vm_compute in iterate 9 next_spec 1. (* getting slow around 10 266 | The exponential is doubling with every op. *) 267 | 268 | Close Scope Q_scope. 269 | Open Scope Qc_scope. 270 | 271 | Definition dt_spec : Qc := Q2Qc ( 1 # 100 ). 272 | 273 | 274 | (* The differnetial equations xdot = x *) 275 | Definition next_spec (x : Qc) := x + x * dt_spec. 276 | 277 | (* This is the recursion principle for nat *) 278 | Fixpoint iterate {a} (n : nat) (f : a -> a) (x0 : a) := 279 | match n with 280 | | O => x0 281 | | S n' => iterate n' f (f x0) 282 | end. 283 | 284 | 285 | 286 | 287 | Search (nat -> (_ -> _) -> _). 288 | Search (Q -> Q). 289 | 290 | Eval vm_compute in decide (0 <= dt_spec). 291 | Eval vm_compute in decide (0 = dt_spec). 292 | 293 | 294 | 295 | Require Import Psatz. 296 | 297 | Goal (0 <= 1)%Q. lra. Qed. 298 | Goal (0 <= 1). fourier. Abort. (* lra doesn't work on Qc? That super sucks. *) 299 | 300 | 301 | Definition myabs x := if decide (0 <= x) then x else - x. 302 | Search Qc. 303 | 304 | 305 | 306 | Goal forall x, (myabs (myabs x)) = x. intros. unfold myabs. destruct (decide (0 <= x)). destruct (decide (0 <= x)). auto. apply n in q. destruct q. destruct (decide (0 <= -x)). Search (- _ <= - _). apply Qcopp_le_compat in q. Search (- 0). Search (- - _). rewrite Qcopp_involutive in q. 307 | 308 | 309 | (* 310 | 311 | Approximate by epsilon 312 | Qabs 313 | 314 | 315 | *) 316 | 317 | 318 | (* If we parametrize over dt, we are in some ense allowing the differential limit 319 | 320 | 321 | *) 322 | 323 | 324 | p_count_as_opt = 325 | (λ (st : () * ()) (input : stream (ocaml_stream ascii) ascii), 326 | let 327 | '(_, m_st', st') := 328 | ocaml_peek (ascii * () * ocaml_stream ascii) (let (state, _, _, _) := input in state) 329 | (λ ot : option ascii, 330 | match ot with 331 | | Some t => 332 | if ocaml_eq t "a"%char 333 | then 334 | ocaml_drop (ascii * () * ocaml_stream ascii) (let (state, _, _, _) := input in state) 335 | (λ state_str : ocaml_stream ascii, ("a"%char, let (x, _) := st in x, state_str)) 336 | else failwith "parse_exact: Unexpected Token!" 337 | | None => failwith "Unexpected EOF!" 338 | end) in 339 | (fix 340 | rec_v (n : nat) (H : Type) (k' : nat → () → option as_tok * () * ocaml_stream ascii → H) 341 | (m_st : ()) (stream_st : option as_tok * () * ocaml_stream ascii) {struct n} : H := 342 | match n with 343 | | 0 => failwith "out of gas!" 344 | | S m => 345 | match stream_st with 346 | | (Some t, _, _) => 347 | if ocaml_eq t A 348 | then 349 | let 350 | '(_, m_st'0, st'0) := 351 | let 352 | '(_, m_st0, str') := stream_st in 353 | ocaml_peek (as_tok * () * (option as_tok * () * ocaml_stream ascii)) str' 354 | (λ ot : option ascii, 355 | match ot with 356 | | Some _ => 357 | let 358 | '(_, m_st'0, st'0) := 359 | ocaml_peek (ascii * () * ocaml_stream ascii) st' 360 | (λ ot0 : option ascii, 361 | match ot0 with 362 | | Some t1 => 363 | if ocaml_eq t1 "a"%char 364 | then 365 | ocaml_drop (ascii * () * ocaml_stream ascii) st' 366 | (λ state_str : ocaml_stream ascii, 367 | ("a"%char, m_st0, state_str)) 368 | else failwith "parse_exact: Unexpected Token!" 369 | | None => failwith "Unexpected EOF!" 370 | end) in (A, m_st, (Some A, m_st'0, st'0)) 371 | | None => (A, m_st, (None, m_st0, str')) 372 | end) in 373 | let 374 | '(o2, m_st'1, st'1) := 375 | rec_v m (nat * () * (option as_tok * () * ocaml_stream ascii))%type 376 | (λ (o2 : nat) (m_st'1 : ()) (st'1 : option as_tok * () * ocaml_stream ascii), 377 | (o2, m_st'1, st'1)) m_st'0 st'0 in k' (S o2) m_st'1 st'1 378 | else k' 0 m_st stream_st 379 | | (None, _, _) => k' 0 m_st stream_st 380 | end 381 | end) max_int nat (λ (o0 : nat) (_ : ()) (_ : option as_tok * () * ocaml_stream ascii), o0) 382 | (let (_, y) := st in y) (Some A, m_st', st')) 383 | -------------------------------------------------------------------------------- /realvec.v: -------------------------------------------------------------------------------- 1 | Require Import Reals. 2 | 3 | Open Scope R_scope. 4 | Inductive V0 (A : Type) : Type := V0Make. 5 | (* Inductive V1 (A : Type) : Type := V1Make : A -> V1 A. *) 6 | 7 | Record V1 {A : Type} := { v : A }. 8 | Check Build_V1 R 3. 9 | Hint Constructors V1. 10 | 11 | Class Count (a : Type) := { 12 | count : nat 13 | }. 14 | Open Scope nat. 15 | Instance unitCount : Count unit := { 16 | count := 1%nat 17 | }. 18 | 19 | Instance sumCount a b `{Count a} `{Count b} : Count (a + b) := 20 | { 21 | count := count + count 22 | }. 23 | 24 | Instance prodCount a b `{Count a} `{Count b} : Count (a * b) := 25 | { 26 | count := count * count 27 | }. 28 | Instance boolCount : Count bool := 29 | { 30 | count := 2 31 | }. 32 | 33 | 34 | Class Enum (a : Type) `{c : Count a} := { 35 | toNat : a -> nat 36 | }. 37 | 38 | Instance unitEnum : Enum unit := { 39 | toNat := fun _ => 0 40 | }. 41 | Print sum. 42 | Instance plusEnum {a b : Type} `{ea : Enum a} `{eb : Enum b} : Enum (a + b) := 43 | { toNat := fun x => match x with 44 | | inl a => toNat a 45 | | inr b => (toNat b) + count (a := a) 46 | end 47 | 48 | }. 49 | 50 | Compute toNat (a := (unit + unit)) (inr tt). 51 | 52 | Check @count. 53 | Compute count (a := unit * unit). 54 | (* Compute count unitCount. *) 55 | 56 | Open Scope nat. 57 | Definition isdiv f := forall x y z, z * y <= x <-> z <= f x y. 58 | Definition isdivy f y := forall x z, z * y <= x <-> z <= f x. 59 | (* 60 | It's strange. it's a spec for div. We don't need to assume a unique div op. 61 | 62 | 63 | *) 64 | Require Import Psatz. 65 | 66 | Goal forall x y, x <= y <= x -> x = y. intros. destruct H. Search ( _ <= _ -> _ <= _ -> _ = _). apply Nat.le_antisymm; auto. Qed. 67 | 68 | Definition islog f := forall x z, 2 ^ z <= x <-> z <= f x. 69 | Goal forall f, islog f -> f 1 = 0. intros. apply Nat.le_antisymm. unfold islog in H. auto with arith. Focus 2. unfold islog in H. apply H. simpl. constructor. assert (f 1 <= f 1). lia. apply H in H0. assert (forall x, 2 ^ x >= 1). intros. auto with arith. induction x. simpl. lia. simpl. lia. destruct (f 1). lia. simpl in H0. assert False. ring_simplify in H0. assert (2 * 1 <= 2 * 2^n ) . Search (_ * _ <= _ * _). apply Nat.mul_le_mono_l. apply H1. lia. destruct H2. Qed. 70 | 71 | (* what a mess *) 72 | 73 | Theorem pospow : forall y, 1 <= 2 ^ y. intros. auto with arith. Search (_ ^ _). assert (1 ^ y <= 2 ^ y). apply Nat.pow_le_mono_l. lia. Search (1 ^ _). rewrite Nat.pow_1_l in H. auto. Qed. 74 | 75 | Goal forall f y, islog f -> (y <= f 1 <-> y <= 0). intros. unfold islog in H. split. intros. apply H in H0. destruct y. lia. simpl in H0. pose (pospow y). lia. intros. apply H. assert ( y = 0). lia. rewrite H1. simpl. lia. Qed. 76 | 77 | (* 78 | Ok, a key fact is that 2^n is monotonic. That makes sense. 79 | 80 | 2^x <= 81 | 82 | 83 | 84 | *) 85 | 86 | 87 | Record Iso {A} {B} (f : A -> B) (g : B -> A) := { to : forall x, f (g x) = x ; 88 | from : forall y, g (f y) = y 89 | }. 90 | Definition id {A : Type} (x : A) := x. 91 | 92 | Goal forall A, Iso (A:= A) id id. constructor; intros; unfold id; reflexivity. Qed. 93 | 94 | 95 | 96 | 97 | Theorem thingo : {n : nat | n <= 0}. exists 0. auto. Qed. 98 | (* 99 | Goal Iso (A := unit) (B := {n : nat | Nat.le n 0}) (fun _ => thingo ) (fun _ => tt). constructor. intros. destruct x. destruct x. destruct thingo. destruct x. 100 | *) 101 | 102 | (* 103 | 104 | 105 | isomorphism between n <= m and 106 | 107 | Program Instance let's you fill in partial typeclasses 108 | 109 | *) 110 | 111 | Compute count. 112 | Compute count. 113 | 114 | (* I'm of half a mind to just use pair. *) 115 | Close Scope nat. 116 | 117 | Inductive V2 (A : Type) : Type := V2Make : A -> A -> V2 A. 118 | Inductive Kron (f : Type -> Type) (g : Type -> Type) (a : Type) := MkKron : (f (g a)) -> Kron f g a. 119 | Inductive DSum (f : Type -> Type) (g : Type -> Type) (a : Type) := MkDSum : f a -> g a -> DSum f g a. 120 | (* Definition kron f g a := f ( g a) 121 | Definition V2 a := (a,a) 122 | 123 | *) 124 | 125 | Require Import Psatz. 126 | Definition convex f := forall x y l, 0 <= l <= 1 -> f((1 - l) * x + l * y) <= (1 - l) * f x + l * f y. 127 | Goal convex (fun x => x). unfold convex. intros. lra. Qed. 128 | 129 | Theorem cert1 : forall a x l c, a * x >= 0 -> l >= 0 -> l * a = c -> c * x >= 0. 130 | Proof. intros. assert (l * (a * x) >= l * 0). Search (_ * _ >= _ * _). apply Rmult_ge_compat_l; auto. ring_simplify in H2. rewrite H1 in H2. auto. Qed. 131 | 132 | Definition convex2 f := forall x y lx ly, 0 <= lx <= 1 -> 0 <= ly <= 1 -> lx + ly = 1 -> f(lx * x + ly * y) <= lx * f x + ly * f y. 133 | (* Definition convex f := forall x y l, 0 <= l <= 1 -> f((1 - l) * x + l * y) <= (1 - l) * f x + l * f y. *) 134 | Goal convex (fun x => x * x). unfold convex. intros. psatz R . Qed. 135 | (* Note on compling csdp for mac os x. i had to remove static flag from flags 136 | and export CC=gcc-9 137 | *) 138 | 139 | Goal forall x, (x * x - 7 * x + 9) ^ 2 >= 0. intros. ring_simplify. (* blow it up *) 140 | try nia. try psatz R. Qed. 141 | 142 | 143 | Goal convex (fun x => x * x). unfold convex. intros. ring_simplify. assert (l ^ 2 <= l). nra. assert ((x - y)^2 >= 0). assert (Rsqr (x - y) = (x - y)^2). unfold Rsqr. simpl. ring. rewrite <- H1. auto with real. nra. Qed. 144 | 145 | Definition epigraph (f : R -> R) (x : R) y := (f x) <= y. 146 | 147 | 148 | (* 149 | compositional rules of convexity 150 | 151 | positive Scalar multiples are convex 152 | composition rule 153 | 154 | 155 | 156 | *) 157 | Goal forall a f, a >= 0 -> convex f -> convex (fun x => a * (f x)). Abort. 158 | 159 | (* quite an opaque proof as written 160 | https://math.stackexchange.com/questions/580856/proof-of-convexity-of-fx-x2 161 | 162 | 163 | 164 | 165 | *) 166 | 167 | 168 | 169 | (* Search (_ + _ <= _ + _). apply Rplus_le_compat_r. assert (lx * x * ly * y <= 0). psatz R 2. 170 | *) 171 | 172 | 173 | (* 174 | 175 | Definition min 176 | 177 | 178 | Given a dual certificate 179 | prove minimality of 180 | 181 | we can do the 1d version, and the 2d version. 182 | cert : A * x >= 0 -> l >= 0 -> l * A = c -> c x >= l a 183 | 184 | ocaml-python 185 | sympy tactic 186 | 187 | find formula using sympy, assert it's truth. 188 | 189 | use python solve. 190 | esympy 191 | 192 | *) 193 | 194 | Definition vsumv1 x y := Build_V1 (v x + v y). 195 | Definition smulv1 s x := Build_V1 (s *(v x)). 196 | Definition vzerov1 : V1 := Build_V1 R 0. 197 | Check vzerov1. 198 | Check vzerov1. 199 | (* Check vsumv1 vzerov1 vzerov1. *) 200 | 201 | 202 | 203 | 204 | (* We need to get the ring theory in there. *) 205 | (* 206 | Class Linear (f : Type -> Type) := { 207 | vsum : f R -> f R -> f R ; 208 | smul : R -> f R -> f R; 209 | vzero : f R; 210 | 211 | 212 | }. 213 | *) 214 | 215 | 216 | Class LinOps (v : Type) := { 217 | vsum : v -> v -> v; 218 | smul : R -> v -> v; 219 | vzero : v; 220 | 221 | 222 | }. 223 | Require Import Program.Tactics. 224 | Class Linear (a : Type) `{l : LinOps a} := { 225 | dist_smul : forall x y s, smul s (vsum x y) = vsum (smul s x) (smul s y); 226 | assoc_vsum : forall x y z, vsum (vsum x y) z = vsum x (vsum y z); 227 | assoc_smul : forall s s' v, smul s (smul s' v) = smul (s * s') v; 228 | dist_smul2 : forall s s' v, smul (s + s') v = vsum (smul s v) (smul s' v); 229 | vsum_comm : forall x y, vsum x y = vsum y x; 230 | smul_id : forall v, smul 1 v = v; 231 | vzero_id : forall v, vsum v vzero = v 232 | }. 233 | 234 | Print Linear. 235 | 236 | Notation "s *^ v" := (smul s v) (at level 75, right associativity). 237 | Notation "v ^+^ w" := (vsum v w) (at level 70, right associativity). 238 | Locate "+". 239 | Locate "*". 240 | Instance linOpsR : (LinOps R) := { 241 | vsum := Rplus; 242 | smul := Rmult; 243 | vzero := 0%R 244 | 245 | }. 246 | 247 | Instance linearR : (Linear R). split; intros; simpl; lra. Qed. 248 | 249 | 250 | Print linearR. 251 | Print vsum. 252 | (* Print HintDb typeclass_instances. *) 253 | 254 | 255 | (* 256 | Set Typeclasses Debug. 257 | 258 | a -> Prop is morally very much like a -> bool 259 | The difference is in decidability questions, which aren't really where I play 260 | Coq has way more introspection into a -> bool than a runtime/haskell/evulation only model does. It can see the textual definition. 261 | 262 | 263 | Definition MySet a := a -> Prop 264 | Definition MyRel a b := (a -> Prop) -> (b -> Prop) -> Prop 265 | Definition MyPro a b := (a -> bool) -> list b -> 266 | (a -> Prop) -> Prop ? Partialy applied 267 | (a -> bool) -> bool -- finitely probing? 268 | (a -> Prop) -> a 269 | 270 | 271 | class Canon a where 272 | canon :: a -> a 273 | 274 | canonicalizing a relationship for quotienting. Very natrual 275 | 276 | 277 | 278 | DSum f g = (f,g) -- no i already did this. 279 | 280 | Solving systems -- QR is easiest. 281 | 282 | Duality 283 | A x == 0 284 | A^T l == 0 285 | 286 | [x,y,z...] = 0 287 | 288 | 289 | f f = identity matrix 290 | 291 | 292 | Class basisOps v := { 293 | basis : list v {- list is a little weak 294 | } 295 | Laws? 296 | Class basis v := { 297 | complete : forall v, exists l, v = vsum smul l basis 298 | independnet : not (exists l vsum basis = head basis) 299 | } 300 | 301 | 302 | complete : sum u u = x 303 | orthonormal : 304 | 305 | 306 | instance basis R { 307 | basis = [1] 308 | } 309 | 310 | instance basis unit { 311 | basis = [] 312 | } 313 | instance basis (x,y) { 314 | basis = (map dsum vzero basis) append (map dsum x vzero basis) 315 | orthonormal = forall u1 u2, u1 elem basis, u2 elem basis, Reflect (dot u1 u2 ?= 1) (u1 = u2) 316 | 317 | } 318 | 319 | 320 | 321 | instance Outer R x := x 322 | 323 | instance Outer Unit x = Unit 324 | 325 | instance Outer (a,b) x := Outer a x, Outer ta x := 326 | 327 | 328 | 329 | 330 | 331 | class Scalar {} 332 | 333 | 334 | 335 | 336 | 337 | 338 | *) 339 | 340 | Instance linopsunit : (LinOps unit) := { 341 | vsum := fun _ _ => tt; 342 | smul := fun _ _ => tt; 343 | vzero := tt 344 | }. 345 | 346 | Instance linearunit : (Linear unit). split; intros; simpl; auto; destruct v0. auto. auto. Qed. 347 | 348 | 349 | 350 | Instance linopspair a b `{LinOps a} `{LinOps b} : LinOps (a * b) := 351 | { 352 | 353 | vsum := fun v1 v2 => ( (fst v1) ^+^ (fst v2) , (snd v1) ^+^ (snd v2 )); 354 | smul := fun s v => ( s *^ (fst v) , s *^ (snd v)); 355 | vzero := (vzero, vzero) 356 | }. 357 | 358 | 359 | Instance linearpair a b `{lina : Linear a} `{ linb : Linear b} : Linear (a * b). destruct lina. destruct linb. split; intros; simpl; try congruence. 360 | - destruct v0. simpl. rewrite smul_id1; rewrite smul_id0; auto. 361 | - destruct v0. simpl. rewrite vzero_id1; rewrite vzero_id0; auto. 362 | Qed. 363 | 364 | Print nat. 365 | 366 | 367 | 368 | Fixpoint V (n : nat) := match n with 369 | | O => unit 370 | | S n' => prod R (V n') 371 | end. 372 | 373 | Compute (vzero : (V 4)). 374 | Compute (vzero : (V 5)). 375 | 376 | Theorem vzero_id_l A `{l : Linear A} (v : A) : vsum vzero v = v. 377 | Proof. rewrite vsum_comm. rewrite vzero_id. auto. Qed. 378 | 379 | 380 | (* 381 | Norm? 382 | Metric 383 | 384 | I shouldn't call these metric. Hilbert maybe? 385 | 386 | *) 387 | 388 | Class MetricOps v `{LinOps v} := { 389 | dot : v -> v -> R 390 | }. 391 | 392 | Class Metric v `{MetricOps v} `{Linear v} := { 393 | pos_dot : forall v, 0 <= dot v v; 394 | sym_dot : forall v w, dot v w = dot w v; 395 | lin_dot : forall v w u, dot v (w ^+^ u) = (dot v w) + (dot v u); 396 | lin_dot2 : forall v w s, dot v (s *^ w) = s * (dot v w) 397 | 398 | }. 399 | 400 | Instance metopunit : MetricOps unit := { 401 | dot := fun _ _ => 0 402 | }. 403 | 404 | Instance metopreal : MetricOps R := { dot := fun x y => x * y }. 405 | 406 | Instance metoprod a b `{MetricOps a} `{MetricOps b} : MetricOps (a * b) := { 407 | dot := fun x y => (dot (fst x) (fst y)) + (dot (snd x) (snd y)) }. 408 | 409 | Instance metricunit : Metric unit. 410 | split; auto with real. Qed. 411 | 412 | Search (0 <= Rsqr _). 413 | 414 | 415 | 416 | Instance metricreal : Metric R. 417 | split; intros; simpl; nra. Qed. 418 | 419 | Instance metricprod a b `{ma : Metric a} `{mb : Metric b} : Metric (a * b). 420 | Proof. 421 | destruct ma. destruct mb. split; intros; simpl. 422 | - simpl. Search (0 <= _ + _). apply Rplus_le_le_0_compat; auto. 423 | - simpl. rewrite sym_dot0. rewrite sym_dot1. auto. 424 | - simpl. rewrite lin_dot0. rewrite lin_dot1. simpl. lra. 425 | - simpl. rewrite lin_dot3. rewrite lin_dot4. simpl. lra. 426 | Qed. 427 | 428 | 429 | Definition Cone {A} `{Linear A} (P : A -> Prop) := forall l v, P v -> l >= 0 -> P (smul l v). 430 | Goal Cone (fun x => x >= 0). unfold Cone. intros. simpl. nra. Qed. 431 | Goal Cone (fun (v : R*R) => let ( x, y ) := v in x >= 0 /\ y >= 0). unfold Cone. simpl. intros. destruct v0. simpl. nra. Qed. 432 | Goal forall {a} `{la : Metric a} (w : a), Cone (fun v => dot w v >= 0). 433 | intros. unfold Cone. intros. rewrite lin_dot2. nra. Qed. 434 | 435 | 436 | Class Quadrant a `{Linear a} := { quadrant : a -> Prop; conequad : Cone quadrant}. 437 | Instance quadr : Quadrant R := { quadrant := fun x => x >= 0}. 438 | unfold Cone. intros. simpl. nra. Qed. 439 | 440 | Instance quadprod a b `{Quadrant a} `{Quadrant b} : Quadrant (a * b) := {quadrant := fun x => quadrant (fst x) /\ quadrant (snd x) }. 441 | unfold Cone. intros. simpl. destruct H3. split; apply conequad; auto. Qed. 442 | 443 | Theorem cone_conj : forall P Q, Cone P -> Cone Q -> Cone (fun x => P x /\ Q x). 444 | intros. unfold Cone. intros. destruct H1. split; auto. Qed. 445 | 446 | Definition DualCone {A} `{Metric A} (P : A -> Prop) := fun w => forall x, P x -> dot w x >= 0. 447 | 448 | Theorem dcone : forall A `{Metric A} (P : A -> Prop), Cone (DualCone P). intros. unfold Cone. intros. unfold DualCone. intros. rewrite sym_dot. rewrite lin_dot2. rewrite sym_dot. 449 | 450 | (* 451 | 452 | Contlens 453 | | _ => : Is this constructive point-wise continuity? 454 | 455 | Contructive cones. 456 | (a -> Prop) -> Prop 457 | feels rather non contrusctive (I wouldn't necessarily want this in Haskell) 458 | cone :: (a -> Bool) -> Bool would never be a function I write 459 | 460 | Why not list? 461 | Need to trim upper zeros. That's not so bad 462 | 463 | 464 | 465 | 466 | 467 | 468 | 469 | *) 470 | 471 | Search R. 472 | Require Import QArith. 473 | Search (Q -> Q -> bool). 474 | Print Scope Q_scope. 475 | Print Qeq. 476 | Print Qeq_bool. 477 | Search nil. 478 | Print list. 479 | Close Scope R. 480 | 481 | Fixpoint trimzero (l : list Q) : list Q := match l with 482 | | List.cons x xs => if (Qeq_bool 0 x)%Q then trimzero xs else l 483 | | List.nil => List.nil 484 | end. 485 | Definition canonlist l : list Q := List.rev (trimzero (List.rev l)). 486 | 487 | Compute canonlist (List.cons 1 (List.cons 0 (List.nil))). 488 | 489 | 490 | Fixpoint vsumlist l l' := match l, l' with 491 | | List.cons x xs, List.cons y ys => List.cons (x + y) (vsumlist xs ys) 492 | | List.nil, ys => ys 493 | | xs, List.nil => xs 494 | end. 495 | Definition vzerolist {A} := @List.nil A. 496 | 497 | Definition smullist s l := List.map (fun x => s * x) l. 498 | 499 | (* 500 | 501 | list is ambiently in an infinite dimensional space with finite nonzeros. 502 | 503 | *) 504 | 505 | Compute trimzero (List.cons 0 List.nil). 506 | 507 | 508 | 509 | (* 510 | 511 | Quadrant 512 | Elementwise 513 | Functor 514 | 515 | *) 516 | 517 | 518 | 519 | 520 | 521 | Compute ((1,2), 4) ^+^ ((1,3), 8). 522 | 523 | Goal forall x y : R, (x ^+^ y) = (y ^+^ x). intros. auto with real. Qed. 524 | Goal forall x y : R * R, (x ^+^ y) = (y ^+^ x). intros. destruct x. destruct y. unfold vsum. simpl. auto with real. 525 | 526 | (* 527 | Definition LinFun {Linear a} {Linear b} a b := {f : a -> b | f (vsum a a') = vsum (f a) (f a') /\ 528 | f (smul x a) = smul x (f a) } 529 | *) 530 | 531 | 532 | (* 533 | dist_smul : forall x y s, smul s (vsum x y) = vsum (smul s x) (smul s y); 534 | assoc_vsum : forall x y z, (vsum (vsum x y) z) = vsum (vsum x y) z; 535 | assoc_smul : forall s s' v, smul s (smul s' v) = smul (s * s') v; 536 | dist_smul2 : forall s s'smul (s + s') v = vsum (smul s v) (smul s' v); 537 | vsum_comm : vsum x y = vsum y x; 538 | smul_id : smul 1 v = v; 539 | vzero_id : vsum v vzero = v 540 | *) 541 | 542 | 543 | 544 | 545 | 546 | Definition cone P := forall l, l >= 0 -> P x -> P (l ^* x). 547 | 548 | Program Instance linearV1 : Linear V1 := { 549 | 550 | smul s v := match v with 551 | | (V1Make _ x) => V1Make _ (s * x) 552 | end; 553 | vzero := V1Make _ 0 554 | dist_smul := 555 | }. 556 | 557 | 558 | 559 | Instance linearDSum (f : Type -> Type) (g : Type -> Type) `{Linear f} `{Linear g} : Linear (DSum f g) nat := { 560 | vsum := fun v w => match v,w with 561 | | (MkDSum _ _ _ f g), (MkDSum _ _ _ f' g') => MkDSum _ _ _ (f ^+^ f') (g ^+^ g') 562 | end; 563 | smul s v := match v with 564 | | (MkDSum _ _ _ f g) => MkDSum _ _ _ (s *^ f) (s *^ g) 565 | end; 566 | vzero := MkDSum _ _ _ vzero vzero 567 | }. 568 | 569 | Definition v1one := V1Make _ 1. 570 | Compute v1one ^+^ v1one. 571 | Definition v2one := MkDSum _ _ _ v1one v1one. 572 | Compute v2one ^+^ v2one. 573 | 574 | 575 | (* 576 | 577 | 578 | Compute (1)%R. 579 | Compute (1 + 1)%R. 580 | Local Open Scope R_scope. 581 | 582 | Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. 583 | Proof. 584 | destruct 1. red. auto with real. auto with real. 585 | Qed. 586 | 587 | Lemma Rle_refl : forall r, r <= r. 588 | Proof. 589 | intro. red. right. reflexivity. 590 | Qed. 591 | 592 | 593 | Lemma Rge_refl : forall r, r <= r. 594 | Proof. intro. right. reflexivity. Qed. 595 | (* Proof. exact Rle_refl. Qed. *) 596 | 597 | Print Rlt_asym. 598 | Lemma Rlt_irrefl : forall r, ~ r < r. 599 | Proof. 600 | intros r H. eapply Rlt_asym. apply H. apply H. 601 | Qed.Lemma Rlt_irrefl : forall r, ~ r < r. 602 | 603 | 604 | 605 | (* Solution at https://github.com/coq/coq/blob/master/theories/Reals/RIneq.v 606 | I should try to do them on my own 607 | *) 608 | Theorem square_pos : forall (x : R), 0 <= Rmult x x. 609 | Proof. 610 | (* 611 | apply Rle_0_sqr. 612 | Qed. *) 613 | intros r. 614 | Print Hint. 615 | case (Rlt_le_dec r 0). 616 | intro H. 617 | replace (r * r) with (- r * - r). 618 | auto with real. (* This is not working *) 619 | 620 | About Rlt_le_dec. 621 | auto with real. 622 | 623 | destruct (total_order_T x 0). 624 | destruct s. 625 | 626 | 627 | Rmult_lt_compat_l. 628 | 629 | 630 | (** 631 | 632 | Define LinOp 633 | record LinOp 634 | 635 | define contractive as 636 | |A v| <= |v| 637 | 638 | prove using complete basis 639 | Chain them 640 | 641 | Define polytope region using corner 642 | show that goes inside region in fitie time 643 | 644 | Define V1 V2 Product and Compose 645 | 646 | define Vector space type class 647 | vadd 648 | smul 649 | 650 | 651 | 652 | 653 | *) 654 | 655 | *) 656 | --------------------------------------------------------------------------------