Get SCI macros tested + working

src/sicmutils/abstract/function.cljc

@@ -166,22 +166,26 @@
          :else
          (u/illegal (str "WTF range" range)))))
 
+(defn binding-pairs [litfns]
+  (letfn [(extract-sym [entry]
+            (if (symbol? entry) entry (first entry)))
+          (entry->fn [entry]
+            (cond (symbol? entry) `(literal-function (quote ~entry))
+
+                  (and (sequential? entry) (= (count entry) 3))
+                  (let [[sym domain range] entry]
+                    `(literal-function (quote ~sym) ~domain ~range))
+
+                  :else (u/illegal (str "unknown literal function type" entry))))]
+    (mapv (fn [entry]
+            [(extract-sym entry)
+             (entry->fn entry)])
+          litfns)))
+
 (defmacro with-literal-functions [litfns & body]
-  `(let ~(vec (interleave
-               (map (fn [s]
-                      (if (symbol? s) s (first s)))
-                    litfns)
-               (map (fn [s]
-                      (cond (symbol? s)
-                            `(literal-function (quote ~s))
-                            (and (sequential? s)
-                                 (= (count s) 3))
-                            `(literal-function (quote ~(first s))
-                                               ~(second s)
-                                               ~(nth s 2))
-                            :else (u/illegal (str "unknown literal function type" s))))
-                    litfns)))
-     ~@body))
+  (let [pairs    (binding-pairs litfns)
+        bindings (into [] cat pairs)]
+    `(let ~bindings ~@body)))
 
 ;; ## Differentiation of literal functions
 

src/sicmutils/calculus/coordinate.cljc

@@ -34,7 +34,7 @@
                     #(m/point->coords coordinate-system %)))
             (s/structure->access-chains prototype))))
 
-(defn ^:private quotify-coordinate-prototype
+(defn quotify-coordinate-prototype
   "Scmutils wants to allow forms like this:
      (using-coordinates (up x y) R2-rect ...)
    Note that x, y are unquoted. This function converts such an unquoted for

src/sicmutils/env.cljc

@@ -48,14 +48,15 @@
             [sicmutils.numerical.quadrature]
             [sicmutils.mechanics.lagrange]
             [sicmutils.mechanics.hamilton]
+            [sicmutils.mechanics.rigid]
             [sicmutils.mechanics.rotation]
             [sicmutils.calculus.basis]
             [sicmutils.calculus.covariant]
             [sicmutils.calculus.derivative :as d]
             [sicmutils.calculus.form-field]
             [sicmutils.calculus.manifold]
             [sicmutils.calculus.map]
-            [sicmutils.calculus.coordinate]
+            [sicmutils.calculus.coordinate :as cc]
             [sicmutils.calculus.vector-field]))
 
 #?(:clj
@@ -83,10 +84,15 @@
      `(af/literal-function ~f ~sicm-signature)))
   ([f domain range] `(af/literal-function ~f ~domain ~range)))
 
