-
-
Notifications
You must be signed in to change notification settings - Fork 68
/
macros.cljc
95 lines (85 loc) · 3.7 KB
/
macros.cljc
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
;;
;; Copyright © 2020 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.env.sci.macros
"This namespace contains reimplementations of various macros from sicmutils,
defined in the form required by SCI."
(:require [sicmutils.abstract.function :as af]
[sicmutils.calculus.coordinate :as cc]
[sicmutils.calculus.manifold :as m]
[sicmutils.calculus.vector-field :as vf]
[sicmutils.calculus.form-field :as ff]
[sicmutils.util :as u]))
(defn literal-function
"Originally defined in `sicmutils.env`."
([_ _ f] `(af/literal-function ~f))
([_ _ f sicm-signature]
(if (and (list? sicm-signature)
(= '-> (first sicm-signature)))
`(af/literal-function ~f '~sicm-signature)
`(af/literal-function ~f ~sicm-signature)))
([_ _ f domain range]
`(af/literal-function ~f ~domain ~range)))
(defn with-literal-functions
"Originally defined in `sicmutils.abstract.function`."
[_ _ litfns & body]
(let [pairs (af/binding-pairs litfns)
bindings (into [] cat pairs)]
`(let ~bindings ~@body)))
(defn let-coordinates
"Originally defined in `sicmutils.calculus.coordinate`."
[_ _ bindings & body]
(when-not (even? (count bindings))
(u/illegal "let-coordinates requires an even number of bindings"))
(let [pairs (partition 2 bindings)
prototypes (map first pairs)
c-systems (mapv second pairs)
coordinate-names (mapcat #'cc/symbols-from-prototype prototypes)
coordinate-vector-field-names (map vf/coordinate-name->vf-name coordinate-names)
coordinate-form-field-names (map ff/coordinate-name->ff-name coordinate-names)]
`(let [[~@c-systems :as c-systems#]
(mapv m/with-coordinate-prototype
~c-systems
~(mapv #(cc/quotify-coordinate-prototype identity %) prototypes))
c-fns# (map cc/coordinate-functions c-systems#)
c-vfs# (map vf/coordinate-basis-vector-fields c-systems#)
c-ffs# (map ff/coordinate-basis-oneform-fields c-systems#)
~(vec coordinate-names) (flatten c-fns#)
~(vec coordinate-vector-field-names) (flatten c-vfs#)
~(vec coordinate-form-field-names) (flatten c-ffs#)]
~@body)))
(defn using-coordinates
"Originally defined in `sicmutils.calculus.coordinate`."
[env form coordinate-prototype coordinate-system & body]
(apply let-coordinates
env form
[coordinate-prototype coordinate-system]
body))
(defn- tag-as-macro [f]
(with-meta f {:sci/macro true}))
(def all
{'literal-function (tag-as-macro literal-function)
'with-literal-functions (tag-as-macro with-literal-functions)
'let-coordinates (tag-as-macro let-coordinates)
'using-coordinates (tag-as-macro using-coordinates)})
(def ns-bindings
{'sicmutils.env all
'sicmutils.abstract.function
(select-keys all ['with-literal-functions])
'sicmutils.calculus.coordinate
(select-keys all ['let-coordinates 'using-coordinates])})