diff --git a/src/sicmutils/abstract/function.cljc b/src/sicmutils/abstract/function.cljc index 5d3ae50ef..e08dd1ce6 100644 --- a/src/sicmutils/abstract/function.cljc +++ b/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 diff --git a/src/sicmutils/calculus/coordinate.cljc b/src/sicmutils/calculus/coordinate.cljc index 90c4e1ced..e04c7eb87 100644 --- a/src/sicmutils/calculus/coordinate.cljc +++ b/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 diff --git a/src/sicmutils/env.cljc b/src/sicmutils/env.cljc index de92adb70..5d3bfbcf3 100644 --- a/src/sicmutils/env.cljc +++ b/src/sicmutils/env.cljc @@ -48,6 +48,7 @@ [sicmutils.numerical.quadrature] [sicmutils.mechanics.lagrange] [sicmutils.mechanics.hamilton] + [sicmutils.mechanics.rigid] [sicmutils.mechanics.rotation] [sicmutils.calculus.basis] [sicmutils.calculus.covariant] @@ -55,7 +56,7 @@ [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])) diff --git a/src/sicmutils/env/sci.cljc b/src/sicmutils/env/sci.cljc index 5f6c62046..f0573b51f 100644 --- a/src/sicmutils/env/sci.cljc +++ b/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 . +;; + (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)) diff --git a/src/sicmutils/env/sci/macros.cljc b/src/sicmutils/env/sci/macros.cljc index e5cefd638..929128a48 100644 --- a/src/sicmutils/env/sci/macros.cljc +++ b/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 . +;; + (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])}) diff --git a/src/sicmutils/expression/compile.cljc b/src/sicmutils/expression/compile.cljc index e2566e7df..35e43a6b7 100644 --- a/src/sicmutils/expression/compile.cljc +++ b/src/sicmutils/expression/compile.cljc @@ -463,7 +463,6 @@ cache, see `compile-state-fn`." [f params initial-state] (let [sw (us/stopwatch) - mode *mode* generic-params (for [_ params] (gensym 'p)) generic-state (struct/mapr (fn [_] (gensym 'y)) initial-state) g (apply f generic-params) @@ -473,7 +472,7 @@ compile-state-native compile-state-sci) compiled-fn (compiler generic-params generic-state body)] - (log/info "compiled state function in" (us/repr sw)) + (log/info "compiled state function in" (us/repr sw) "with mode" *mode*) compiled-fn)) (defn compile-state-fn @@ -543,14 +542,13 @@ cache, see `compile-univariate-fn`." [f] (let [sw (us/stopwatch) - mode *mode* var (gensym 'x) body (cse-form (g/simplify (f var))) - compiled (if (= mode :native) + compiled (if (native?) (compile-native var body) (compile-sci var body))] - (log/info "compiled univariate function in " (us/repr sw) " with mode " mode) + (log/info "compiled univariate function in" (us/repr sw) "with mode" *mode*) compiled)) (defn compile-univariate-fn diff --git a/src/sicmutils/mechanics/hamilton.cljc b/src/sicmutils/mechanics/hamilton.cljc index 709a20780..6ed025789 100644 --- a/src/sicmutils/mechanics/hamilton.cljc +++ b/src/sicmutils/mechanics/hamilton.cljc @@ -83,7 +83,8 @@ v (/ (- w b) M)] (- (* w v) (F v)))))) -(def Legendre-transform (make-operator Legendre-transform-fn "Legendre-transform")) +(def Legendre-transform + (make-operator Legendre-transform-fn 'Legendre-transform)) (defn ^:private Lagrangian->Hamiltonian-fn [Lagrangian] @@ -91,7 +92,8 @@ (let [L #(Lagrangian (up t q %))] ((Legendre-transform L) p)))) -(def Lagrangian->Hamiltonian (make-operator Lagrangian->Hamiltonian-fn 'Lagrangian->Hamiltonian)) +(def Lagrangian->Hamiltonian + (make-operator Lagrangian->Hamiltonian-fn 'Lagrangian->Hamiltonian)) (defn Poisson-bracket [f g] diff --git a/test/sicmutils/env/sci_test.cljc b/test/sicmutils/env/sci_test.cljc new file mode 100644 index 000000000..839e1b1ab --- /dev/null +++ b/test/sicmutils/env/sci_test.cljc @@ -0,0 +1,91 @@ +;; +;; 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 . +;; + +(ns sicmutils.env.sci-test + (:refer-clojure :exclude [eval]) + (:require [clojure.test :refer [is deftest testing]] + [sci.core :as sci] + [sicmutils.env :as e] + [sicmutils.env.sci :as es] + [sicmutils.operator :as o])) + +(defn eval [form] + (sci/eval-form (sci/fork es/context) form)) + +(deftest basic-sci-tests + (is (= 1 (eval '(simplify (+ (square (sin 'x)) + (square (cos 'x)))))) + "simplifications work inside sci") + + (is (= "{\\cos}^{2}\\left(x\\right) + {\\sin}^{2}\\left({x}^{2}\\right)" + (eval '(->TeX + (simplify (+ (square (sin (square 'x))) + (square (cos 'x)))))))) + + (is (= (e/literal-function 'U) + (eval '(literal-function 'U))) + "Literal functions use value equality.") + + (is (= o/identity-operator + (eval + '(do (require '[sicmutils.operator :as o]) + o/identity-operator))) + "can sci internally require namespaces?") + + (is (= '(* 10 face) + (eval + '(do (require '[sicmutils.env :as e]) + (e/simplify (e/* 'face 10))))) + "sicmutils.env is available as a namespace and also included as the + default bindings in `user`.") + + (testing "sci-specific macro definitions" + (is (= [true true true true] + (eval '(let-coordinates [[x y] R2-rect + [r theta] R2-polar] + (let [p ((point R2-rect) (up 1 2))] + [(= 1 (x p)) + (= 2 (y p)) + (= (sqrt 5) (r p)) + (= (atan 2) (theta p))])))) + "let-coordinates macro works") + + (is (= [true true] + (eval '(using-coordinates + [x y] R2-rect + (let [p ((point R2-rect) (up 1 2))] + [(= 1 (x p)) + (= 2 (y p))])))) + "using-coordinates works") + + (testing "internal defn, funky symbols, internal with-literal-functions macro" + (is (= "down(- m (Dφ(t))² r(t) + m D²r(t) + DU(r(t)), 2 m Dφ(t) r(t) Dr(t) + m (r(t))² D²φ(t))" + (eval + '(do (defn L-central-polar [m U] + (fn [[_ [r] [rdot φdot]]] + (- (* (/ 1 2) m + (+ (square rdot) + (square (* r φdot)))) + (U r)))) + (with-literal-functions [U r φ] + (let [L (L-central-polar 'm U) + state (up r φ)] + (->infix + (simplify + (((Lagrange-equations L) state) 't)))))))))))) diff --git a/test/sicmutils/expression/render_test.cljc b/test/sicmutils/expression/render_test.cljc index ffe66e408..a1adf07ea 100644 --- a/test/sicmutils/expression/render_test.cljc +++ b/test/sicmutils/expression/render_test.cljc @@ -102,7 +102,7 @@ (is (= "x^y" (s->infix (expt 'x 'y))))) (deftest more-with-D - (af/with-literal-functions [f g [p [] 0]] + (af/with-literal-functions [f g] (is (= "f(s)" (s->infix (f 's)))) (is (= "(f + g)(x, y)" (->infix '((+ f g) x y)))) (is (= "f(x) g(x)" (s->infix ((* f g) 'x)))) diff --git a/test/sicmutils/runner.cljs b/test/sicmutils/runner.cljs index 45034a28e..264b6b134 100644 --- a/test/sicmutils/runner.cljs +++ b/test/sicmutils/runner.cljs @@ -14,6 +14,8 @@ sicmutils.calculus.map-test sicmutils.calculus.vector-field-test + sicmutils.env.sci-test + sicmutils.examples.central-potential-test sicmutils.examples.double-pendulum-test sicmutils.examples.driven-pendulum-test @@ -107,6 +109,8 @@ 'sicmutils.calculus.map-test 'sicmutils.calculus.vector-field-test + 'sicmutils.env.sci-test + 'sicmutils.examples.central-potential-test 'sicmutils.examples.double-pendulum-test 'sicmutils.examples.driven-pendulum-test