day's work

1 files changed, 207 insertions, 8 deletions

diff --git a/work/funcdiff_play.scm b/work/funcdiff_play.scm
index f447253..18c72e5 100644
--- a/work/funcdiff_play.scm
+++ b/work/funcdiff_play.scm
@@ -85,6 +85,7 @@
 
 ;;; Feb 2
 
+#|
 (define (vector-field-procedure components coordinate-system)
   (define (the-procedure f)
     (compose (* (D (compose f (coordinate-system '->point)))
@@ -92,9 +93,10 @@
 	     (coordinate-system '->coords)))
   the-procedure)
 
-(define (components->vecotr-field components coordinate-system)
+(define (components->vector-field components coordinate-system)
   (procedure->vector-field
-   (vector-field-procedure components coordinate-system)))
+   (vector-field-procedure components coordinate-system)
+   'foo))
 
 (define v
   (components->vector-field
@@ -113,6 +115,7 @@
 		      (coordsys '->point))))
       (* ((D f) x) (b x))))
   (make-operator v))
+|#
 
 #|
 (pe (((coordinatize v R2)
@@ -355,17 +358,19 @@
 (define ((vector-field-over-map mu:N->M) v-on-M)
   (procedure->vector-field
    (lambda (f-on-M)
-     (compose (v-on-M f-on-M) mu:N->M))))
+     (compose (v-on-M f-on-M) mu:N->M))
+   'foo))
 
 (define (vector-field-over-map->vector-field V-over-mu n)
   (procedure->vector-field
    (lambda (f)
-     (lambda (m) ((V-over-mu f) n)))))
+     (lambda (m) ((V-over-mu f) n)))
+   'foo))
 
 (define ((form-field-over-map mu:N->M) w-on-M)
   (let ((k (get-rank w-on-M)))
     (procedure->nform-field
-     (lambda vecotrs-over-map
+     (lambda vectors-over-map
        (lambda (n)
 	 ((apply w-on-M
 		 (map (lambda (V-over-mu)
@@ -389,6 +394,200 @@
 	       (literal-function 'beta))
 	   (the-real-line '->coords)))
 
-(define sphere-basis-over-mu
-  (basis->basis-over-map mu sphere-basis))
- 
+(define (((differential mu) v) f)
+  (v (compose f mu)))
+
+;;; Feb 5
+;;; skipped a bit here...
+
+(define setup-P2
+  (lambda ()
+    (define P2 (polar/cylindrical 2))
+    (define P2-chi (P2 '->coords))
+    (define P2-chi-inverse (P2 '->point))
+    (define polar-basis (coordinate-system->basis P2))
+    (instantiate-coordinates P2 '(r theta))))
+
+(setup-R2)
+(define rectangular-basis (coordinate-system->basis R2))
+(setup-P2)
+(define polar-basis (coordinate-system->basis P2))
+
+(define rectangular-Christoffel
+  (make-Christoffel
+   (let ((zero (lambda (m) 0)))
+     (down (down (up zero zero)
+		 (up zero zero))
+	   (down (up zero zero)
+		 (up zero zero))))
+   rectangular-basis))
+
+(define polar-Christoffel
+  (make-Christoffel
+   (let ((zero (lambda (m) 0)))
+     (down (down (up zero zero)
+		 (up zero (/ 1 r)))
+	   (down (up zero (/ 1 r))
+		 (up (* -1 r) zero))))
+   polar-basis))
+
+(define rectangular-Cartan
+  (Christoffel->Cartan rectangular-Christoffel))
+
+(define polar-Cartan
+  (Christoffel->Cartan polar-Christoffel))
+
+(define f
+  (compose (literal-function 'f-rect R2->R) R2-chi))
+
+#|
+(pe (((((covariant-derivative rectangular-Cartan) d/dx)
+       J)
+      f)
+     R2-point))
+
+(pe ((d/dy f) R2-point))
+|#
+
+(instantiate-coordinates the-real-line 't)
+(define M (rectangular 2))
+(instantiate-coordinates M '(theta phi))
+(define M-basis (coordinate-system->basis M))
+
+(define G-S2-1
+  (make-Christoffel
+   (let ((zero (lambda (point) 0)))
+     (down (down (up zero zero)
+		 (up zero (/ 1 (tan theta))))
+	   (down (up zero (/ 1 (tan theta)))
+		 (up (- (+ (sin theta) (cos theta))) zero))))
+   M-basis))
+
+(define gamma:N->M
+  (compose (M '->point)
+	   (up (literal-function 'alpha)
+	       (literal-function 'beta))
+	   (the-real-line '->coords)))
+
+(define basis-over-gamma
+  (basis->basis-over-map gamma:N->M M-basis))
+; this gave me an error; i tried from a blank run and didn't get the error so 
+; I must have clobbered something in this file
+
+; ah, it was easy, i /was/ passing the wrong arguments to 
+; procedure->vector-field
+
+(define w
+  (basis-components->vector-field
+   (up (compose (literal-function 'w0)
+		(the-real-line '->coords))
+       (compose (literal-function 'w1)
+		(the-real-line '->coords)))
+   (basis->vector-basis basis-over-gamma)))
+
+(define sphere-Cartan-over-gamma
+  (Christoffel->Cartan-over-map G-S2-1 gamma:N->M))
+
+#|
+(pe
+ (s:map/r
+  (lambda (omega)
+    ((omega
+      (((covariant-derivative sphere-Cartan-over-gamma)
+	d/dt)
+       w))
+     ((the-real-line '->point) 'tau)))
+  (basis->1form-basis basis-over-gamma)))
+
+|#
+
+(define gamma:N->M
+  (compose (M '->point)
+	   (up (literal-function 'alpha)
+	       (literal-function 'beta))
+	   (the-real-line '->coords)))
+
+#|
+(se
+ (((((covariant-derivative sphere-Cartan-over-gamma) d/dt)
+    ((differential gamma:N->M) d/dt))
+   (M '->coords))
+  ((the-real-line '->point) 't)))
+|#
+
+(define (Lfree s)
+  (* 1/2 (square (velocity s))))
+
+(define (sphere->R3 s)
+  (let ((q (coordinate s)))
+    (let ((theta (ref q 0)) (phi (ref q 1)))
+      (up (* (sin theta) (cos phi))
+	  (* (sin theta) (sin phi))
+	  (cos theta)))))
+
+(define Lsphere
+  (compose Lfree (F->C sphere->R3)))
+
+#|
+(pe (((Lagrange-equations Lsphere)
+      (up (literal-function 'alpha)
+	  (literal-function 'beta)))
+     't))
+|#
+
+(define ((Riemann-curvature Cartan) u v)
+  (let ((nabla (covariant-derivative Cartan)))
+    (- (commutator (nabla u) (nabla v))
+       (nabla (commutator u v)))))
+
+(define sphere-Cartan (Christoffel->Cartan G-S2-1))
+
+(pe (((Riemann sphere-Cartan) dphi d/dtheta d/dphi d/dtheta)
+     ((M '->point) (up 'theta0 'phi0))))
+;1
+
+(define SR (rectangular 4))
+(instantiate-coordinates SR '(t x y z))
+(define an-event ((SR '->point) (up 't0 'x0 'y0 'z0)))
+(define c 'c)
+
+(define (g-Lorentz u v)
+  (+ (* (dx u) (dx v))
+     (* (dy u) (dy v))
+     (* (dz u) (dz v))
+     (* -1 (square c) (dt u) (dt v))))
+
+(define SR-vector-basis
+  (down (* (/ 1 c) d/dt)
+	d/dx
+	d/dy
+	d/dz))
+
+(define SR-1form-basis
+  (up (* c dt) dx dy dz))
+
+(define SR-basis
+  (make-basis SR-vector-basis SR-1form-basis))
+
+(define (Faraday Ex Ey Ez Bx By Bz)
+  (+ (* Ex c (wedge dx dt))
+     (* Ey c (wedge dy dt))
+     (* Ez c (wedge dz dt))
+     (* Bx (wedge dy dz))
+     (* By (wedge dz dx))
+     (* Bz (wedge dx dy))))
+
+(define (Maxwell Ex Ey Ez Bx By Bz)
+  (+ (* -1 Bx c (wedge dx dt))
+     (* -1 By c (wedge dy dt))
+     (* -1 Bz c (wedge dz dt))
+     (* Ex (wedge dy dz))
+     (* Ey (wedge dz dx))
+     (* Ez (wedge dx dy))))
+
+; blah doesn't interpret
+
+(define SR-star
+  (Hodge-star g-Lorentz SR-basis))
+
+(SR-star (Faraday 'Ex 'Ey 'Ez 'Bx 'By 'Bz))