diff --git a/src/sicmutils/abstract/function.cljc b/src/sicmutils/abstract/function.cljc index 4d4022f20..fb6adaa2c 100644 --- a/src/sicmutils/abstract/function.cljc +++ b/src/sicmutils/abstract/function.cljc @@ -22,8 +22,14 @@ applied to structures and numeric inputs, and differentiated. The namespace also contains an implementation of a small language for - declaring the input and output types of [[literal-function]] instances." - (:refer-clojure :exclude [name]) + declaring the input and output types of [[literal-function]] instances. + + NOTE: + + - a typed function is a function with typed metadata. + - This MIGHT be a thing we want now, given all of the stuff from the calc + work..." + (:refer-clojure :exclude [name ->]) (:require [sicmutils.abstract.number :as an] [sicmutils.differential :as d] [sicmutils.expression :as x] @@ -50,32 +56,180 @@ (derive ::function ::v/function) -(defn ^:private sicm-set->exemplar +;; The descriptors for literal functions look like prefix versions of the +;; standard function types. Thus, we want to be able to say: +;; +;; (literal-function 'V (-> (X Real Real) Real)) +;; +;; The base types are the real numbers, designated by "Real". We will later +;; extend the system to include complex numbers, designated by "Complex". +;; +;; Types can be combined in several ways. The cartesian product of types is +;; designated by: + +;; (X ...) +;; +;; We use this to specify an argument tuple of objects of the given types +;; arranged in the given order. +;; +;; Similarly, we can specify an up tuple or a down tuple with: +;; +;; (UP ...) +;; (DOWN ...) +;; +;; We can also specify a uniform tuple of a number of elements of the +;; same type using: +;; +;; (UP* [n]) +;; (DOWN* [n]) +;; +;; To get started... Type expressions are self-evaluating. + +(def Real 'Real) + +(defn X + ([] (u/illegal "Null type argument -- X")) + ([t] t) + ([t & ts] (apply list 'X t ts))) + +(defn UP + ([] (u/illegal "Null type argument -- UP")) + ([t] t) + ([t & ts] (apply list 'UP t ts))) + +(defn DOWN + ([] (u/illegal "Null type argument -- DOWN")) + ([t] t) + ([t & ts] (apply list 'DOWN t ts))) + +(defn EXPT [t n] + (apply X (repeat n t))) + +;; Examples: +;; (UP* Real 2 (UP Real Real) 2) +;; => (UP Real Real (UP Real Real) (UP Real Real)) +;; +;; (UP* Real 2 (UP Real Real) 2 Real) +;; => (UP* Real Real (UP Real Real) (UP Real Real) Real) + +(defn- starify [xs starred-sym unstarred-fn] + (if (empty? xs) + (u/illegal (str "Null type argument -- " starred-sym)) + (loop [xs xs + current nil + explicit? false + types []] + (if (empty? xs) + (if explicit? + (apply unstarred-fn types) + (cons starred-sym types)) + (let [[x & more] xs] + (if (integer? x) + (if current + (recur more + false + true + (into types (repeat (dec x) current))) + (u/illegal "Bad type arguments" starred-sym xs)) + (recur more x false (conj types x)))))))) + +(defn X* [& rest] + (starify rest 'X* X)) + +(defn UP* [& rest] + (starify rest 'UP* UP)) + +(defn DOWN* [& rest] + (starify rest 'DOWN* DOWN)) + +(defn -> [domain range] + (list '-> domain range)) + +(def Any 'Any) + +(defn default-type [n] + (if (= n 1) + (-> Real Real) + (-> (X* Real n) Real))) + +(defn permissive-type [n] + (-> (X* Any n) Real)) + +;; Some useful types + +(defn Lagrangian + "n = #degrees-of-freedom" + ([] (-> (UP* Real (UP* Real) (UP* Real)) Real)) + ([n] (-> (UP Real (UP* Real n) (UP* Real n)) Real))) + +(defn Hamiltonian + "n = #degrees-of-freedom" + ([] (-> (UP Real (UP* Real) (DOWN* Real)) Real)) + ([n] (-> (UP Real (UP* Real n) (DOWN* Real n)) Real))) + +(defn process-type + "combo of all type-> functions." + [t] + {:pre [(sequential? t)]} + (let [[arrow domain range] t] + (if-not (and (= '-> arrow) domain range) + (u/illegal + (str "A SICM signature is of the form '(-> domain range), got: " + arrow domain range)) + (let [[dtypes arity] + (cond (and (sequential? domain) + (= (first domain) 'X)) + (let [types (into [] (rest domain))] + [types [:exactly (count types)]]) + + (and (sequential? domain) + (= (first domain) 'X*)) + [[domain] [:at-least 0]] + + :else [domain [:exactly 1]])] + {:domain domain + :range-type range + :domain-types dtypes + :arity arity})))) + +;; Existing Stuff. There is a BIT more in `litfun.scm` that we should read to +;; figure out what is going on. + +(defn- sicm-set->exemplar "Convert a SICM-style set (e.g., Real or (UP Real Real)) to an exemplar (an instance of the relevant type)." [s] - (cond - (= s 'Real) 0 - - (sequential? s) - (let [[constructor & args] s] - (case constructor - X (mapv sicm-set->exemplar args) - UP (apply s/up (map sicm-set->exemplar args)) - DOWN (apply s/down (map sicm-set->exemplar args)) - UP* (apply s/up (repeat (second args) (sicm-set->exemplar (first args)))) - DOWN* (apply s/down (repeat (second args) (sicm-set->exemplar (first args)))) - X* (into [] (repeat (second args) (sicm-set->exemplar (first args)))))))) - -(defn ^:no-doc sicm-signature->domain-range - "Convert a SICM-style literal function signature (e.g., - '(-> Real (X Real Real)) ) to our 'exemplar' format." + (cond (= s 'Real) 0 + (sequential? s) + (let [[ctor & [type arity :as args]] s] + (case ctor + X (mapv sicm-set->exemplar args) + UP (s/up* (map sicm-set->exemplar args)) + DOWN (s/down* (map sicm-set->exemplar args)) + X* (into [] (repeat arity (sicm-set->exemplar type))) + UP* (s/up* (repeat arity (sicm-set->exemplar type))) + DOWN* (s/down* (repeat arity (sicm-set->exemplar type))))) + :else + (u/illegal "error!"))) + +;; TODO SHOULD NOT handle an "X" type in the range. + +(defn sicm-signature->domain-range + "Convert a SICM-style literal function signature, + e.g., '(-> Real (X Real Real)) + to our 'exemplar' format." [[arrow domain range]] (when-not (and (= '-> arrow) domain range) - (u/illegal (str "A SICM signature is of the form '(-> domain range), got: " arrow domain range))) - [(let [d (sicm-set->exemplar domain)] - (if (vector? d) d [d])) - (sicm-set->exemplar range)]) + (u/illegal + (str "A SICM signature is of the form '(-> domain range), got: " + arrow domain range))) + (let [d (sicm-set->exemplar domain) + d (if (vector? d) d [d]) + r (sicm-set->exemplar range)] + [d r])) + +;; TODO add metadata!! How did we get away with not having this yet? +;; TODO trawl for other uses of the star constructors, replace those around the library. (deftype Function [name arity domain range] v/Value @@ -85,7 +239,7 @@ (zero-like [_] (fn [& _] (v/zero-like range))) (one-like [_] (fn [& _] (v/one-like range))) (identity-like [_] - (let [meta {:arity arity :from :identity-like}] + (let [meta {:arity arity :from ::v/identity-like}] (with-meta identity meta))) (exact? [f] (f/compose v/exact? f)) (freeze [_] (v/freeze name)) @@ -197,6 +351,11 @@ (= (domain-types a) (domain-types b)) (= (range-type a) (range-type b)))) +;; TODO allow for functions in range! +;; +;; (((literal-function 'f (-> Real (-> Real Real))) 'x) 'y) +;; ((f x) y) + (defn literal-function ([f] (->Function f [:exactly 1] [0] 0)) ([f signature] @@ -281,8 +440,8 @@ (apply d/d:+ (apply f ve) (flatten partials)))) (defn- check-argument-type - "Check that the argument provided at index i has the same type as - the exemplar expected." + "Check that the argument provided at index i has the same type as the exemplar + expected." [f provided expected indexes] (cond (number? expected) (when-not (v/numerical? provided) @@ -309,14 +468,3 @@ (if (some d/perturbed? xs) (literal-derivative f xs) (an/literal-number `(~(name f) ~@(map v/freeze xs))))) - -;; ## Specific Generics -;; -;; We can install one more method - [[sicmutils.generic/simplify]] returns its -;; argument with the internally captured name simplified. - -(defmethod g/simplify [::function] [f] - (->Function (g/simplify (name f)) - (f/arity f) - (domain-types f) - (range-type f))) diff --git a/test/sicmutils/mechanics/hamilton_test.cljc b/test/sicmutils/mechanics/hamilton_test.cljc index 3893acbb3..85ff8b5a2 100644 --- a/test/sicmutils/mechanics/hamilton_test.cljc +++ b/test/sicmutils/mechanics/hamilton_test.cljc @@ -1,21 +1,21 @@ -; -; 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 . -; +;; +;; 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 . +;; (ns sicmutils.mechanics.hamilton-test (:refer-clojure :exclude [+ - * / partial]) @@ -89,9 +89,9 @@ (up 't (up 'x 'y) (down 'p_x 'p_y)))))) (testing "Jacobi identity" (is (= 0 (simplify ((+ (H/Poisson-bracket FF (H/Poisson-bracket GG HH)) - (H/Poisson-bracket GG (H/Poisson-bracket HH FF)) - (H/Poisson-bracket HH (H/Poisson-bracket FF GG))) - (up 't (up 'x 'y) (down 'p_x 'p_y)))))))))) + (H/Poisson-bracket GG (H/Poisson-bracket HH FF)) + (H/Poisson-bracket HH (H/Poisson-bracket FF GG))) + (up 't (up 'x 'y) (down 'p_x 'p_y)))))))))) (deftest section-3-1-1 ;; To move further into Hamiltonian mechanics, we will need @@ -129,6 +129,72 @@ (L/L-rectangular 'm V)) (up 't (up 'x 'y) (down 'p_x 'p_y)))))))) +(deftest litfun-tests + (testing "similar test from litfun.scm" + (let [H (f/literal-function 'H '(-> (UP Real (UP* Real 2) (DOWN* Real 2)) Real))] + (is (= '(up 0 + (up + (+ ((D x) t) + (* -1 (((partial 2 0) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t)))))) + (+ ((D y) t) + (* -1 (((partial 2 1) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t))))))) + (down + (+ ((D p_x) t) + (((partial 1 0) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t))))) + (+ ((D p_y) t) + (((partial 1 1) H) (up t (up (x t) (y t)) (down (p_x t) (p_y t))))))) + (g/simplify + (((H/Hamilton-equations H) + (L/coordinate-tuple (f/literal-function 'x) + (f/literal-function 'y)) + (H/momentum-tuple (f/literal-function 'p_x) + (f/literal-function 'p_y))) + 't)))))) + + (comment + (let [Lf (f/literal-function 'L (f/Lagrangian))] + + (Lf (L/->L-state 't 'x 'v)) + #_(Lf (up t x v)) + + ((D Lf) (L/->L-state 't 'x 'v)) + #_(down (((partial 0) L) (up t x v)) + (((partial 1) L) (up t x v)) + (((partial 2) L) (up t x v))) + + (Lf (L/->L-state 't (up 'x 'y) (up 'v_x 'v_y))) + #_(L (up t (up x y) (up v_x v_y))) + + ((D Lf) (L/->L-state 't (up 'x 'y) (up 'v_x 'v_y))) + #_(down + (((partial 0) L) (up t (up x y) (up v_x v_y))) + (down (((partial 1 0) L) (up t (up x y) (up v_x v_y))) + (((partial 1 1) L) (up t (up x y) (up v_x v_y)))) + (down (((partial 2 0) L) (up t (up x y) (up v_x v_y))) + (((partial 2 1) L) (up t (up x y) (up v_x v_y)))))) + + + (let [Hf (f/literal-function 'H (f/Hamiltonian))] + + (Hf (H/->H-state 't 'x 'p)) + #_(Hf (up t x p)) + + ((D H) (H/->H-state 't 'x 'p)) + #_(down (((partial 0) H) (up t x p)) + (((partial 1) H) (up t x p)) + (((partial 2) H) (up t x p))) + + (H (H/->H-state 't (up 'x 'y) (down 'p_x 'p_y))) + #_(H (up t (up x y) (down p_x p_y))) + + ((D H) (H/->H-state 't (up 'x 'y) (down 'p_x 'p_y))) + #_(down + (((partial 0) H) (up t (up x y) (down p_x p_y))) + (down (((partial 1 0) H) (up t (up x y) (down p_x p_y))) + (((partial 1 1) H) (up t (up x y) (down p_x p_y)))) + (up (((partial 2 0) H) (up t (up x y) (down p_x p_y))) + (((partial 2 1) H) (up t (up x y) (down p_x p_y)))))))) + (deftest gjs-tests (is (= '(up 0 (up (/ (+ (* m ((D x) t)) (* -1 (p_x t))) m) @@ -138,8 +204,7 @@ (f/with-literal-functions [x y p_x p_y [V [0 1] 2]] (simplify (((H/Hamilton-equations - (H/H-rectangular - 'm V)) + (H/H-rectangular 'm V)) (L/coordinate-tuple x y) (H/momentum-tuple p_x p_y)) 't)))))