Skip to content

Commit d32f557

Browse files
kloimhardtkloimhardt
authored
FDGCh06 (#324)
1 parent b09749d commit d32f557

File tree

2 files changed

+256
-0
lines changed

2 files changed

+256
-0
lines changed

‎site/_quarto.yml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,8 @@ website:
4747
text: "FDG Chapter 4"
4848
- href: mentat_collective/emmy/fdg_ch05.qmd
4949
text: "FDG Chapter 5"
50+
- href: mentat_collective/emmy/fdg_ch06.qmd
51+
text: "FDG Chapter 6"
5052
- href: mentat_collective/emmy/fdg_ch01_ys.qmd
5153
text: "FDG Ch01 Infix"
5254
- href: mentat_collective/emmy/sicm_ch01.qmd

‎src/mentat_collective/emmy/fdg_ch06.clj‎

Lines changed: 254 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,254 @@
1+
^{:kindly/hide-code true
2+
:clay {:title "Emmy, the Algebra System: Differential Geometry Chapter Six"
3+
:quarto {:author :kloimhardt
4+
:type :draft
5+
:description "Functional Differential Geometry: Chapter 6"
6+
:sidebar "emmy-fdg"
7+
:date "2026-02-09"
8+
:image "sicm_ch01.png"
9+
:category :libs
10+
:tags [:emmy :physics]}}}
11+
12+
(ns mentat-collective.emmy.fdg-ch06
13+
(:refer-clojure :exclude [+ - * / zero? compare divide numerator denominator
14+
time infinite? abs ref partial =])
15+
(:require [scicloj.kindly.v4.api :as kindly]
16+
[scicloj.kindly.v4.kind :as kind]
17+
[mentat-collective.emmy.scheme :refer [define-1 let-scheme lambda] :as scheme]
18+
[civitas.repl :as repl]))
19+
20+
;; ## 6 Over a Map
21+
;; To deal with motion on manifolds we need to think about paths on manifolds and vectors along these paths.
22+
23+
^:kindly/hide-code
24+
(def prod true) #_"used to check Emmy in Scittle kitchen"
25+
26+
^:kindly/hide-code
27+
(kind/hiccup scheme/scittle-kitchen-hiccup)
28+
29+
^:kindly/hide-code
30+
(defmacro define [& b]
31+
(list 'do
32+
(cons 'scheme/define b)
33+
(list 'kind/scittle (list 'quote (cons 'define b)))))
34+
35+
^:kindly/hide-code
36+
(define emmy-env
37+
'[emmy.env :as e :refer :all :exclude [print-expression Lagrangian-action find-path
38+
Lagrange-equations r->p R2 define-coordinates
39+
Jacobian S2 S2-spherical pullback-function
40+
differential pullback-vector-field]])
41+
42+
^:kindly/hide-code
43+
(define emmy-vector-field
44+
'[emmy.calculus.vector-field :as vf])
45+
46+
^:kindly/hide-code
47+
(define emmy-structure
48+
'[emmy.structure :as s])
49+
50+
^{:kindly/hide-code true :kindly/kind kind/hidden}
51+
(do
52+
(require emmy-env)
53+
(require emmy-vector-field)
54+
(require emmy-structure))
55+
56+
^:kindly/hide-code
57+
(kind/scittle
58+
'(do
59+
(require emmy-env)
60+
(require emmy-vector-field)
61+
(require emmy-structure)))
62+
63+
^:kindly/hide-code
64+
(defmacro define-coordinates [& b]
65+
(list 'do
66+
(cons 'emmy.env/define-coordinates b)
67+
(list 'kind/scittle (list 'quote (cons 'emmy.env/define-coordinates b)))))
68+
69+
^:kindly/hide-code
70+
(define string-exp (comp str simplify))
71+
72+
^:kindly/hide-code
73+
(defn reag-comp [b]
74+
(let [server-erg (string-exp (eval b))]
75+
(list 'kind/reagent
76+
[:div (list 'quote
77+
(list 'let ['a (list 'string-exp b)]
78+
[:div
79+
(when (not prod)
80+
[:div
81+
[:tt 'a]
82+
[:p (list 'str (list '= server-erg 'a))]])
83+
[:tt server-erg]]))])))
84+
85+
^:kindly/hide-code
86+
(defmacro print-expression [e]
87+
(if prod
88+
(list 'simplify e)
89+
(reag-comp e)))
90+
91+
^:kindly/hide-code
92+
(kind/scittle
93+
'(def print-expression simplify))
94+
95+
^:kindly/hide-code
96+
(def show-tex-fn (comp kind/tex emmy.expression.render/->TeX))
97+
98+
^:kindly/hide-code
99+
(defmacro show-tex [e]
100+
(if prod
101+
(list 'show-tex-fn e)
102+
(reag-comp e)))
103+
104+
^:kindly/hide-code
105+
(kind/scittle
106+
'(defn show-tex [e]
107+
(->infix e)))
108+
109+
^:kindly/hide-code
110+
(defn show-expression-fn [e]
111+
(kind/tex (str "\\boxed{" (emmy.expression.render/->TeX e) "}")))
112+
113+
^:kindly/hide-code
114+
(defmacro show-expression [e]
115+
(if prod
116+
(list 'show-expression-fn e)
117+
(reag-comp e)))
118+
119+
^:kindly/hide-code
120+
(kind/scittle
121+
'(defn show-expression [e]
122+
(->infix (simplify e))))
123+
124+
;; See Ch3: `procedure->vector-field` not accessible in Scittle,
125+
;; but vector-field->vector-field-over-map is standard
126+
127+
(comment
128+
(define ((vector-field->vector-field-over-map mu:N->M) v-on-M)
129+
(procedure->vector-field
130+
(lambda (f-on-M)
131+
(compose (v-on-M f-on-M) mu:N->M)))))
132+
133+
;; ### Differential of a Map
134+
135+
;; here I use lambda, because my define does not support three nestings
136+
137+
(define ((differential mu) v)
138+
(lambda (f)
139+
(v (compose f mu))))
140+
141+
;; ### 6.2 One-Form Fields Over a Map
142+
(comment
143+
(define ((form-field->form-field-over-map mu:N->M) w-on-M)
144+
(define (make-fake-vector-field V-over-mu n)
145+
(define ((u f) m)
146+
((V-over-mu f) n))
147+
(procedure->vector-field u))
148+
(procedure->nform-field
149+
(lambda vectors-over-map
150+
(lambda (n)
151+
((apply w-on-M
152+
(map (lambda (V-over-mu)
153+
(make-fake-vector-field V-over-mu n))
154+
vectors-over-map))
155+
(mu:N->M n))))
156+
(get-rank w-on-M)))
157+
:end-comment)
158+
159+
;;### 6.3 Basis Fields Over a Map
160+
161+
(define S2 (make-manifold S2-type 2 3))
162+
163+
(define S2-spherical
164+
(coordinate-system-at S2 :spherical :north-pole))
165+
166+
167+
(define-coordinates (up theta phi) S2-spherical)
168+
169+
(define S2-basis (coordinate-system->basis S2-spherical))
170+
171+
(define mu
172+
(compose (point S2-spherical)
173+
(up (literal-function 'theta) (literal-function 'phi))
174+
(chart R1-rect)))
175+
176+
(define S2-basis-over-mu (basis->basis-over-map mu S2-basis))
177+
178+
(define h
179+
(literal-manifold-function 'h-spherical S2-spherical))
180+
181+
(print-expression
182+
(((basis->vector-basis S2-basis-over-mu) h)
183+
((point R1-rect) 't0)))
184+
185+
(print-expression
186+
(((basis->oneform-basis S2-basis-over-mu)
187+
(basis->vector-basis S2-basis-over-mu))
188+
((point R1-rect) 't0)))
189+
190+
;; ### Components of the Velocity
191+
192+
(define-coordinates t e/R1-rect)
193+
194+
(print-expression
195+
(((basis->oneform-basis S2-basis-over-mu)
196+
((differential mu) d:dt))
197+
((point R1-rect) 't0)))
198+
199+
;; ### Pullback and Pushforward of a Function
200+
201+
(define ((pullback-function mu:N->M) f-on-M)
202+
(compose f-on-M mu:N->M))
203+
204+
;; ### Pushforward of a Vector Field
205+
206+
(comment
207+
(define ((pushforward-vector mu:N->M mu-inverse:M->N) v-on-N)
208+
(procedure->vector-field
209+
(lambda (f)
210+
(compose (v-on-N (compose f mu:N->M)) mu-inverse:M->N))))
211+
)
212+
213+
;; ### Pullback of a Vector Field
214+
215+
(define (pullback-vector-field mu:N->M mu-inverse:M->N)
216+
(pushforward-vector mu-inverse:M->N mu:N->M))
217+
218+
219+
;; ### Pullback of a Form Field
220+
221+
(comment
222+
(define ((pullback-form mu:N->M) omega-on-M)
223+
(let ((k (get-rank omega-on-M)))
224+
(if (= k 0)
225+
((pullback function mu:N->M) omega-on-M)
226+
(procedure->nform-field
227+
(lambda vectors-on-N
228+
(apply ((form-field->form-field-over-map mu:N->M)
229+
omega-on-M)
230+
(map (differential mu:N->M) vectors-on-N)))
231+
k))))
232+
)
233+
234+
;; ### Properties of Pullback
235+
236+
(define mu (literal-manifold-map 'MU R2-rect R3-rect))
237+
238+
(define f (literal-manifold-function 'f-rect R3-rect))
239+
240+
(define X (literal-vector-field 'X-rect R2-rect))
241+
242+
(print-expression
243+
(((- ((pullback mu) (d f)) (d ((pullback mu) f))) X)
244+
((point R2-rect) (up 'x0 'y0))))
245+
246+
(define theta (literal-oneform-field 'THETA R3-rect))
247+
248+
(define Y (literal-vector-field 'Y-rect R2-rect))
249+
250+
(print-expression
251+
(((- ((pullback mu) (d theta)) (d ((pullback mu) theta))) X Y)
252+
((point R2-rect) (up 'x0 'y0))))
253+
254+
(repl/scittle-sidebar)

0 commit comments

Comments
 (0)