-
-
Notifications
You must be signed in to change notification settings - Fork 68
/
map.clj
121 lines (110 loc) · 4.34 KB
/
map.clj
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
;
; Copyright © 2017 Colin Smith.
; This work is based on the Scmutils system of MIT/GNU Scheme:
; Copyright © 2002 Massachusetts Institute of Technology
;
; This is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 3 of the License, or (at
; your option) any later version.
;
; This software is distributed in the hope that it will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
; General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with this code; if not, see <http://www.gnu.org/licenses/>.
;
(ns sicmutils.calculus.map
(:require [sicmutils
[structure :as s]
[function :as f]]
[sicmutils.calculus.basis :refer :all]
[sicmutils.calculus.vector-field :as vf]
[sicmutils.calculus.form-field :as ff]
[sicmutils.calculus.manifold :as m]))
(defn vector-field->vector-field-over-map
"FDG p.72"
[mu:N->M]
(fn [v-on-M]
(vf/procedure->vector-field
(fn [f-on-M]
(f/compose (v-on-M f-on-M) mu:N->M))
`((~'vector-field->vector-field-over-map ~(m/diffop-name mu:N->M)) ~(m/diffop-name v-on-M)))))
(defn differential
"FDG p.72"
[mu:N->M]
(fn [v-on-N]
(let [v-on-M (fn [g-on-M] (v-on-N (f/compose g-on-M mu:N->M)))]
(assert (vf/vector-field? v-on-N))
(vf/procedure->vector-field v-on-M
`((~'d ~(m/diffop-name mu:N->M)) ~(m/diffop-name v-on-N))))))
(defn literal-manifold-map
[name source target]
(let [n (:dimension (m/manifold source))
m (:dimension (m/manifold target))
domain (if (= n 1) [0] (apply s/up (repeat n 0)))]
(f/compose (m/point target)
(s/generate m ::s/up #(f/literal-function (symbol (str name "↑" %)) domain 0))
(m/chart source))))
(defn form-field->form-field-over-map
[mu:N->M]
(fn [w-on-M]
(let [make-fake-vector-field (fn [V-over-mu n]
(let [u (fn [f]
(fn [_]
((V-over-mu f) n)))]
(vf/procedure->vector-field u)))]
(ff/procedure->nform-field
(fn [& vectors-over-map]
(fn [n]
((apply w-on-M
(map (fn [V-over-mu] (make-fake-vector-field V-over-mu n))
vectors-over-map))
(mu:N->M n))))
(ff/get-rank w-on-M)
`((~'form-field->form-field-over-map ~(m/diffop-name mu:N->M))
~(m/diffop-name w-on-M))))))
(defn basis->basis-over-map
[mu:N->M basis-on-M]
(let [vector-basis-on-M (basis->vector-basis basis-on-M)
dual-basis-on-M (basis->oneform-basis basis-on-M)]
(make-basis (s/mapr (vector-field->vector-field-over-map mu:N->M) vector-basis-on-M)
(s/mapr (form-field->form-field-over-map mu:N->M) dual-basis-on-M))))
(defn pullback-function
[mu:N->M]
(fn [f-on-M]
(f/compose f-on-M mu:N->M)))
(defn pushforward-vector
[mu:N->M mu-inverse:M->N]
(fn [v-on-N]
(vf/procedure->vector-field
#(f/compose (v-on-N (f/compose % mu:N->M)) mu-inverse:M->N)
`((~'pushforward ~(m/diffop-name mu:N->M)) ~(m/diffop-name v-on-N)))))
(defn pullback-vector-field
[mu:N->M mu-inverse:M->N]
(pushforward-vector mu-inverse:M->N mu:N->M))
(defn pullback-form
"Returns a function which will pull a form back across a map (without needing its inverse)"
[mu:N->M]
(fn [omega-on-M]
(let [k (ff/get-rank omega-on-M)]
(if (zero? k)
((pullback-function mu:N->M) omega-on-M)
(ff/procedure->nform-field
(fn [& vectors-on-N]
(apply ((form-field->form-field-over-map mu:N->M) omega-on-M)
(map (differential mu:N->M) vectors-on-N)))
k
`((~'pullback ~(m/diffop-name mu:N->M)) ~(m/diffop-name omega-on-M)))))))
(defn pullback
([mu:N->M mu-inverse:M->N]
(fn [thing]
(if (vf/vector-field? thing)
(do
(assert mu-inverse:M->N "Pullback of a vector requires inverse map")
((pullback-vector-field mu:N->M mu-inverse:M->N) thing))
((pullback-form mu:N->M) thing))))
([mu:N->M]
(pullback mu:N->M nil)))