-(defmacro with-literal-functions
-  [& args]
+(defmacro with-literal-functions [& args]
   `(af/with-literal-functions ~@args))
 
+(defmacro let-coordinates [& args]
+  `(cc/let-coordinates ~@args))
+
+(defmacro using-coordinates [& args]
+  `(cc/using-coordinates ~@args))
+
 (def print-expression simp/print-expression)
 
 (defn ref
@@ -339,8 +345,3 @@
  [sicmutils.value exact? zero? one? identity?
   zero-like one-like identity-like
   numerical? freeze kind kind-predicate])
-
-;; Macros. These work with Potemkin's import, but not with the Clojure version.
-#?(:clj
-   (import-vars
-    [sicmutils.calculus.coordinate let-coordinates using-coordinates]))

src/sicmutils/env/sci.cljc

@@ -1,66 +1,113 @@
+;;
+;; 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
-  (:refer-clojure :exclude [eval])
-  (:require [clojure.set :as set]
-            [sci.core :as sci]
+  (:require [sci.core :as sci]
+            [sicmutils.env]
             [sicmutils.env.sci.macros :as macros]
-            [sicmutils.env :as env]
-            [sicmutils.abstract.function :as af]
-            [sicmutils.calculus.coordinate :as cc]))
-
-(defn ->sci-var [[var-name the-var]]
-  [var-name (cond-> (deref the-var)
-              (-> the-var meta :macro)
-              (with-meta {:sci/macro true}))])
+            [sicmutils.util :as u]))
 
-(defn ->sci-ns [publics]
-  (into {} (map ->sci-var) publics))
+(def macro? (comp :macro meta))
+(def dynamic? (comp :dynamic meta))
 
-(def namespaces
-  {'sicmutils.env (-> 'sicmutils.env
-                      ns-publics
-                      (dissoc 'literal-function
-                              'with-literal-functions
-                              'bootstrap-repl!
-                              'let-coordinates
-                              'using-coordinates)
-                      ->sci-ns
+(defn ns-macros
+  "Given a map of symbol => var, returns a sequence of the symbols associated with
+  macro value."
+  [sym->var]
+  (mapcat (fn [[sym var]]
+            (if (macro? var) [sym] []))
+          sym->var))
 
-                      (merge (select-keys macros/all ['literal-function
-                                                      'with-literal-functions
-                                                      'let-coordinates
-                                                      'using-coordinates])))
-   'sicmutils.abstract.function (-> 'sicmutils.abstract.function ns-publics ->sci-ns)
-   'sicmutils.calculus.coordinate (-> 'sicmutils.calculus.coordinate
-                                      ns-publics
-                                      ->sci-ns
-                                      (merge (select-keys macros/all ['let-coordinates
-                                                                      'using-coordinates])))})
+(defn sci-ns
+  "Given a map of symbol => var, returns a map of symbol => var with:
 
-(def opts {:namespaces (set/rename-keys namespaces {'sicmutils.env 'user})})
+  - any pair removed whose value is a macro (tagged with `:macro true` metadata)
+  - all other values resolved"
+  [sym->var]
+  (letfn [(process [[sym var]]
+            (cond
+              ;; Inside SCI, macros are replaced by rewritten-as-functions
+              ;; versions of themselves, with additional slots for `&form` and
+              ;; `&env`. We exclude them here so they can be replaced later.
+              (macro? var) []
 
-(def ctx (sci/init opts))
+              ;; Keep dynamic variables as unresolved vars, so that they can
+              ;; at least be inspected (at which point they'll reveal any
+              ;; rebindings applied by the system)
+              (dynamic? var) [[sym var]]
 
-(comment
-  (defn eval [form]
-    (sci/eval-string* ctx (pr-str form)))
+              ;; by default, the SCI environment holds values, not the vars
+              ;; that they were attached to in non-SCI land.
+              :else [[sym @var]]))]
+    (into {} (mapcat process) sym->var)))
 
-  (eval '(simplify (+ (square (sin 'x))
-                      (square (cos 'x)))))
+(def ^{:doc "Map whose values are the symbols of of all namespaces explicitly
+checked and whitelisted for SCI compilation and interesting enough in their own
+right to expose to a user by default. Each value is the sym->var map for the
+corresponding namespace."}
+  ns-map
+  {'sicmutils.env                              (ns-publics 'sicmutils.env)
+   'sicmutils.generic                          (ns-publics 'sicmutils.generic)
+   'sicmutils.function                         (ns-publics 'sicmutils.function)
+   'sicmutils.operator                         (ns-publics 'sicmutils.operator)
+   'sicmutils.series                           (ns-publics 'sicmutils.series)
+   'sicmutils.simplify                         (ns-publics 'sicmutils.simplify)
+   'sicmutils.structure                        (ns-publics 'sicmutils.structure)
+   'sicmutils.matrix                           (ns-publics 'sicmutils.matrix)
+   'sicmutils.abstract.function                (ns-publics 'sicmutils.abstract.function)
+   'sicmutils.calculus.basis                   (ns-publics 'sicmutils.calculus.basis)
+   'sicmutils.calculus.coordinate              (ns-publics 'sicmutils.calculus.coordinate)
+   'sicmutils.calculus.covariant               (ns-publics 'sicmutils.calculus.covariant)
+   'sicmutils.calculus.derivative              (ns-publics 'sicmutils.calculus.derivative)
+   'sicmutils.calculus.form-field              (ns-publics 'sicmutils.calculus.form-field)
+   'sicmutils.calculus.manifold                (ns-publics 'sicmutils.calculus.manifold)
+   'sicmutils.calculus.map                     (ns-publics 'sicmutils.calculus.map)
+   'sicmutils.calculus.vector-field            (ns-publics 'sicmutils.calculus.vector-field)
+   'sicmutils.expression.compile               (ns-publics 'sicmutils.expression.compile)
+   'sicmutils.expression.render                (ns-publics 'sicmutils.expression.render)
+   'sicmutils.mechanics.lagrange               (ns-publics 'sicmutils.mechanics.lagrange)
+   'sicmutils.mechanics.hamilton               (ns-publics 'sicmutils.mechanics.hamilton)
+   'sicmutils.mechanics.rigid                  (ns-publics 'sicmutils.mechanics.rigid)
+   'sicmutils.mechanics.rotation               (ns-publics 'sicmutils.mechanics.rotation)
+   'sicmutils.numerical.derivative             (ns-publics 'sicmutils.numerical.derivative)
+   'sicmutils.numerical.quadrature             (ns-publics 'sicmutils.numerical.quadrature)
+   'sicmutils.numerical.ode                    (ns-publics 'sicmutils.numerical.ode)
+   'sicmutils.numerical.minimize               (ns-publics 'sicmutils.numerical.minimize)
+   'sicmutils.numerical.interpolate.polynomial (ns-publics 'sicmutils.numerical.interpolate.polynomial)
+   'sicmutils.numerical.interpolate.rational   (ns-publics 'sicmutils.numerical.interpolate.rational)
+   'sicmutils.numerical.interpolate.richardson (ns-publics 'sicmutils.numerical.interpolate.richardson)
+   'sicmutils.numerical.multimin.nelder-mead   (ns-publics 'sicmutils.numerical.multimin.nelder-mead)
+   'sicmutils.numerical.unimin.bracket         (ns-publics 'sicmutils.numerical.unimin.bracket)
+   'sicmutils.numerical.unimin.brent           (ns-publics 'sicmutils.numerical.unimin.brent)
+   'sicmutils.numerical.unimin.golden          (ns-publics 'sicmutils.numerical.unimin.golden)})
 
-  (eval '(->TeX (simplify (+ (square (sin (square 'x)))
-                             (square (cos 'x))))))
+(def ^{:doc "Default sci context options required (currently only `:namespace`
+  bindings) required to evaluate SICMUtils forms from inside of an SCI
+  context. Pass these to `sci/init` to generate an sci context."}
+  context-opts
+  (let [ns-map (into {}
+                     (map (fn [[k v]] [k (sci-ns v)]))
+                     ns-map)
+        with-macros (merge-with merge ns-map macros/ns-bindings)]
+    {:namespaces with-macros}))
 
-  (eval '(literal-function 'U))
-  (eval '(do (defn L-central-polar [m U]
-               (fn [[_ [r] [rdot φdot]]]
-                 (- (* 1/2 m
-                       (+ (square rdot)
-                          (square (* r φdot))))
-                    (U r))))
-             (let [potential-fn (literal-function 'U)
-                   L     (L-central-polar 'm potential-fn)
-                   state (up (literal-function 'r)
-                             (literal-function 'φ))]
-               (->TeX
-                (simplify
-                 (((Lagrange-equations L) state) 't)))))))
+(def ^{:doc "sci context (currently only `:namespace` bindings) required to
+  evaluate SICMUtils forms via SCI"}
+  context
+  (sci/init context-opts))

src/sicmutils/env/sci/macros.cljc

@@ -1,24 +1,52 @@
+;;
+;; 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
-  (:require [sicmutils.abstract.function :as af #?@(:cljs [:include-macros true])]
-            [sicmutils.calculus.coordinate :as cc #?@(:cljs [:include-macros true])]
+  "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)))
+  ([_ _ f domain range]
+   `(af/literal-function ~f ~domain ~range)))
 
 (defn with-literal-functions
-  [_ _ & args]
-  `(af/with-literal-functions ~@args))
+  "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"))
@@ -31,8 +59,8 @@
     `(let [[~@c-systems :as c-systems#]
            (mapv m/with-coordinate-prototype
                  ~c-systems
-                 ~(mapv #(sicmutils.calculus.coordinate/quotify-coordinate-prototype identity %) prototypes))
-           c-fns# (map coordinate-functions 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#)
@@ -41,14 +69,27 @@
        ~@body)))
 
 (defn using-coordinates
-  [_ _ coordinate-prototype coordinate-system & body]
-  `(let-coordinates [~coordinate-prototype ~coordinate-system] ~@body))
+  "Originally defined in `sicmutils.calculus.coordinate`."
+  [env form coordinate-prototype coordinate-system & body]
+  (apply let-coordinates
+         env form
+         [coordinate-prototype coordinate-system]
+         body))
 
-(defn macrofy [f]
+(defn- tag-as-macro [f]
   (with-meta f {:sci/macro true}))
 
 (def all
-  {'literal-function (macrofy literal-function)
-   'with-literal-functions (macrofy with-literal-functions)
-   'let-coordinates (macrofy let-coordinates)
-   'using-coordinates (macrofy using-coordinates)})
+  {'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])})