├── LICENCE.txt ├── README.rst ├── calculus.rkt ├── docs ├── calculus.rst ├── data-virtualization.rst ├── equation-solving.rst ├── euler-lagrangian-equation.rst ├── expressions.rst ├── grassmannian-calculus.rst ├── linear-algebra.rst ├── numerical-differential-equation.rst ├── riemannian-geometry-general-relativity.rst ├── simplify.rst ├── virtualization-of-expressions.png └── virtualization-of-expressions.rst ├── examples ├── curvature-schwarzschild.rkt ├── curvature-surface-of-sphere.rkt ├── metric-einstein-summation.rkt ├── numerical-visualization-simple-pendulum.gif ├── numerical-visualization-simple-pendulum.rkt ├── symbolic-double-pendulum.rkt └── symbolic-simple-pendulum.rkt ├── fundamental.rkt ├── generic-hash.rkt ├── grassmannian-calculus.rkt ├── lagrangian.rkt ├── linear-algebra.rkt ├── mechanical-objects.rkt ├── numerical-differential-equation.rkt ├── plot.rkt ├── riemannian.rkt ├── show-expression.rkt ├── show-mechanical-objects.rkt ├── simplify.rkt ├── solve.rkt └── tensor.rkt /LICENCE.txt: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | 3 | Version 3, 29 June 2007 4 | 5 | Copyright © 2007 Free Software Foundation, Inc. 6 | 7 | Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. 8 | 9 | This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below. 10 | 0. Additional Definitions. 11 | 12 | As used herein, “this License” refers to version 3 of the GNU Lesser General Public License, and the “GNU GPL” refers to version 3 of the GNU General Public License. 13 | 14 | “The Library” refers to a covered work governed by this License, other than an Application or a Combined Work as defined below. 15 | 16 | An “Application” is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library. 17 | 18 | A “Combined Work” is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the “Linked Version”. 19 | 20 | The “Minimal Corresponding Source” for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version. 21 | 22 | The “Corresponding Application Code” for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work. 23 | 1. Exception to Section 3 of the GNU GPL. 24 | 25 | You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL. 26 | 2. Conveying Modified Versions. 27 | 28 | If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version: 29 | 30 | a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or 31 | b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy. 32 | 33 | 3. Object Code Incorporating Material from Library Header Files. 34 | 35 | The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following: 36 | 37 | a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License. 38 | b) Accompany the object code with a copy of the GNU GPL and this license document. 39 | 40 | 4. Combined Works. 41 | 42 | You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following: 43 | 44 | a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License. 45 | b) Accompany the Combined Work with a copy of the GNU GPL and this license document. 46 | c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document. 47 | d) Do one of the following: 48 | 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source. 49 | 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version. 50 | e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.) 51 | 52 | 5. Combined Libraries. 53 | 54 | You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following: 55 | 56 | a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License. 57 | b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 58 | 59 | 6. Revised Versions of the GNU Lesser General Public License. 60 | 61 | The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. 62 | 63 | Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License “or any later version” applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation. 64 | 65 | If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library. 66 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | =========== 2 | Schemannian 3 | =========== 4 | 5 | As a scheme/Racket based package for symbolic mathematics for physicist, "Schemannian" currently supports a realization of Euler-Lagrangian Equation is classical physics, Riemannian geometry and General Relativity calculations, and simple Grassmannian Calculus. 6 | 7 | "Schemannian" won the first Jane Street prize of `Lisp In Summer Projects 2013`_. 8 | 9 | .. _Lisp In Summer Projects 2013: http://lispinsummerprojects.org/ 10 | 11 | Test Environment 12 | ================ 13 | 14 | "Schemannian" is written and debugged using a `Racket`_ v5.3.1 in a 64-bit Ubuntu 13.04 (Raring Ringtail) computer, and a v5.3.5 in a 32-bit Ubuntu 12.04 (Precise Pangolin) computer. Racket is installed by the default setting of ``sudo apt-get install racket``. 15 | 16 | .. _Racket: http://racket-lang.org/ 17 | 18 | Highlights 19 | ========== 20 | 21 | "Schemannian" can calculate the Lagrangian and the equation of motion (by Euler-Lagrangian equation) of a classical mechanical system. For example, this piece of code will give you the equation of motion of the double pendulum. 22 | 23 | .. code:: scheme 24 | 25 | (define pendulum1 26 | (make-pendulum 'm1 'l1 'pivotX1 'pivotY1 (make-function 'theta1 't))) 27 | (define pendulum2 28 | (make-pendulum 'm2 'l2 (pendulum1 'X) (pendulum1 'Y) (make-function 'theta2 't))) 29 | 30 | (define L (lagrangian (list pendulum1 pendulum2))) 31 | (define euler-lagrangian-L 32 | (euler-lagrangian-equation L 33 | (list (make-function 'theta1 't) (make-function 'theta2 't)) 34 | (list (deriv (make-function 'theta1 't) 't) 35 | (deriv (make-function 'theta2 't) 't)) 36 | 't)) 37 | 38 | That is interesting, because Lagrangian formulation and Euler-Lagrangian equation are extremely important for loop calculations in quantum field theory. Those calculations are really tedious, and currently there is *NO* general propose package to do them. 39 | 40 | "Schemannian" gives an interface to virtualize the motion of mechanical objects by Euler-Lagrangian equation. 41 | 42 | "Schemannian" is capable to calculate typical General Relativity expressions such as Christoffel symbols, Riemann curvature tensor, Ricci curvature tensor, and Ricci scalar from the metric. For example, the following code calculate the curvature on the surface of a sphere. 43 | 44 | .. code:: scheme 45 | 46 | (define g (make-tensor '((_ a) (_ b)) 47 | '(((** r 2) 0) 48 | (0 (* (** r 2) (** (sin theta) 2)))))) 49 | 50 | (define Gamma^a_bc (christoffel '((^ a) (_ b) (_ c)) g '(theta phi))) 51 | (define R^a_bcd (riemann-tensor '((^ a) (_ b) (_ c) (_ d)) Gamma^a_bc '(theta phi))) 52 | (define R_ab (ricci-curvature-tensor '((_ a) (_ b)) R^a_bcd)) 53 | (ricci-scalar g R_ab) 54 | 55 | The Schemannian Reference 56 | ========================= 57 | 58 | Supported Math Functions 59 | ------------------------ 60 | 61 | `Expressions`_ 62 | 63 | `Virtualization of Expressions`_ 64 | 65 | `Simplification of Expressions`_ 66 | 67 | `Linear Algebra`_ 68 | 69 | `Equation Solving`_ 70 | 71 | `Basic Calculus`_ 72 | 73 | `Numerical Differential Equation Solving`_ 74 | 75 | `Data Virtualization`_ 76 | 77 | .. _Expressions: https://github.com/ozooxo/Schemannian/blob/master/docs/expressions.rst 78 | .. _Virtualization of Expressions: https://github.com/ozooxo/Schemannian/blob/master/docs/virtualization-of-expressions.rst 79 | .. _Simplification of Expressions: https://github.com/ozooxo/Schemannian/blob/master/docs/simplify.rst 80 | .. _Linear Algebra: https://github.com/ozooxo/Schemannian/blob/master/docs/linear-algebra.rst 81 | .. _Equation Solving: https://github.com/ozooxo/Schemannian/blob/master/docs/equation-solving.rst 82 | .. _Basic Calculus: https://github.com/ozooxo/Schemannian/blob/master/docs/calculus.rst 83 | .. _Numerical Differential Equation Solving: https://github.com/ozooxo/Schemannian/blob/master/docs/numerical-differential-equation.rst 84 | .. _Data Virtualization: https://github.com/ozooxo/Schemannian/blob/master/docs/data-virtualization.rst 85 | 86 | Physics Related Functions 87 | ------------------------- 88 | 89 | `Euler Lagrangian Equation`_ 90 | 91 | `Riemannian Geometry and General Relativity`_ 92 | 93 | `Grassmannian Calculus`_ 94 | 95 | .. _Euler Lagrangian Equation: https://github.com/ozooxo/Schemannian/blob/master/docs/euler-lagrangian-equation.rst 96 | .. _Riemannian Geometry and General Relativity: https://github.com/ozooxo/Schemannian/blob/master/docs/riemannian-geometry-general-relativity.rst 97 | .. _Grassmannian Calculus: https://github.com/ozooxo/Schemannian/blob/master/docs/grassmannian-calculus.rst 98 | 99 | Copyright and License 100 | ===================== 101 | 102 | This program has been written by Cong-Xin Qiu. It is protected by the `"GNU Lesser General Public License"`_. 103 | 104 | .. _"GNU Lesser General Public License": http://www.gnu.org/copyleft/lesser.html 105 | -------------------------------------------------------------------------------- /calculus.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "fundamental.rkt") 4 | 5 | (provide deriv integrate) 6 | 7 | (define (deriv exp var) 8 | (cond ((number? exp) 0) 9 | ((equal? exp var) 1) 10 | ((and (variable? exp) (not (same-variable? exp var))) 0) 11 | ((and (not (variable? var)) (function? exp)) 0) 12 | ((and (not (variable? var)) (deriv? exp)) 0) 13 | ((function? exp) (if (eq? (get-function-arg exp) var) 14 | (make-deriv exp var) 15 | 0)) 16 | ((deriv? exp) (if (eq? (get-deriv-arg exp) var) 17 | (make-deriv exp var) 18 | 0)) 19 | ((sum? exp) 20 | (make-sum (map 21 | (lambda (arg-lst) (deriv arg-lst var)) 22 | (get-arg-lst exp)))) 23 | ((product? exp) 24 | (map-derivation (lambda (exp) (deriv exp var)) make-product (get-arg-lst exp))) 25 | ((exponentiation? exp) 26 | (cond ((number? (exponent exp)) 27 | (make-product (list (exponent exp) 28 | (make-exponentiation (base exp) (- (exponent exp) 1)) 29 | (deriv (base exp) var)))) 30 | ((number? (base exp)) 31 | (make-product (list (log (base exp)) 32 | exp 33 | (deriv (exponent exp) var)))) 34 | (else 35 | (make-product (list (make-exponentiation (base exp) (make-sum (list (exponent exp) -1))) 36 | (make-sum (list (make-product (list (exponent exp) 37 | (deriv (base exp) var))) 38 | (make-product (list (base exp) 39 | (deriv (exponent exp) var) 40 | (make-log (base exp))))))))))) 41 | ((log? exp) 42 | (make-product (list (make-exponentiation (get-arg exp) -1) (deriv (get-arg exp) var)))) 43 | ((sin? exp) 44 | (make-product (list (make-cos (get-arg exp)) (deriv (get-arg exp) var)))) 45 | ((cos? exp) 46 | (make-product (list -1 (make-sin (get-arg exp)) (deriv (get-arg exp) var)))) 47 | (else (error "unknown expression type -- DERIV" exp)))) 48 | 49 | ;(deriv '(+ x 2 x x 3) 'x) ;3 50 | ;(deriv '(+ (* x 2) (* x x y 3)) 'x) ;'(+ 2 (+ (* 3 x y) (* 3 x y))) 51 | ;(deriv '(** (+ (* 2 x) y) 3) 'x) ;'(* 6 (** (+ (* 2 x) y) 2)) 52 | ;(deriv '(** 2 (* x y)) 'x) ;'(* 0.6931471805599453 (** 2 (* x y)) y) 53 | ;(deriv '(** x x) 'x) ;'(* (** x (+ -1 x)) (+ x (* x (log x)))) = '(* (** x x) (+ 1 (log x))) 54 | ;(deriv '(log (** x 3)) 'x) ;'(* (** (** x 3) -1) (* 3 (** x 2))) 55 | ;(deriv '(sin (* 3 x)) 'x) ;'(* 3 (cos (* 3 x))) 56 | 57 | ;(deriv '(** (+ 3 (* x 2) y) (sin x)) 'x) 58 | 59 | ;(deriv '(+ x y) '+) ;0 ;It shows a bug that '+ '* are also symbols. The bug is not corrected. 60 | 61 | ;(define xt (make-function 'x 't)) 62 | ;(deriv (list '* xt 3) xt) ;3 63 | ;(deriv (list '* xt 3) 't) ;'(* 3 (deriv (function x t) t)) 64 | ;(deriv (list '* xt 3) 's) ;0 65 | 66 | (define (integrate exp var) 67 | (cond ((number? exp) (make-product (list exp var))) 68 | ((variable? exp) 69 | (if (same-variable? exp var) 70 | (make-product (list (/ 1 2) (make-exponentiation var 2))) 71 | (make-product (list exp var)))) 72 | ((sum? exp) 73 | (make-sum (map 74 | (lambda (arg-lst) (integrate arg-lst var)) 75 | (get-arg-lst exp)))) 76 | ((exponentiation? exp) 77 | (if (and (number? (exponent exp)) (eq? (base exp) var)) 78 | (make-product (list (/ 1 (+ (exponent exp) 1)) 79 | (make-exponentiation var (+ (exponent exp) 1)))) 80 | (error "unknown expression type -- DERIV" exp))) 81 | (else (error "unknown expression type -- DERIV" exp)))) 82 | 83 | ;(integrate '(+ x y 2) 'x) ;'(+ (* (1/2) (** x 2)) (* y x) (* 2 x)) 84 | ;(integrate '(** x 3) 'x) ;'(* (1/4) (** x 4)) -------------------------------------------------------------------------------- /docs/calculus.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Basic Calculus 5 | -------------- 6 | 7 | "Schemannian" can do chain rule level derivations and kindergarten level integrals. It has two functions ``deriv`` and ``integrate``. 8 | 9 | .. code:: scheme 10 | 11 | (deriv exp var) → expression? 12 | exp : expression? 13 | var : expression? 14 | 15 | (integrate exp var) → expression? 16 | exp : expression? 17 | var : variable? 18 | 19 | Notice that in ``deriv``, the independent variable ``var`` can not only be a variable, but also be a complicated expression (e.g., a function). 20 | 21 | Examples of using those two functions are shown as below. 22 | 23 | .. code:: scheme 24 | 25 | (require "calculus.rkt") 26 | 27 | (deriv '(** (+ 3 (* x 2) y) (sin x)) 'x) 28 | (integrate '(+ (** x 3) y 2) 'x) 29 | -------------------------------------------------------------------------------- /docs/data-virtualization.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Data Virtualization 5 | ------------------- 6 | 7 | "Schemannian" supports two functions ``plot`` and ``listplot`` for plotting and data visualization. 8 | 9 | .. code:: scheme 10 | 11 | (plot func x-min x-max y-min y-max) → pict? 12 | func : procedure? 13 | x-min : real? 14 | x-max : real? 15 | y-min : real? 16 | y-max : real? 17 | 18 | (listplot lst x-min x-max y-min y-max) → pict? 19 | lst : list? 20 | x-min : real? 21 | x-max : real? 22 | y-min : real? 23 | y-max : real? 24 | 25 | For ``listplot``, every element in ``lst`` is a list of two numbers (so you can get them by ``car`` and ``cadr``), as the x and y coordinate of the plotting point. 26 | 27 | For example, 28 | 29 | .. code:: scheme 30 | 31 | (require "plot.rkt") 32 | (plot cos 0 10 -2 2) 33 | 34 | gives you a cosine curve of ``y = cos(x)`` in the plotting region ``0 < x < 10`` and ``-2 < y < 2``. 35 | -------------------------------------------------------------------------------- /docs/equation-solving.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Equation Solving 5 | ---------------- 6 | 7 | "Schemannian" can currently a solve equation symbolically, if in which the unknown appears only once. 8 | 9 | .. code:: scheme 10 | 11 | (solve eqn var) → expression? 12 | eqn : expression? 13 | var : expression? 14 | 15 | In function ``solve``, the argument ``eqn`` is a expression with the outest level operator ``'=``. For example, ``'(= x 3)`` describes a equation, while ``'(+ x 3)`` does not. 16 | 17 | Here is an example. 18 | 19 | .. code:: scheme 20 | 21 | (require "solve.rkt") 22 | (solve '(= (** x z) y) 'z) 23 | 24 | gives you 25 | 26 | .. code:: scheme 27 | 28 | '(= z (* (log y) (** (log x) -1))) 29 | -------------------------------------------------------------------------------- /docs/euler-lagrangian-equation.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Euler-Lagrangian Equation 5 | ------------------------- 6 | 7 | Symbolic Calculations 8 | ~~~~~~~~~~~~~~~~~~~~~ 9 | 10 | "Schemannian" can do some symbolic and numerical calculations of the Euler-Lagrangian Equation in classical mechanics. The key functions are ``lagrangian`` and ``euler-lagrangian-equation``, which are defined in ``lagrangian.rkt``. 11 | 12 | .. code:: scheme 13 | 14 | (lagrangian object-lst) → expression? 15 | object-lst : list? 16 | 17 | (euler-lagrangian-equation L coordi-lst coordi-dot-lst time) → expression? 18 | L : expression? 19 | coordi-lst : list? 20 | coordi-dot-lst : list? 21 | time : variable? 22 | 23 | In function ``lagrangian``, ``object-lst`` is a list of closures of mechanical objects with dispatching ``kinetic-energy`` and ``potential-energy``. To make those two functions useful, we defined an example closure ``make-pendulum`` in ``mechanical-objects.rkt``. 24 | 25 | .. code:: scheme 26 | 27 | (make-pendulum mass string-length pivotX pivotY amplitude) → mechanical-object? 28 | mass : expression? 29 | string-length : expression? 30 | pivotX : expression? 31 | pivotY : expression? 32 | amplitude : expression? 33 | 34 | For example, the following code can give you the equation of motion of a symbolic simple pendulum, 35 | 36 | .. code:: scheme 37 | 38 | (require "fundamental.rkt" 39 | "calculus.rkt" 40 | "lagrangian.rkt" 41 | "mechanical-objects.rkt" 42 | "solve.rkt") 43 | 44 | (define pendulum1 45 | (make-pendulum 'm1 'l1 'pivotX1 'pivotY1 (make-function 'theta1 't))) 46 | 47 | (define L1 (lagrangian (list pendulum1))) 48 | (define euler-lagrangian-L1 (euler-lagrangian-equation L1 49 | (list (make-function 'theta1 't)) 50 | (list (deriv (make-function 'theta1 't) 't)) 51 | 't)) 52 | 53 | euler-lagrangian-L1 54 | 55 | which equals 56 | 57 | .. code:: scheme 58 | 59 | '((= (+ (* m1 (** l1 2) (deriv (deriv (function theta1 t) t) t)) (* 9.8 m1 l1 (sin (function theta1 t)))) 0)) 60 | 61 | And this will give you the equation of motion of the double pendulum, 62 | 63 | .. code:: scheme 64 | 65 | (define pendulum1 66 | (make-pendulum 'm1 'l1 'pivotX1 'pivotY1 (make-function 'theta1 't))) 67 | (define pendulum2 68 | (make-pendulum 'm2 'l2 (pendulum1 'X) (pendulum1 'Y) (make-function 'theta2 't))) 69 | 70 | (define L (lagrangian (list pendulum1 pendulum2))) 71 | (define euler-lagrangian-L 72 | (euler-lagrangian-equation L 73 | (list (make-function 'theta1 't) (make-function 'theta2 't)) 74 | (list (deriv (make-function 'theta1 't) 't) 75 | (deriv (make-function 'theta2 't) 't)) 76 | 't)) 77 | 78 | euler-lagrangian-L 79 | 80 | which are two really complicated equations. 81 | 82 | These two examples can be find in `symbolic-simple-pendulum.rkt`_ and `symbolic-double-pendulum.rkt`_. 83 | 84 | .. _symbolic-simple-pendulum.rkt: https://github.com/ozooxo/Schemannian/blob/master/examples/symbolic-simple-pendulum.rkt 85 | .. _symbolic-double-pendulum.rkt: https://github.com/ozooxo/Schemannian/blob/master/examples/symbolic-double-pendulum.rkt 86 | 87 | Virtualization of the Motions 88 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 89 | 90 | "Schemannian" includes an interface which can help you virtualize the motion of the mechanical objects. In order to use this interface, you need to define how your mechanical object looks like in the screen. ``show-mechanical-objects.rkt`` gives an example for single and double pendulum. Roughly speeking, the following functions are being defined. 91 | 92 | .. code:: scheme 93 | 94 | (show-pendulum-in-scene p) → pict? 95 | p : mechanical-object? 96 | 97 | (shoe-multi-pendulum-in-scene p-lst) → pict? 98 | p : list? 99 | 100 | (create-pendulum-moving time) → procedure? 101 | time : number? 102 | 103 | ``p-lst`` is a list of mechanical objects (pendulums). ``create-pendulum-moving`` basically returns a lambda expression which is used together with ``animate`` in the Racket package ``2htdp/universe``. When those things are successfully defined, the following piece of code 104 | 105 | .. code:: scheme 106 | 107 | (require 2htdp/universe 108 | "fundamental.rkt" 109 | "calculus.rkt" 110 | "mechanical-objects.rkt" 111 | "lagrangian.rkt" 112 | "solve.rkt" 113 | "numerical-differential-equation.rkt" 114 | "show-mechanical-objects.rkt") 115 | 116 | (define pendulum1 (make-pendulum 20 250 300 50 (make-function 'theta1 't))) 117 | 118 | (define L1 (lagrangian (list pendulum1))) 119 | (define euler-lagrangian-L1 120 | (euler-lagrangian-equation L1 121 | (list (make-function 'theta1 't)) 122 | (list (deriv (make-function 'theta1 't) 't)) 123 | 't)) 124 | 125 | (define euler-lagrangian-solution 126 | (numerical-solve 127 | (solve (car euler-lagrangian-L1) '(deriv (deriv (function theta1 t) t) t)) 128 | '((function theta1 t) (deriv (function theta1 t) t)) 129 | '(0.3 0) 130 | 0 131 | 0.1)) 132 | 133 | (define solution-next (stream-next euler-lagrangian-solution)) 134 | (animate (lambda (time) ((create-pendulum-moving time) pendulum1 solution-next))) 135 | 136 | can generate the following cartoon. 137 | 138 | .. image:: https://raw.github.com/ozooxo/Schemannian/master/examples/numerical-visualization-simple-pendulum.gif 139 | :height: 528 px 140 | :width: 640 px 141 | :scale: 100 % 142 | :alt: alternate text 143 | :align: center 144 | 145 | This example can be find in `numerical-visualization-simple-pendulum.rkt`_. 146 | 147 | .. _numerical-visualization-simple-pendulum.rkt: https://github.com/ozooxo/Schemannian/blob/master/examples/numerical-visualization-simple-pendulum.rkt 148 | 149 | People may also expect "Schemannian" to virtualize some more fancy mechanical process, such as the double pendulum. This is still quite hard until now, although it is easy to draw two pendulums together in the screen (we already realized that by the function ``shoe-multi-pendulum-in-scene`` in ``show-mechanical-objects.rkt``). 150 | 151 | The reason is that double pendulum gives a quite complicated equation of motion, in which `d^2 theta1 / d t^2` and `d^2 theta2 / d t^2` are entangled to each other. So "Schemannian" need to know first how to solve a set of simultaneous equations in general. In addition, it also need to know how to numerically solve simultaneous differential equations. It currently doesn't have both support functions. 152 | -------------------------------------------------------------------------------- /docs/expressions.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Expressions 5 | ----------- 6 | 7 | Representation 8 | ~~~~~~~~~~~~~~ 9 | 10 | Following the Lisp family rule, "Schemannian" uses prefix notations for a representation of the symbolic expressions. Every value in a list can be either a number or a symbol. The current supported operations (which are noted as symbols) includes ``'=``, ``'+``, ``'*``, ``'**`` (exponential function), ``'log``, ``'sin``, and ``'cos``. To support differential equation related topics, there are two special tags includes ``'function`` and ``'deriv``. 11 | 12 | For example, Newton's law of universal gravitation :math:`F = (G m1 m2)/r^2` can be expressed as 13 | 14 | .. code:: scheme 15 | 16 | '(= F (* G m1 m2 (** r -2))) 17 | 18 | One of the trigonometric identities :math:`sin(x+y) = sin(x) cos(y) + cos(x) sin(y)` can be expressed as 19 | 20 | .. code:: scheme 21 | 22 | '(= (sin (+ x y)) (+ (* (sin x) (cos y)) (* (cos x) (sin y)))) 23 | 24 | And the Lagrangian of a simple pendulum can be expressed as 25 | 26 | .. code:: scheme 27 | 28 | '(+ (* -1 g m1 (+ pivotY1 (* -1 l1 (cos (function theta1 t))))) 29 | (* 0.5 m1 (** l1 2) (** (deriv (function theta1 t) t) 2))) 30 | 31 | Constructing Functions 32 | ~~~~~~~~~~~~~~~~~~~~~~ 33 | 34 | In addition, "Schemannian" supports several constructing functions. By using those functions, the functions can be independent of the detail of the representation we are chosen. Those functions can also do some preliminary simplification of the expressions. To use those functions, you need to first import the fundamental package. 35 | 36 | .. code:: scheme 37 | 38 | (require "fundamental.rkt") 39 | 40 | A incomplete list of the constructing functions are shown as below. 41 | 42 | .. code:: scheme 43 | 44 | (get-op exp) → symbol? 45 | exp : expression? 46 | 47 | (get-arg-lst exp) → list? 48 | exp : expression? 49 | 50 | (get-arg exp) → symbol? 51 | exp : expression? 52 | 53 | (make-function f x) → function? 54 | f : expression? 55 | x : variable? 56 | 57 | (make-deriv f x) → deriv? 58 | f : expression? 59 | x : variable? 60 | 61 | (make-sum args) → expression? 62 | args : list? 63 | 64 | (make-product args) → expression? 65 | args : list? 66 | 67 | (make-exponentiation x n) → expression? 68 | x : expression? 69 | n : expression? 70 | 71 | (make-abs x) → expression? 72 | (make-log x) → expression? 73 | (make-sin x) → expression? 74 | (make-cos x) → expression? 75 | x : expression? 76 | -------------------------------------------------------------------------------- /docs/grassmannian-calculus.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Grassmannian Calculus 5 | --------------------- 6 | 7 | "Schemannian" can do some easy Grassmannian calculus. To use that, you want to first include the relavent file. 8 | 9 | .. code:: scheme 10 | 11 | (require "grassmannian-calculus.rkt") 12 | 13 | In the current design, Grassmannian numbers are made by ``make-grassmannian``; however, they add and multiple normal numbers by normal expressions (i.e., it doesn't cover the normal numbers by further tag system). 14 | 15 | .. code:: scheme 16 | 17 | (make-grassmannian x) → grassmannian? 18 | x : expression? 19 | 20 | Current supported functions include 21 | 22 | .. code:: scheme 23 | 24 | (simplify-grassmannian exp) → grassmannian? 25 | exp : grassmannian? 26 | 27 | (grassmannian-integrate exp var) → expression? 28 | exp : expression? 29 | var : grassmannian? 30 | 31 | (grassmannian-deriv exp var) → expression? 32 | exp : expression? 33 | var : grassmannian? 34 | 35 | in which the ``exp`` is basically some superfield, or say, normal expressions with some elements in it are grassmannian numbers. 36 | 37 | For example, here is a piece of code about a two-dimensional superfield 38 | 39 | .. code:: scheme 40 | 41 | (require "grassmannian-calculus.rkt") 42 | 43 | (define theta1 (make-grassmannian 'theta1)) 44 | (define theta2 (make-grassmannian 'theta2)) 45 | 46 | (define superfield (make-sum (list 'a 47 | (make-product (list theta1 'b1)) 48 | (make-product (list theta2 'b2)) 49 | (make-product (list theta1 theta2 'c))))) 50 | 51 | (grassmannian-integrate superfield theta1) 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /docs/linear-algebra.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Linear Algebra 5 | -------------- 6 | 7 | "Schemannian" can do basic symbolic and numerical linear algebra. 8 | 9 | In "Schemannian", vectors are one-dimensional scheme list such as ``'(1 2 a 3 b)``, and matrices are two-dimensional list such as ``'((a 1) (2 b))``. Notice that every element in a vector/matrix is an expression, so ``'(1 (+ a b))`` is a vector. Current supported functions include 10 | 11 | .. code:: scheme 12 | 13 | (dot-product-vector v w) → expression? 14 | v : linear-algebra-vector? 15 | w : linear-algebra-vector? 16 | 17 | (matrix-*-vector m v) → linear-algebra-vector? 18 | m : linear-algebra-matrix? 19 | v : linear-algebra-vector? 20 | 21 | (transpose-mat m) → linear-algebra-matrix? 22 | m : linear-algebra-matrix? 23 | 24 | (matrix-*-matrix m n) → linear-algebra-matrix? 25 | m : linear-algebra-matrix? 26 | n : linear-algebra-matrix? 27 | 28 | (mat-trace m) → expression? 29 | m : linear-algebra-matrix? 30 | 31 | (mat-determinant m) → expression? 32 | m : linear-algebra-matrix? 33 | 34 | (mat-inverse m) → linear-algebra-matrix? 35 | m : linear-algebra-matrix? 36 | 37 | For example, 38 | 39 | .. code:: scheme 40 | 41 | (require "linear-algebra.rkt") 42 | (define m '((a b c) (d e f) (g h i))) 43 | (mat-determinant m) 44 | 45 | should give you 46 | 47 | .. code:: scheme 48 | 49 | '(+ (* (+ (* i e) (* -1 f h)) a) (* -1 (+ (* i b) (* -1 c h)) d) (* (+ (* f b) (* -1 c e)) g)) 50 | -------------------------------------------------------------------------------- /docs/numerical-differential-equation.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Numerical Differential Equation Solving 5 | --------------------------------------- 6 | 7 | "Schemannian" can currently numerically solve a differential equation of arbitrary order. 8 | 9 | .. code:: scheme 10 | 11 | (numerical-solve eqn initial-exp-lst initial-lst num-var num-dvar) → stream? 12 | eqn : expression? 13 | initial-exp-lst : list? 14 | initial-lst : list? 15 | num-var : number? 16 | num-dvar : number? 17 | 18 | In function ``numerical-solve``, the argument ``eqn`` is a expression with the outest level operator ``'=``, ``initial-exp-lst`` is a list of expressions, i.e., the unknown function (dependent variable) and its derivatives, and ``initial-lst`` is a list of numbers. 19 | 20 | The output is a stream of pairs, with ``car`` as a stream of numbers of the independent variable, and ``cdr`` as a stream of lists with elements as the values of the unknown function and its derivatives, starts from the ``initial-lst``. 21 | 22 | Here is an example. 23 | 24 | .. code:: scheme 25 | 26 | (require "numerical-differential-equation.rkt") 27 | (define solution (numerical-solve '(= (deriv (deriv (function theta1 t) t) t) (* -1 (sin (function theta1 t)))) 28 | '((function theta1 t) (deriv (function theta1 t) t)) 29 | '(1 0) 30 | 0 31 | 0.1)) 32 | -------------------------------------------------------------------------------- /docs/riemannian-geometry-general-relativity.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Riemannian Geometry and General Relativity 5 | ------------------------------------------ 6 | 7 | "Schemannian" supports functions to calculate typical General Relativity expressions such as Christoffel symbols, Riemann curvature tensor, Ricci curvature tensor, and Ricci scalar from the metric. To support those calculations, it can also do some general tensor operations. 8 | 9 | Tensor Operations 10 | ~~~~~~~~~~~~~~~~~ 11 | 12 | .. code:: scheme 13 | 14 | (make-scalar x) → scalar? 15 | x : expression? 16 | 17 | (make-tensor index-lst contents-matrix) → tensor? 18 | index-lst : list? 19 | contents-matrix : list? 20 | 21 | The two constructing functions above are used to make scalars and tensors. In ``make-tensor``, ``contents-matrix`` is a ``(length index-lst)``-ranked nested list with elements of the tensor. 22 | 23 | ``scalar`` and ``tensor`` supports generic operations such ass ``add``, ``mul``, ``simplify-generic``, and ``partial-deriv``. 24 | 25 | .. code:: scheme 26 | 27 | (add x y) 28 | (mul x y) 29 | (simplify-generic x) 30 | (partial-deriv fx x) 31 | 32 | For ``add``, the two addends need to be either scalars or tensors of the same form (same rank and dimensions). ``mul`` actually means tensor product; to ``mul`` a tensor of rank ``m`` and a tensor of rank ``n``, you got a tensor of rank ``m*n``. ``simplify-generic`` just simplifies every scalar element individually. For ``(partial-deriv fx x)``, if both ``fx`` and ``x`` are scalars, it is just normal ``deriv``; for all the other combinations, if ``fx`` has rank ``m`` (scalar has rank ``1``), ``x`` has rank ``n``, the ``(partial-deriv fx x)`` is a ``m*n``-ranked tensor. 33 | 34 | In addition, some other questions has been defined as below. 35 | 36 | .. code:: scheme 37 | 38 | (switch-index aim-index-lst tnsr) → tensor? 39 | aim-index-lst : list? 40 | tnsr : tensor? 41 | 42 | (switch-index aim-index-lst tnsr) → tensor? 43 | aim-index-lst : list? 44 | tnsr : tensor? 45 | 46 | (scalar-mul k x) → tensor? 47 | k : expression? 48 | x : tensor? 49 | 50 | ``change-index`` just changes the indices of the tensor, but doesn't do anything for the content elements of the tensor. ``switch-index`` does not only change the indices of the tensor, but also transpose the content elements of tensor following the new order of the indices. 51 | 52 | To use all those tensor related functions, you need to first 53 | 54 | .. code:: scheme 55 | 56 | (require "tensor.rkt") 57 | 58 | Riemannian Geometry 59 | ~~~~~~~~~~~~~~~~~~~ 60 | 61 | "Schemannian" has several useful functions in package 62 | 63 | .. code:: scheme 64 | 65 | (require "riemannian.rkt") 66 | 67 | for Riemannian geometry calculations. 68 | 69 | .. code:: scheme 70 | 71 | (einstein-summation tnsr) → tensor? 72 | tnsr : tensor? 73 | 74 | sums over the repeated indices of a tensor. 75 | 76 | ``metric`` is just a rank-2 tensor. You can upper or lower its indices by 77 | 78 | .. code:: scheme 79 | 80 | (metric upper-lower-lst tnsr) → tensor? 81 | upper-lower-lst : list? 82 | tnsr : tensor? 83 | 84 | in which ``upper-lower-lst`` is just a list of either ``'(_ _)``, ``'(_ ^)``, ``'(^ _)``, or ``'(^ ^)``. Therefore, `metric-einstein-summation.rkt`_ gives you identity. 85 | 86 | .. _metric-einstein-summation.rkt: https://github.com/ozooxo/Schemannian/blob/master/examples/metric-einstein-summation.rkt 87 | 88 | .. code:: scheme 89 | 90 | (require "tensor.rkt" 91 | "riemannian.rkt") 92 | 93 | (define g (make-tensor '((_ a) (_ b)) '((a b c d) (e f g h) (i j k l) (m n o p)))) 94 | (einstein-summation (mul (change-index '((^ a) (^ b)) (metric '(^ ^) g)) 95 | (change-index '((_ b) (_ c)) (metric '(_ _) g)))) 96 | 97 | The General Relativity aimed functions are 98 | 99 | .. code:: scheme 100 | 101 | (christoffel index-lst g-tensor coordinate-lst) → tensor? 102 | index-lst : list? 103 | g-tensor : tensor? 104 | coordinate-lst : list? 105 | 106 | (riemann-tensor index-lst christoffel-gamma coordinate-lst) → tensor? 107 | index-lst : list? 108 | christoffel-gamma : tensor? 109 | coordinate-lst : list? 110 | 111 | (ricci-curvature-tensor index-lst riemann-tnsr) → tensor? 112 | index-lst : list? 113 | riemann-tnsr : tensor? 114 | 115 | (ricci-scalar g-tnsr ricci-tnsr) → scalar? 116 | g-tnsr : tensor? 117 | ricci-tnsr : tensor? 118 | 119 | For example, `curvature-surface-of-sphere.rkt`_ calculates the curvature on the surface of a sphere, which is ``'(scalar * 2 (** r -2))``. 120 | 121 | .. _curvature-surface-of-sphere.rkt: https://github.com/ozooxo/Schemannian/blob/master/examples/curvature-surface-of-sphere.rkt 122 | 123 | .. code:: scheme 124 | 125 | (require "tensor.rkt" 126 | "riemannian.rkt") 127 | 128 | (define g (make-tensor '((_ a) (_ b)) 129 | '(((** r 2) 0) 130 | (0 (* (** r 2) (** (sin theta) 2)))))) 131 | 132 | (define Gamma^a_bc (christoffel '((^ a) (_ b) (_ c)) g '(theta phi))) 133 | (define R^a_bcd (riemann-tensor '((^ a) (_ b) (_ c) (_ d)) Gamma^a_bc '(theta phi))) 134 | (define R_ab (ricci-curvature-tensor '((_ a) (_ b)) R^a_bcd)) 135 | (ricci-scalar g R_ab) 136 | 137 | And `curvature-schwarzschild.rkt`_ calculates the curvature of the Schwarzschild metric, which is ``'(scalar 0)`` (You can check the output by hand, although the current ``simplify`` function is a little bit too weak to actually get that). 138 | 139 | .. _curvature-schwarzschild.rkt: https://github.com/ozooxo/Schemannian/blob/master/examples/curvature-schwarzschild.rkt 140 | 141 | .. code:: scheme 142 | 143 | (define g (make-tensor '((_ a) (_ b)) 144 | '(((+ 1 (* -1 rs (** r -1))) 0 0 0) 145 | (0 (* -1 (** (+ 1 (* -1 rs (** r -1))) -1)) 0 0) 146 | (0 0 (* -1 (** r 2)) 0) 147 | (0 0 0 (* -1 (** r 2) (** (sin theta) 2)))))) 148 | 149 | (define Gamma^a_bc (christoffel '((^ a) (_ b) (_ c)) g '(t r theta phi))) 150 | (define R^a_bcd (riemann-tensor '((^ a) (_ b) (_ c) (_ d)) Gamma^a_bc '(t r theta phi))) 151 | (define R_ab (ricci-curvature-tensor '((_ a) (_ b)) R^a_bcd)) 152 | (ricci-scalar g R_ab) 153 | -------------------------------------------------------------------------------- /docs/simplify.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Simplification of Expressions 5 | ----------------------------- 6 | 7 | "Schemannian" supports a function called ``simplify``, which have some ability on the simplification of algebraic expressions, such as combining like terms by distributive property of multiplication, using Pythagorean trigonometric identity to simplify ``(+ (** (sin x) 2) (** (cos x) 2))`` to ``1``, removing common factors for "fractions" whose numerator and denominator are both functions, etc. 8 | 9 | Here is the function ``simplify``. 10 | 11 | .. code:: scheme 12 | 13 | (simplify exp) → expression? 14 | exp : expression? 15 | 16 | To use it, for example, if we do 17 | 18 | .. code:: scheme 19 | 20 | (require "simplify.rkt") 21 | (simplify '(+ x y 1 (* 5 a) (* 6 a (** (cos (* z w)) 2)) (* 6 (** (sin (* z w)) 2) a))) 22 | 23 | it will give us ``'(+ 1 y x (* 11 a))``. There are several more relastic examples while using other functions (e.g., while calculating the Euler-Lagrangian equation, or the Ricci scalar). 24 | -------------------------------------------------------------------------------- /docs/virtualization-of-expressions.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozooxo/Schemannian/d49f6a015ae46e41df0e37a56237e0ae22379566/docs/virtualization-of-expressions.png -------------------------------------------------------------------------------- /docs/virtualization-of-expressions.rst: -------------------------------------------------------------------------------- 1 | The Schemannian Reference 2 | ========================= 3 | 4 | Virtualization of Expressions 5 | ----------------------------- 6 | 7 | "Schemannian" has a small package to virtualize expressions. By using this package, you can turn the quite confusing prefix notations to something which is quite clear and human readable. To use this package, you need to first 8 | 9 | .. code:: scheme 10 | 11 | (require "show-expression.rkt") 12 | 13 | To use that, you have the function ``show-expression``. 14 | 15 | .. code:: scheme 16 | 17 | (show-expression exp) → pict? 18 | exp : expression? 19 | 20 | For example, 21 | 22 | .. code:: scheme 23 | 24 | (show-expression '(= (+ (* (+ 1 (sin x) (cos x)) (** (+ 1 (sin x) (* -1 (cos x))) -1)) 25 | (* (+ 1 (sin x) (* -1 (cos x))) (** (+ 1 (sin x) (cos x)) -1))) 26 | (* 2 (** (cos x) -1)))) 27 | 28 | will gives you 29 | 30 | .. image:: https://raw.github.com/ozooxo/Schemannian/master/docs/virtualization-of-expressions.png 31 | :height: 63 px 32 | :width: 508 px 33 | :scale: 100 % 34 | :alt: alternate text 35 | :align: center 36 | -------------------------------------------------------------------------------- /examples/curvature-schwarzschild.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../tensor.rkt" 4 | "../riemannian.rkt") 5 | 6 | ;;; 7 | 8 | (define g (make-tensor '((_ a) (_ b)) 9 | '(((+ 1 (* -1 rs (** r -1))) 0 0 0) 10 | (0 (* -1 (** (+ 1 (* -1 rs (** r -1))) -1)) 0 0) 11 | (0 0 (* -1 (** r 2)) 0) 12 | (0 0 0 (* -1 (** r 2) (** (sin theta) 2)))))) 13 | (define Gamma^a_bc (christoffel '((^ a) (_ b) (_ c)) g '(t r theta phi))) 14 | ;Gamma^a_bc 15 | (define R^a_bcd (riemann-tensor '((^ a) (_ b) (_ c) (_ d)) Gamma^a_bc '(t r theta phi))) 16 | ;R^a_bcd 17 | (define R_ab (ricci-curvature-tensor '((_ a) (_ b)) R^a_bcd)) 18 | ;R_ab 19 | (ricci-scalar g R_ab) ;By checking the result by hand, it is actually zero. 20 | ;Although the current simplify function cannot get it. -------------------------------------------------------------------------------- /examples/curvature-surface-of-sphere.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../tensor.rkt" 4 | "../riemannian.rkt") 5 | 6 | ;;; 7 | 8 | (define g (make-tensor '((_ a) (_ b)) 9 | '(((** r 2) 0) 10 | (0 (* (** r 2) (** (sin theta) 2)))))) 11 | 12 | (define Gamma^a_bc (christoffel '((^ a) (_ b) (_ c)) g '(theta phi))) 13 | ;Gamma^a_bc 14 | (define R^a_bcd (riemann-tensor '((^ a) (_ b) (_ c) (_ d)) Gamma^a_bc '(theta phi))) 15 | ;R^a_bcd 16 | (define R_ab (ricci-curvature-tensor '((_ a) (_ b)) R^a_bcd)) 17 | ;R_ab 18 | (ricci-scalar g R_ab) 19 | ;'(scalar * 2 (** r -2)) ;which is correct. -------------------------------------------------------------------------------- /examples/metric-einstein-summation.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../tensor.rkt" 4 | "../riemannian.rkt") 5 | 6 | (define g (make-tensor '((_ a) (_ b)) '((a b c d) (e f g h) (i j k l) (m n o p)))) 7 | (einstein-summation (mul (change-index '((^ a) (^ b)) (metric '(^ ^) g)) 8 | (change-index '((_ b) (_ c)) (metric '(_ _) g)))) 9 | 10 | ;'(tensor 11 | ; ((^ a) (_ c)) 12 | ; ((scalar . 1) (scalar . 0) (scalar . 0) (scalar . 0)) 13 | ; ((scalar . 0) (scalar . 1) (scalar . 0) (scalar . 0)) 14 | ; ((scalar . 0) (scalar . 0) (scalar . 1) (scalar . 0)) 15 | ; ((scalar . 0) (scalar . 0) (scalar . 0) (scalar . 1))) -------------------------------------------------------------------------------- /examples/numerical-visualization-simple-pendulum.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozooxo/Schemannian/d49f6a015ae46e41df0e37a56237e0ae22379566/examples/numerical-visualization-simple-pendulum.gif -------------------------------------------------------------------------------- /examples/numerical-visualization-simple-pendulum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 2htdp/universe 4 | "../fundamental.rkt" 5 | "../calculus.rkt" 6 | "../mechanical-objects.rkt" 7 | "../lagrangian.rkt" 8 | "../solve.rkt" 9 | "../numerical-differential-equation.rkt" 10 | "../show-mechanical-objects.rkt") 11 | 12 | ;;; 13 | 14 | (define pendulum1 (make-pendulum 20 250 300 50 (make-function 'theta1 't))) 15 | 16 | (define L1 (lagrangian (list pendulum1))) 17 | (define euler-lagrangian-L1 18 | (euler-lagrangian-equation L1 19 | (list (make-function 'theta1 't)) 20 | (list (deriv (make-function 'theta1 't) 't)) 21 | 't)) 22 | 23 | euler-lagrangian-L1 24 | ;print out the Euler Lagrangian equation: 25 | ;'((= (+ (* 1250000.0 (deriv (deriv (function theta1 t) t) t)) (* 49000.0 (sin (function theta1 t)))) 0)) 26 | 27 | (define euler-lagrangian-solution 28 | (numerical-solve 29 | (solve (car euler-lagrangian-L1) '(deriv (deriv (function theta1 t) t) t)) 30 | '((function theta1 t) (deriv (function theta1 t) t)) 31 | '(0.3 0) 32 | 0 33 | 0.1)) ;this parameter adjusts how quickly the times goes can be. 34 | ;(stream-take 10 euler-lagrangian-solution) 35 | 36 | (define solution-next (stream-next euler-lagrangian-solution)) 37 | (animate (lambda (time) ((create-pendulum-moving time) pendulum1 solution-next))) 38 | ;show video of a simple pendulum. -------------------------------------------------------------------------------- /examples/symbolic-double-pendulum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../fundamental.rkt" 4 | "../calculus.rkt" 5 | "../lagrangian.rkt" 6 | "../mechanical-objects.rkt" 7 | "../solve.rkt") 8 | 9 | ;;; 10 | 11 | (define pendulum1 (make-pendulum 'm1 'l1 'pivotX1 'pivotY1 (make-function 'theta1 't))) 12 | (define pendulum2 (make-pendulum 'm2 'l2 (pendulum1 'X) (pendulum1 'Y) (make-function 'theta2 't))) 13 | 14 | (define L (lagrangian (list pendulum1 pendulum2))) 15 | L 16 | (define euler-lagrangian-L 17 | (euler-lagrangian-equation L 18 | (list (make-function 'theta1 't) (make-function 'theta2 't)) 19 | (list (deriv (make-function 'theta1 't) 't) (deriv (make-function 'theta2 't) 't)) 20 | 't)) 21 | 22 | euler-lagrangian-L 23 | ;print out the symbolic equations of motion for double pendulum. 24 | ;there are two equations, but they are really complicated. -------------------------------------------------------------------------------- /examples/symbolic-simple-pendulum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "../fundamental.rkt" 4 | "../calculus.rkt" 5 | "../lagrangian.rkt" 6 | "../mechanical-objects.rkt" 7 | "../solve.rkt") 8 | 9 | ;;; 10 | 11 | (define pendulum1 (make-pendulum 'm1 'l1 'pivotX1 'pivotY1 (make-function 'theta1 't))) 12 | 13 | (define L1 (lagrangian (list pendulum1))) 14 | L1 ;'(+ (* -9.8 m1 (+ pivotY1 (* -1 l1 (cos (function theta1 t))))) (* 0.5 m1 (** l1 2) (** (deriv (function theta1 t) t) 2))) 15 | 16 | (define euler-lagrangian-L1 17 | (euler-lagrangian-equation L1 18 | (list (make-function 'theta1 't)) 19 | (list (deriv (make-function 'theta1 't) 't)) 20 | 't)) 21 | 22 | euler-lagrangian-L1 23 | ;print out the symbolic equation of motion for simple pendulum 24 | ;'((= (+ (* m1 (** l1 2) (deriv (deriv (function theta1 t) t) t)) (* 9.8 m1 l1 (sin (function theta1 t)))) 0)) -------------------------------------------------------------------------------- /fundamental.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/stream 4 | racket/generator) 5 | 6 | (provide (all-defined-out)) 7 | 8 | ;;; 9 | 10 | (define (variable? x) (symbol? x)) 11 | (define (same-variable? v1 v2) 12 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 13 | 14 | (define (expression? x) 15 | (or (number? x) (variable? x) (pair? x))) 16 | 17 | (define (=number? exp num) 18 | (and (number? exp) (= exp num))) 19 | 20 | (define (get-op exp) (car exp)) 21 | (define (get-arg-lst exp) (cdr exp)) 22 | (define (get-arg exp) (cadr exp)) 23 | 24 | ;;; 25 | 26 | ;If there's only one argument 27 | ;(define (function-chain f g) (lambda (x) (f (g x)))) 28 | (define (function-chain f-lst) 29 | (if (null? (cdr f-lst)) 30 | (lambda (x) ((car f-lst) x)) 31 | (lambda (x) ((car f-lst) ((function-chain (cdr f-lst)) x))))) 32 | ;((function-chain (list sin cos)) 1) ;0.5143952585235492 33 | 34 | (define (and-lst lsts) 35 | (define (and-lst-recur lsts) 36 | (cond ((null? lsts) true) 37 | ((eq? (car lsts) true) (and-lst-recur (cdr lsts))) 38 | ((eq? (car lsts) false) false))) 39 | (and-lst-recur lsts)) 40 | 41 | ;(and-lst (list true true)) 42 | ;(and-lst (list true false)) 43 | 44 | ;;; 45 | 46 | (define (symbol=? x y) (string=? (symbol->string x) (symbol->string y))) 47 | (define (symbolstring x) (symbol->string y))) 48 | (define (symbol<=? x y) (string<=? (symbol->string x) (symbol->string y))) 49 | (define (symbol>? x y) (string>? (symbol->string x) (symbol->string y))) 50 | (define (symbol>=? x y) (string>=? (symbol->string x) (symbol->string y))) 51 | 52 | (define (expression? (car x) (car y)) false) 63 | (else (expression? x y) 67 | (cond ((and (null? x) (null? y)) false) 68 | ((and (number? x) (number? y)) (> x y)) 69 | ((number? x) false) 70 | ((number? y) true) 71 | ((and (symbol? x) (symbol? y)) (symbol>? x y)) 72 | ((symbol? x) false) 73 | ((symbol? y) true) 74 | ((and (pair? x) (pair? y)) 75 | (cond ((expression>? (car x) (car y)) true) 76 | ((expression? (cdr x) (cdr y))))) 78 | (else ("Not an expression" x y)))) 79 | 80 | ;(expression? '(+ c d) '(+ a b)) ;#t 85 | ;(expression>? '(+ a b) '(+ c d)) ;#f 86 | 87 | ;(sort '((+ x y) 2 3 (+ 3 x) 2 (* x 5) (* x y)) expression?) ;'((+ x y) (+ 3 x) (* x y) (* x 5) 3 2 2) 89 | 90 | ;;; 91 | 92 | ;It is not the same as the Racket "reverse", as it has two arguments. 93 | (define (list-reverse torev-seq done-seq) 94 | (if (eq? torev-seq '()) 95 | done-seq 96 | (list-reverse (cdr torev-seq) (cons (car torev-seq) done-seq)))) 97 | 98 | ;To be consistent with "list-ref" in Racket, The first element has index 0. 99 | (define (list-delete lst pos) 100 | (cond ((null? lst) (error "Index out of range")) 101 | ((= 0 pos) (cdr lst)) 102 | (else (cons (car lst) (list-delete (cdr lst) (- pos 1)))))) 103 | 104 | ;(list-delete '(a b c d) 2) ;'(a b d) 105 | ;(list-delete '(a b c d) 5) ;Index out of range 106 | 107 | ;It works exactly the same as the function "take" while (require racket/list). 108 | (define (list-take lst pos) 109 | (define (list-flip new-lst old-lst count) 110 | (cond ((= 0 count) new-lst) 111 | ((null? old-lst) (error "Position doesn't exist in list" pos lst)) 112 | (else (list-flip (cons (car old-lst) new-lst) (cdr old-lst) (- count 1))))) 113 | (reverse (list-flip '() lst pos))) 114 | 115 | ;(list-take '(1 2 3 4) 3) ;'(1 2 3) 116 | ;(list-take '(1 2 3 4) 6) ;error 117 | 118 | (define (list-remove ele lst) 119 | (define (list-flip new-lst old-lst) 120 | (cond ((null? old-lst) false) 121 | ((eq? ele (car old-lst)) (list-reverse new-lst (cdr old-lst))) 122 | (else (list-flip (cons (car old-lst) new-lst) (cdr old-lst))))) 123 | (list-flip '() lst)) 124 | 125 | ;(list-remove 2 '(1 2 3 4)) ;'(1 3 4) 126 | ;(list-remove 2 '(1 2 3 2 4)) ;'(1 3 2 4) 127 | ;(list-remove 5 '(1 2 3 4)) ;#f 128 | 129 | (define (list-intersect lsts) 130 | (set->list (apply set-intersect (map list->set lsts)))) 131 | ;(list-intersect '((x y 1) (y 2 x) (x 2 3))) ;'(x) 132 | ;(list-intersect '((x y 1 x) (y 2 x x) (x 2 3 x))) ;'(x) ;It currently doesn't count duplicate element. 133 | 134 | (define (list-mixed-up lst ele) 135 | (cond ((null? lst) '()) 136 | ((null? (cdr lst)) lst) 137 | (else (cons (car lst) (cons ele (list-mixed-up (cdr lst) ele)))))) 138 | 139 | ;(list-mixed-up '(x y z w) 'a) ;'(x a y a z a w) 140 | 141 | (define (members v-lst lst) 142 | (define (members-iter v-lst lst) 143 | (if (null? v-lst) 144 | true 145 | (if (member (car v-lst) lst) 146 | (members-iter (cdr v-lst) lst) 147 | false))) 148 | (members-iter v-lst lst)) 149 | 150 | ;(members '(1 2 3) '(2 3 1 4 5)) ;#t 151 | ;(members '(1 2 3) '(2 3 4 5 6)) ;#f 152 | 153 | (define (removes v-lst lst) 154 | (define (removes-iter v-lst lst) 155 | (if (null? v-lst) 156 | lst 157 | (removes-iter (cdr v-lst) (remove (car v-lst) lst)))) 158 | (removes-iter v-lst lst)) 159 | 160 | ;(removes '(1 3 5) '(3 4 5 1 2)) ;'(4 2) 161 | ;(removes '(1 3 5) '(3 4 5 1 2 1)) ;'(4 2 1) 162 | 163 | (define (index element lst) ;The first element has index 0 164 | (define (index-iter element lst passed-index) 165 | (cond ((null? lst) false) ;(error "Not find in list -- INDEX" element lst)) 166 | ((equal? (car lst) element) passed-index) 167 | (else (index-iter element (cdr lst) (+ passed-index 1))))) 168 | (index-iter element lst 0)) 169 | 170 | ;(index 5 (list 1 3 5 7)) ;2 171 | ;(index 0 (list 1 3 5 7)) ;#f 172 | 173 | ;(index '(x y) '(w z (x y) 1 2)) ;2 ;It also works for complicated case. 174 | 175 | (define (index-in element nested-lst) 176 | (define (index-in-iter nested-lst passed-index) 177 | (cond ((null? nested-lst) false) 178 | ((not (eq? (index element (car nested-lst)) false)) passed-index) 179 | (else (index-in-iter (cdr nested-lst) (+ passed-index 1))))) 180 | (index-in-iter nested-lst 0)) 181 | 182 | ;(index-in 'c '((a b) (c d) (e f))) ;1 183 | ;(index-in 'g '((a b) (c d) (e f))) ;#f 184 | 185 | (define (element-combination lsts) 186 | (cond ((null? lsts) '()) 187 | ((null? (cdr lsts)) (map list (car lsts))) 188 | (else (apply append (map (lambda (x) (map (lambda (y) (cons y x)) (car lsts))) (element-combination (cdr lsts))))))) 189 | 190 | ;(element-combination '((a b c))) ;'((a) (b) (c)) 191 | ;(element-combination '((a b) (d e))) ;'((a d) (b d) (a e) (b e)) 192 | ;(element-combination '((a b) (d e) (f g))) ;'((a d f) (b d f) (a e f) (b e f) (a d g) (b d g) (a e g) (b e g)) 193 | 194 | (define (counter lst) 195 | (define counter-hash (make-hash)) 196 | (define (put-to-hash ele) 197 | (if (hash-has-key? counter-hash ele) 198 | (hash-set! counter-hash ele (+ (hash-ref counter-hash ele) 1)) 199 | (hash-set! counter-hash ele 1))) 200 | (begin 201 | (map put-to-hash lst) 202 | counter-hash)) 203 | 204 | ;(counter '(a a b a c a d d b e)) ;'#hash((a . 4) (d . 2) (c . 1) (e . 1) (b . 2)) 205 | ;(counter '((+ a b) (+ c d) (+ 1 2) (+ a b) c)) ;'#hash(((+ c d) . 1) ((+ 1 2) . 1) (c . 1) ((+ a b) . 2)) 206 | 207 | (define (stream-take n s) 208 | (if (= n 0) 209 | '() 210 | (cons (stream-first s) (stream-take (- n 1) (stream-rest s))))) 211 | 212 | (define (stream-next strm) 213 | (generator () 214 | (let loop ([x strm]) 215 | (if (null? x) 216 | 0 217 | (begin 218 | (yield (stream-first x)) 219 | (loop (stream-rest x))))))) 220 | 221 | ;(define (map-n dim prop lst) 222 | ; (if (= dim 1) 223 | ; (map prop lst) 224 | ; (map (lambda (lst) (map-n (- dim 1) prop lst)) lst))) 225 | ;In the above form, "prop" can only have one argument. 226 | ;In the bottom form, arbitrary number of arguments are okay. 227 | (define (map-n dim prop . lst) 228 | (if (= dim 1) 229 | (apply map (cons prop lst)) 230 | (apply map (cons (lambda lst (apply map-n (append (list (- dim 1) prop) lst))) lst)))) 231 | 232 | ;(define fx (lambda (x) (+ 2 x))) 233 | ;(map-n 1 fx (list 1 2)) ;'(3 4) 234 | ;(map-n 1 + (list 3 4) (list 1 2)) ;'(4 6) 235 | ;(map-n 2 fx (list (list 1 2) (list 3 4))) ;'((3 4) (5 6)) 236 | ;(map-n 2 + (list (list 1 2) (list 3 4)) (list (list 5 6) (list 7 8))) ;'((6 8) (10 12)) 237 | 238 | (define (exp-replace exp to-replace-lst replace-lst) 239 | (cond ((member exp to-replace-lst) (list-ref replace-lst (index exp to-replace-lst))) 240 | ((or (number? exp) (variable? exp)) exp) 241 | (else (map (lambda (x) (exp-replace x to-replace-lst replace-lst)) exp)))) 242 | 243 | ;(exp-replace '(+ 2 (* x y) (* y (+ z (* x y))) z (* x y)) '((* x y)) '(w)) ;'(+ 2 w (* y (+ z w)) z w) 244 | 245 | (define (accumulate op initial sequence) 246 | (if (null? sequence) 247 | initial 248 | (op (car sequence) 249 | (accumulate op initial (cdr sequence))))) 250 | 251 | (define (accumulate-n op init seqs) 252 | (if (null? (car seqs)) 253 | '() 254 | (cons (accumulate op init (accumulate (lambda (x y) (cons (car x) y)) '() seqs)) 255 | (accumulate-n op init (accumulate (lambda (x y) (cons (cdr x) y)) '() seqs))))) 256 | 257 | (define (gather-num op-for-num unit-num sequence) 258 | (define (gather-num-recur sequence) 259 | (if (null? sequence) 260 | (list unit-num) 261 | (let ([sequence-after (gather-num-recur (cdr sequence))]) 262 | (if (number? (car sequence)) 263 | (cons (op-for-num (car sequence) (car sequence-after)) (cdr sequence-after)) 264 | (cons (car sequence-after) (cons (car sequence) (cdr sequence-after))))))) 265 | (gather-num-recur (sort sequence expressionset (map length m)))))) 19 | 20 | ;(linear-algebra-matrix? '((1 2) (3 4))) 21 | ;(linear-algebra-matrix? '(1 2 3 4)) 22 | ;(linear-algebra-matrix? '((1 2) (3 4 5))) 23 | 24 | ;;; 25 | 26 | (define (identity-mat dim) 27 | (define (one-zeroes-lst dim) 28 | (define (one-zeroes-iter d) 29 | (cond ((= 1 d) (list 0)) 30 | ((< d dim) (cons 0 (one-zeroes-iter (- d 1)))) 31 | ((= d dim) (cons 1 (one-zeroes-iter (- d 1)))))) 32 | (one-zeroes-iter dim)) 33 | (if (= dim 1) 34 | (list (list 1)) 35 | (cons (one-zeroes-lst dim) (map (lambda (element) (cons 0 element)) (identity-mat (- dim 1)))))) 36 | 37 | ;(identity-mat 4) ;'((1 0 0 0) (0 1 0 0) (0 0 1 0) (0 0 0 1)) 38 | 39 | ;;; 40 | 41 | (define (dot-product-vector v w) 42 | (accumulate (lambda args (make-sum args)) 0 (map (lambda args (simplify (make-product args))) v w))) 43 | 44 | (define (matrix-*-vector m v) 45 | (define (dot-v w) (dot-product-vector v w)) 46 | (map dot-v m)) 47 | 48 | (define (transpose-mat m) (accumulate-n cons '() m)) 49 | 50 | (define (matrix-*-matrix m n) 51 | (let ((cols (transpose-mat n))) 52 | (map (lambda (x) (matrix-*-vector m x)) n))) 53 | ;If the definition is like "m.nT", then we should use "(map n)" rather than "(map m)". 54 | ;We may need to change the sign here later for consistency reasons. 55 | 56 | ;(define v '(a 5)) 57 | ;(define w '(d 7)) 58 | ;(define m '((b c) (e 3))) 59 | ;(dot-product-vector v w) ;'(+ 35 (* a d)) 60 | ;(matrix-*-vector m v) ;'((+ (* a b) (* 5 c)) (+ 15 (* a e))) 61 | ;(transpose-mat m) ;'((b e) (c 3)) 62 | ;(matrix-*-matrix m m) ;'(((+ (** b 2) (** c 2)) (+ (* e b) (* 3 c))) ((+ (* e b) (* 3 c)) (+ 9 (** e 2)))) 63 | 64 | (define (mat-trace m) 65 | (define (diagonal-lst m) 66 | (if (null? m) 67 | '() 68 | (cons (car (car m)) (diagonal-lst (map cdr (cdr m)))))) 69 | (simplify (make-sum (diagonal-lst m)))) 70 | 71 | ;(mat-trace '((1 2 3) (4 5 6) (7 8 9))) ;15 72 | ;(mat-trace '((a b c) (d e f) (g h i))) ;'(+ a e i) 73 | ;(mat-trace '((1 b c) (d e f) (g h 3))) ;'(+ 4 e) 74 | 75 | (define (mat-delete-column m pos) (list-delete m pos)) 76 | (define (mat-delete-row m pos) (map (lambda (lst) (list-delete lst pos)) m)) 77 | 78 | (define (mat-determinant m) 79 | (define (pointer num columns) 80 | (if (null? columns) 81 | '() 82 | (begin 83 | (cons 84 | (simplify (make-product (list (sign num) (mat-determinant (map cdr (mat-delete-column m num))) (car (car columns))))) 85 | (pointer (+ num 1) (cdr columns)))))) 86 | (cond ((not (= (length m) (length (car m)))) (error "Not a squared matrix")) 87 | ((null? (cdr m)) (car (car m))) 88 | (else (simplify (make-sum (pointer 0 m)))))) 89 | 90 | (define (mat-factor m i j) (list-ref (list-ref m i) j)) 91 | (define (mat-cofactor m i j) (simplify (make-product 92 | (list 93 | (sign (+ i j)) 94 | (mat-determinant (mat-delete-column (mat-delete-row m j) i)))))) 95 | 96 | (define (mat-inverse m) 97 | (let ([det (mat-determinant m)] 98 | [len (length m)]) 99 | (map (lambda (row) (map (lambda (column) (simplify (make-product (list (mat-cofactor m column row) 100 | (make-exponentiation det -1))))) 101 | (range len))) 102 | (range len)))) 103 | 104 | ;(define l '((10 -9 -12) (7 -12 11) (-10 10 3))) 105 | ;(define m '((a b c) (d e f) (g h i))) 106 | ;(define n '((1 2 4 8) (3 5 6 2) (7 9 8 4) (1 3 2 4))) 107 | ;(mat-delete-column m 1) ;'((a b c) (g h i)) 108 | ;(mat-delete-row m 1) ;'((a c) (d f) (g i)) 109 | ;(mat-determinant m) ;'(+ (* (+ (* i e) (* -1 f h)) a) (* -1 (+ (* i b) (* -1 c h)) d) (* (+ (* f b) (* -1 c e)) g)) 110 | ;(mat-determinant n) ;-204 111 | ;(mat-factor m 1 2) ;'f 112 | ;(mat-cofactor m 1 2) ;'(+ (* h a) (* -1 b g)) 113 | ;(mat-inverse l) ;checked with wolframalpha.com, it works. 114 | ;(mat-inverse n) ;works -------------------------------------------------------------------------------- /mechanical-objects.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "fundamental.rkt" 4 | "calculus.rkt" 5 | "simplify.rkt") 6 | 7 | (provide mechanical-objects? make-pendulum) 8 | 9 | ;;; 10 | 11 | (define (mechanical-objects? x) 12 | (not (or (eq? (x 'potential-energy) 'not-match) (eq? (x 'kinetic-energy) 'not-match)))) 13 | 14 | ;;; 15 | 16 | (define g 9.8) 17 | 18 | (define (make-pendulum mass string-length pivotX pivotY amplitude) 19 | (define X 20 | (make-sum (list pivotX (make-product (list string-length (make-sin amplitude)))))) 21 | (define Y 22 | (make-sum (list pivotY (make-product (list -1 string-length (make-cos amplitude)))))) 23 | (define deltaX (make-sum (list pivotX (make-product (list -1 X))))) 24 | (define deltaY (make-sum (list pivotY (make-product (list -1 Y))))) 25 | (define potential-energy 26 | (make-product (list mass g Y))) 27 | (define kinetic-energy 28 | (make-product (list 0.5 mass (simplify (simplify (make-sum (list (make-exponentiation (deriv X 't) 2) (make-exponentiation (deriv Y 't) 2)))))))) 29 | (define (dispatch m) 30 | (cond ((eq? m 'mass) mass) 31 | ((eq? m 'length) string-length) 32 | ((eq? m 'pivotX) pivotX) 33 | ((eq? m 'pivotY) pivotY) 34 | ((eq? m 'X) X) 35 | ((eq? m 'Y) Y) 36 | ((eq? m 'deltaX) deltaX) 37 | ((eq? m 'deltaY) deltaY) 38 | ((eq? m 'potential-energy) potential-energy) 39 | ((eq? m 'kinetic-energy) kinetic-energy) 40 | (else 'not-match))) 41 | dispatch) 42 | 43 | ;(define pendulum1 (make-pendulum 'm1 'l1 'pivotX1 'pivotY1 (make-function 'theta1 't))) 44 | ;(pendulum1 'X) ;'(+ pivotX1 (* l1 (sin (function theta1 t)))) 45 | ;(pendulum1 'Y) ;'(+ pivotY1 (* -1 l1 (cos (function theta1 t)))) 46 | ;(pendulum1 'potential-energy) ;'(* 9.8 m1 (+ pivotY1 (* -1 l1 (cos (function theta1 t))))) 47 | ;(pendulum1 'kinetic-energy) ;'(* 0.5 m1 (** l1 2) (** (deriv (function theta1 t) t) 2)) 48 | 49 | ;(define pendulum2 (make-pendulum 'm2 'l2 (pendulum1 'X) (pendulum1 'Y) (make-function 'theta2 't))) 50 | ;(pendulum2 'X) 51 | ;(pendulum2 'kinetic-energy) ;complicated, as (x+y)^2 expansion is not included yet. 52 | -------------------------------------------------------------------------------- /numerical-differential-equation.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/stream 4 | "fundamental.rkt" 5 | "simplify.rkt") 6 | 7 | (provide numerical-solve) 8 | 9 | ;;; 10 | 11 | (define (replace-transcendental-function exp) 12 | (cond ((log? exp) (make-log (get-arg exp))) 13 | ((sin? exp) (make-sin (get-arg exp))) 14 | ((cos? exp) (make-cos (get-arg exp))) 15 | ((symbol? exp) exp) 16 | ((number? exp) exp) 17 | (else (simplify (map replace-transcendental-function exp))))) 18 | 19 | ;(replace-transcendental-function '(+ 2 3 x (sin 5) (cos (+ 6 x)))) 20 | 21 | (define (deriv-order exp) 22 | (cond ((function? exp) 0) 23 | ((deriv? exp) (+ 1 (deriv-order (get-function-kernal exp)))) 24 | (else (error "Not a derivative" exp)))) 25 | 26 | ;(deriv-order '(deriv (deriv (function theta1 t) t) t)) ;2 27 | 28 | (define (numerical-solve eqn initial-exp-lst initial-lst num-var num-dvar) ;"initial condition" gives from zero's order to (n-1) order 29 | (if (= (deriv-order (eqn-LHS eqn)) (length initial-lst)) 30 | (let ([num-eqn-RHS (replace-transcendental-function (exp-replace (eqn-RHS eqn) initial-exp-lst initial-lst))]) 31 | (if (not (number? num-eqn-RHS)) 32 | (error "Equation include further parameters, numerical calculation is not possible" eqn) 33 | (stream-cons (cons num-var initial-lst) (numerical-solve eqn 34 | initial-exp-lst 35 | ;(map (lambda (x dx) (+ x (* num-dvar dx))) initial-lst (cons num-eqn-RHS (drop-right initial-lst 1))) 36 | (map (lambda (x dx) (+ x (* num-dvar dx))) initial-lst (append (cdr initial-lst) (list num-eqn-RHS))) 37 | (+ num-var num-dvar) 38 | num-dvar)))) 39 | (error "Initial condition not enough for eqn" eqn initial-lst))) 40 | 41 | ;;; 42 | 43 | ;(require "plot.rkt") 44 | 45 | ;(define solution (numerical-solve '(= (deriv (deriv (function theta1 t) t) t) (function theta1 t)) 46 | ; '((function theta1 t) (deriv (function theta1 t) t)) 47 | ; '(1 1) 48 | ; 0 49 | ; 0.1)) 50 | ;(stream-take 10 solution) 51 | ;(listplot (map (lambda (x) (drop-right x 1)) (stream-take 30 solution)) 0 2 0 6) ;curve quite makes sense. 52 | 53 | ;(define solution (numerical-solve '(= (deriv (deriv (function theta1 t) t) t) (* -1 (sin (function theta1 t)))) 54 | ; '((function theta1 t) (deriv (function theta1 t) t)) 55 | ; '(1 0) 56 | ; 0 57 | ; 0.1)) 58 | ;(stream-take 10 solution) 59 | ;(listplot (map (lambda (x) (drop-right x 1)) (stream-take 60 solution)) 0 5 -1 1) ;curve quite makes sense. 60 | -------------------------------------------------------------------------------- /plot.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require slideshow/pict) 4 | (require racket/draw) 5 | 6 | (provide plot listplot) 7 | 8 | ;;; 9 | 10 | (define plot-width 400) 11 | (define plot-height 300) 12 | 13 | (define count-axis-marker 6) 14 | (define axis-marker-size 5) 15 | (define x-axis-size 20) 16 | (define y-axis-size 40) 17 | 18 | ;;; 19 | 20 | (define (list-scale const lst) (map (lambda (y) (* const y)) lst)) 21 | (define (list-translation const lst) (map (lambda (y) (+ const y)) lst)) 22 | 23 | (define (multisection min max howmany) 24 | (let ([gap (/ (- max min) howmany)]) 25 | (define (multisection-recur num) 26 | (if (>= (+ num (* 1.001 gap)) max) 27 | '() 28 | (cons (+ num gap) (multisection-recur (+ num gap))))) 29 | (multisection-recur min))) 30 | 31 | (define (scale-point-position point-lst x-min x-max y-min y-max) 32 | (let ([x (car point-lst)] 33 | [y (cadr point-lst)]) 34 | (list (* (/ plot-width (- x-max x-min)) (- x x-min)) (- plot-height (* (/ plot-height (- y-max y-min)) (- y y-min)))))) 35 | 36 | (define (find-axis-marker-list min max) 37 | (let ([const (expt 10 (order-of-magnitude (* (/ (- max min) count-axis-marker) 0.5)))]) 38 | (list-scale const (map round (list-scale (/ 1 const) (multisection min max count-axis-marker)))))) 39 | 40 | ;(find-axis-marker-list 1.23 2.42) 41 | ;(find-axis-marker-list 0.00123 0.00242) 42 | ;(find-axis-marker-list 123 242) 43 | 44 | ;;; 45 | 46 | (define canvas (frame (blank plot-width plot-height))) 47 | 48 | (define (x-axis x-min x-max) 49 | (let* ([marker-lst (find-axis-marker-list x-min x-max)] 50 | [marker-lst-screen (list-scale (/ plot-width (- x-max x-min)) 51 | (list-translation (- x-min) marker-lst))]) 52 | (define (axis-marker-recur pict marker-lst marker-lst-screen) 53 | (if (null? marker-lst) 54 | pict 55 | (pin-over 56 | (axis-marker-recur pict (cdr marker-lst) (cdr marker-lst-screen)) 57 | (car marker-lst-screen) 0 (vl-append (vline 2 axis-marker-size) (text (number->string (car marker-lst))))))) 58 | (vl-append 59 | ;(hline plot-width 2) 60 | (axis-marker-recur (blank plot-width x-axis-size) marker-lst marker-lst-screen)))) 61 | 62 | (define (y-axis y-min y-max) 63 | (let* ([marker-lst (find-axis-marker-list y-min y-max)] 64 | [marker-lst-screen (map 65 | (lambda (x) (- plot-height x)) 66 | (list-scale (/ plot-height (- y-max y-min)) 67 | (list-translation (- y-min) marker-lst)))]) 68 | (define (axis-marker-recur pict marker-lst marker-lst-screen) 69 | (if (null? marker-lst) 70 | pict 71 | (pin-over 72 | (axis-marker-recur pict (cdr marker-lst) (cdr marker-lst-screen)) 73 | 0 (car marker-lst-screen) (ht-append (hline 2 axis-marker-size) (blank 2) (text (number->string (car marker-lst))))))) 74 | (hb-append 75 | ;(vline 2 plot-height) 76 | (axis-marker-recur (blank y-axis-size plot-height) marker-lst marker-lst-screen)))) 77 | 78 | ;;; 79 | 80 | (define plot-marker-size 10) 81 | 82 | (define plot-marker (rectangle plot-marker-size plot-marker-size)) 83 | 84 | (define (listplot lst x-min x-max y-min y-max) 85 | (define (listplot-recur pict lst) 86 | (if (null? lst) 87 | pict 88 | (let ([point (scale-point-position (car lst) x-min x-max y-min y-max)] 89 | [other-points (cdr lst)] 90 | [shift (/ plot-marker-size 2)]) 91 | (pin-over (listplot-recur pict other-points) (- (car point) shift) (- (cadr point) shift) plot-marker)))) 92 | (ht-append 93 | (vl-append 94 | (listplot-recur canvas lst) 95 | (x-axis x-min x-max)) 96 | (y-axis y-min y-max))) 97 | 98 | ;(listplot '((20 30) (40 50) (100 200) (100 220)) -100 200 -100 300) 99 | 100 | ;;; 101 | 102 | (define curve-pixel 100) 103 | 104 | (define (plot func x-min x-max y-min y-max) 105 | (let ([data-lst (map (lambda (x) (list x (func x))) (multisection x-min x-max curve-pixel))]) 106 | (listplot data-lst x-min x-max y-min y-max))) 107 | 108 | ;(plot sin 0 10 -2 2) 109 | 110 | -------------------------------------------------------------------------------- /riemannian.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require (only-in "fundamental.rkt" list-take list-reverse map-n)) 4 | (require "simplify.rkt" 5 | "tensor.rkt" 6 | "linear-algebra.rkt") 7 | 8 | (provide (all-defined-out)) 9 | 10 | ;;; 11 | 12 | (define (identity-mat-as-tensor index-lst dim) 13 | (cond ((not (= 2 (length index-lst))) (error "Length of index-lst doesn't match" index-lst)) 14 | ((eq? (car (car index-lst)) (car (cadr index-lst))) (error "Indices should be one sub one super" index-lst)) 15 | (else (make-tensor index-lst (identity-mat dim))))) 16 | 17 | ;(identity-mat-as-tensor '((_ a) (^ b)) 4) ;works 18 | 19 | (define (tensor-order tnsr) (length (get-index tnsr))) 20 | (define (tensor-dimension tnsr) (length (get-matrix tnsr))) 21 | ;For tensors in tensor.rkt, the dimensions belong to different indices need not be the same. 22 | ;In Riemannian geometry, the dimension (of space) should be the same for all orders. 23 | ;In here, we don't check whether it is true or not. 24 | 25 | (define (einstein-summation tnsr) 26 | (define (index-same-back ele lst) 27 | (define (list-flip new-lst old-lst) 28 | (cond ((null? old-lst) false) 29 | ((eq? (cadr ele) (cadr (car old-lst))) (list-reverse new-lst (append (cdr old-lst) (list (car old-lst))))) 30 | (else (list-flip (cons (car old-lst) new-lst) (cdr old-lst))))) 31 | (list-flip '() lst)) 32 | ;(index-same-back '(^ a) '((_ b) (_ a) (^ c))) ;'((_ b) (^ c) (_ a)) 33 | 34 | (define (list-same-right lst) 35 | (define (list-same-right-recur lst) 36 | (if (null? lst) 37 | false 38 | (let ([remain (index-same-back (car lst) (cdr lst))]) 39 | (if remain 40 | (append remain (list (car lst))) 41 | (let ([recur (list-same-right-recur (cdr lst))]) 42 | (if recur 43 | (cons (car lst) recur) 44 | false)))))) 45 | (list-same-right-recur lst)) 46 | (list-same-right '((_ a) (_ b) (^ a) (_ d) (^ b))) ;'((_ b) (_ d) (^ b) (^ a) (_ a)) 47 | (list-same-right '((_ a) (_ b) (^ c) (_ d))) ;#f 48 | 49 | (define (tensor-trace tnsr) 50 | (let ([len (- (length (get-index tnsr)) 2)]) 51 | (make-tensor 52 | (list-take (get-index tnsr) len) 53 | (map-n len mat-trace (get-matrix-without-tag tnsr))))) 54 | (if (= (length (get-index tnsr)) 2) 55 | (if (eq? (cadr (car (get-index tnsr))) (cadr (cadr (get-index tnsr)))) 56 | (make-scalar (simplify (mat-trace (get-matrix-without-tag tnsr)))) 57 | (simplify-generic tnsr)) 58 | (let ([new-index (list-same-right (get-index tnsr))]) 59 | (if new-index 60 | (simplify-generic (einstein-summation (tensor-trace (switch-index new-index tnsr)))) 61 | (simplify-generic tnsr))))) 62 | 63 | ;(define t (make-tensor '((^ a) (_ a)) '((a b) (c d)))) 64 | ;(einstein-summation t) ;'(scalar + a d) 65 | ;(define s (make-tensor '((^ a) (_ b)) '((a b) (c d)))) 66 | ;(einstein-summation s) 67 | ;(define ts (make-tensor '((_ b) (^ a) (^ b)) (list (list (list 1 2) (list 3 4)) (list (list 5 6) (list 7 8))))) 68 | ;(einstein-summation ts) ;'(tensor (a) (scalar . 7) (scalar . 11)) 69 | ;(define tss (make-tensor '((_ a) (^ b) (^ c)) (list (list (list 1 2) (list 3 4)) (list (list 5 6) (list 7 8))))) 70 | ;(einstein-summation tss) ;same as the original 71 | 72 | (define (metric upper-lower-lst tnsr) 73 | (cond ((not (= 2 (tensor-order tnsr))) (error "Not a metric" tnsr)) 74 | ((not (= 2 (length upper-lower-lst))) (error "Upper-lower-lst doesn't match" upper-lower-lst)) 75 | ((or (equal? upper-lower-lst '(_ ^)) (equal? upper-lower-lst '(^ _))) 76 | (identity-mat-as-tensor (list (list (car upper-lower-lst) (cadr (car (get-index tnsr)))) 77 | (list (cadr upper-lower-lst) (cadr (cadr (get-index tnsr))))) 78 | (tensor-dimension tnsr))) 79 | ((and (eq? (car upper-lower-lst) (car (car (get-index tnsr)))) 80 | (eq? (cadr upper-lower-lst) (car (cadr (get-index tnsr))))) tnsr) 81 | (else 82 | (make-tensor (list (list (car upper-lower-lst) (cadr (car (get-index tnsr)))) 83 | (list (cadr upper-lower-lst) (cadr (cadr (get-index tnsr))))) 84 | (mat-inverse (get-matrix-without-tag tnsr)))))) 85 | 86 | ;(define gg (make-tensor '((_ a) (_ b)) '((1 -3 1) (-3 -1 0) (1 0 2)))) 87 | ;(define gg (make-tensor '((_ a) (_ b)) '((1 -3 a) (-3 -1 0) (a 0 2)))) 88 | ;The second one also works, but it doesn't know how to do simplification right now. 89 | ;(metric '(_ ^) gg) ;works 90 | ;(metric '(_ _) gg) ;works 91 | ;(metric '(^ ^) gg) ;works 92 | 93 | ;(einstein-summation (mul (change-index '((^ a) (^ b)) (metric '(^ ^) gg)) 94 | ; (change-index '((_ b) (_ c)) (metric '(_ _) gg)))) ;'(tensor ((^ a) (_ c)) identity) 95 | ;successfully got the simple diagonal matrix :-) 96 | ;'(tensor ((^ a) (_ c)) ((scalar . 1) (scalar . 0) (scalar . 0)) ((scalar . 0) (scalar . 1) (scalar . 0)) ((scalar . 0) (scalar . 0) (scalar . 1))) 97 | 98 | (define (christoffel index-lst g-tensor coordinate-lst) 99 | (if (nand (= 3 (length index-lst)) 100 | (eq? (car (car index-lst)) '^) 101 | (eq? (car (cadr index-lst)) '_) 102 | (eq? (car (caddr index-lst)) '_)) 103 | (error "Christoffel symbol needs 3 indices, has super-sub-sub in order. You give" index-lst) 104 | (let ([first-term (partial-deriv (change-index '((_ dummy) (_ j)) g-tensor) 105 | (make-tensor '((_ k)) coordinate-lst))]) 106 | (change-index 107 | index-lst 108 | (einstein-summation 109 | (mul 110 | (change-index '((^ i) (^ dummy)) (metric '(^ ^) g-tensor)) 111 | (scalar-mul 112 | (/ 1 2) 113 | (add (add first-term 114 | (switch-index '((_ dummy) (_ j) (_ k)) (change-index '((_ dummy) (_ k) (_ j)) first-term))) 115 | (scalar-mul -1 (switch-index '((_ dummy) (_ j) (_ k)) (change-index '((_ k) (_ j) (_ dummy)) first-term))))))))))) 116 | 117 | (define (riemann-tensor index-lst christoffel-gamma coordinate-lst) 118 | (if (nand (= 4 (length index-lst)) 119 | (eq? (car (car index-lst)) '^) 120 | (eq? (car (cadr index-lst)) '_) 121 | (eq? (car (caddr index-lst)) '_) 122 | (eq? (car (cadddr index-lst)) '_)) 123 | (error "Riemann curvature tensor needs 4 indices, has super-sub-sub-sub in order. You give" index-lst) 124 | (let* ([gamma (change-index '((^ i) (_ j) (_ k)) christoffel-gamma)] 125 | [partial-gamma (partial-deriv gamma (make-tensor '((_ l)) coordinate-lst))]) 126 | (change-index 127 | index-lst 128 | (add 129 | (add (switch-index '((^ i) (_ k) (_ l) (_ j)) partial-gamma) 130 | (scalar-mul -1 (switch-index '((^ i) (_ k) (_ l) (_ j)) 131 | (change-index '((^ i) (_ l) (_ k) (_ j)) partial-gamma)))) 132 | (add 133 | (switch-index '((^ i) (_ k) (_ l) (_ j)) 134 | (einstein-summation 135 | (mul (change-index '((^ i) (_ l) (_ dummy)) gamma) 136 | (change-index '((^ dummy) (_ j) (_ k)) gamma)))) 137 | (switch-index '((^ i) (_ k) (_ l) (_ j)) 138 | (scalar-mul -1 (einstein-summation 139 | (mul (change-index '((^ i) (_ j) (_ dummy)) gamma) 140 | (change-index '((^ dummy) (_ l) (_ k)) gamma))))))))))) 141 | 142 | (define (ricci-curvature-tensor index-lst riemann-tnsr) 143 | (if (nand (= 2 (length index-lst)) 144 | (eq? (car (car index-lst)) '_) 145 | (eq? (car (cadr index-lst)) '_)) 146 | (error "Ricci curvature tensor needs 2 indices, has sub-sub in order. You give" index-lst) 147 | (change-index 148 | index-lst 149 | (einstein-summation 150 | (change-index '((^ k) (_ i) (_ k) (_ j)) riemann-tnsr))))) 151 | 152 | (define (ricci-scalar g-tnsr ricci-tnsr) 153 | (einstein-summation 154 | (mul (change-index '((^ i) (^ j)) (metric '(^ ^) g-tnsr)) 155 | (change-index '((_ j) (_ i)) ricci-tnsr)))) 156 | 157 | ;(define g (make-tensor '((_ a) (_ b)) '((x1 0) (0 x2)))) 158 | ;(define gamma (christoffel '((^ i) (_ j) (_ k)) g '(x1 x2))) ;seems work, no simplification right now. 159 | ;'(tensor 160 | ; ((^ i) (_ j) (_ k)) 161 | ; (((scalar * (1/2)(* x2 (** (* x2 x1) -1))) (scalar . 0)) ((scalar . 0) (scalar . 0))) 162 | ; (((scalar . 0) (scalar . 0)) ((scalar . 0) (scalar * (1/2)(* x1 (** (* x2 x1) -1)))))) 163 | ;;;(christoffel '((^ i) (_ j) (^ k)) g '(x1 x2)) ;index error 164 | ;(define r_abcd (riemann-tensor '((^ a) (_ b) (_ c) (_ d)) gamma '(x1 x2))) 165 | ;(define r_ab (ricci-curvature-tensor '((_ a) (_ b)) r_abcd)) ;It is symmetric right now. 166 | ;(ricci-scalar g r_ab) ;works. no simplification. so currently can't check whether right or now. -------------------------------------------------------------------------------- /show-expression.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "fundamental.rkt" 4 | 2htdp/image) 5 | 6 | (provide show-expression) 7 | 8 | (define (show-expression exp [parentheses? false]) 9 | (define (show x) (text x 24 "black")) 10 | (define blank (text " " 12 "black")) 11 | (define show+ (show "+")) 12 | (define show* blank) 13 | (define (add-parentheses x) (beside (show "(") x (show ")"))) 14 | (define (besidee lst) 15 | (let ([len (length lst)]) 16 | (cond ((= len 0) (show "1")) 17 | ((= len 1) (car lst)) 18 | (else (apply beside/align (cons "bottom" lst)))))) 19 | (define (get-deriv-arg-lst exp lst) 20 | (if (deriv? exp) 21 | (cons (get-deriv-arg exp) (get-deriv-arg-lst (get-deriv-kernel exp) lst)) 22 | lst)) 23 | (define (get-deriv-deepest-kernel exp) 24 | (if (deriv? exp) 25 | (get-deriv-deepest-kernel (get-deriv-kernel exp)) 26 | exp)) 27 | (cond ((number? exp) (show (number->string exp))) 28 | ((variable? exp) (show (symbol->string exp))) 29 | ((eqn? exp) (beside (show-expression (eqn-LHS exp)) 30 | blank 31 | (show "=") 32 | blank 33 | (show-expression (eqn-RHS exp)))) 34 | ((sum? exp) 35 | (let ([to-show (besidee (list-mixed-up (map show-expression (get-arg-lst exp)) show+))]) 36 | (if (eq? parentheses? false) 37 | to-show 38 | (add-parentheses to-show)))) 39 | ((product? exp) 40 | (define (denominator? x) (and (exponentiation? x) (number? (exponent x)) (< (exponent x) 0))) 41 | (let ([numerator (filter (function-chain (list not denominator?)) (get-arg-lst exp))] 42 | [denominator (map (lambda (x) (make-exponentiation (base x) (- (exponent x)))) (filter denominator? (get-arg-lst exp)))]) 43 | (let ([draw-numerator (besidee (list-mixed-up (map (lambda (x) (show-expression x true)) numerator) show*))] 44 | [draw-denominator (besidee (list-mixed-up (map (lambda (x) (show-expression x true)) denominator) show*))]) 45 | (if (null? denominator) 46 | draw-numerator 47 | (above 48 | draw-numerator 49 | (rectangle (max (image-width draw-numerator) (image-width draw-denominator)) 2 "solid" "black") 50 | draw-denominator))))) 51 | ((exponentiation? exp) (beside/align "bottom" (show-expression (base exp) true) (above (show-expression (exponent exp) true) blank))) 52 | ((log? exp) (beside (show "log") (add-parentheses (show-expression (get-arg exp))))) 53 | ((sin? exp) (beside (show "sin") (add-parentheses (show-expression (get-arg exp))))) 54 | ((cos? exp) (beside (show "cos") (add-parentheses (show-expression (get-arg exp))))) 55 | ((function? exp) (beside (show-expression (get-function-kernal exp)) 56 | (add-parentheses (show-expression (get-function-arg exp))))) 57 | ((deriv? exp) 58 | (let ([arg-lst (get-deriv-arg-lst exp '())] 59 | [deepest-kernel (get-deriv-deepest-kernel exp)]) 60 | (let ([draw-d-above (beside/align "bottom" (if (= (length arg-lst) 1) 61 | (show "d") 62 | (show-expression (make-exponentiation 'd (length arg-lst)))) 63 | (if (function? deepest-kernel) 64 | (show-expression deepest-kernel) 65 | (add-parentheses (show-expression deepest-kernel))))] 66 | [draw-d-bottom (beside/align "bottom" 67 | (show "d") 68 | (if (= (length arg-lst) 1) 69 | (show-expression (car arg-lst)) 70 | (show-expression (make-exponentiation (car arg-lst) (length arg-lst)))))]) 71 | (above 72 | draw-d-above 73 | (rectangle (max (image-width draw-d-above) (image-width draw-d-bottom)) 2 "solid" "black") 74 | draw-d-bottom)))) 75 | )) 76 | 77 | ;(show-expression '(* 2 b)) 78 | ;(show-expression '(+ 3 x y)) 79 | ;(show-expression '(** x (+ y z))) 80 | ;(show-expression '(* 3 (** x z) y (+ a 2) (** z (* 2 b (** c -1))) (** w -2) (** (cos x) -1))) 81 | 82 | ;(show-expression '(deriv (+ 2 (function x t)) t)) 83 | ;(show-expression '(deriv (deriv (function x t) t) t)) 84 | 85 | ;(show-expression '(= F (* G m1 m2 (** r -2)))) 86 | ;(show-expression '(= (sin (+ x y)) (+ (* (sin x) (cos y)) (* (cos x) (sin y))))) 87 | 88 | ;(show-expression '(= (+ (* m1 (** l1 2) (deriv (deriv (function theta1 t) t) t)) (* 9.8 m1 l1 (sin (function theta1 t)))) 0)) 89 | 90 | ;(show-expression '(= (sin (+ x y)) (+ (* (sin x) (cos y)) (* (cos x) (sin y))))) 91 | 92 | ;(show-expression '(= (+ (* (+ 1 (sin x) (cos x)) (** (+ 1 (sin x) (* -1 (cos x))) -1)) 93 | ; (* (+ 1 (sin x) (* -1 (cos x))) (** (+ 1 (sin x) (cos x)) -1))) 94 | ; (* 2 (** (cos x) -1)))) -------------------------------------------------------------------------------- /show-mechanical-objects.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "fundamental.rkt" 4 | "mechanical-objects.rkt" 5 | 2htdp/image 6 | 2htdp/universe) 7 | 8 | (provide (all-defined-out)) 9 | 10 | ;;; 11 | 12 | (define scene-background (rectangle 600 480 "solid" "orange")) 13 | 14 | (define (show-pendulum p) 15 | (add-line (circle (p 'mass) "solid" "black") (- (p 'mass) (p 'deltaX)) (- (p 'mass) (p 'deltaY)) (p 'mass) (p 'mass) "black")) 16 | 17 | (define (show-pendulum-in-scene p) 18 | (underlay/xy scene-background 19 | (- (p 'pivotX) (max (- (p 'mass) (p 'deltaX)) 0)) 20 | (- (p 'pivotY) (max (- (p 'mass) (p 'deltaY)) 0)) 21 | (show-pendulum p))) 22 | 23 | (define (create-pendulum-moving time) 24 | (lambda (p solution-next) 25 | (show-pendulum-in-scene (make-pendulum (p 'mass) (p 'length) (p 'pivotX) (p 'pivotY) (cadr (solution-next)))))) 26 | 27 | (define (shoe-multi-pendulum-in-scene p-lst) 28 | (if (null? p-lst) 29 | scene-background 30 | (let ([p (car p-lst)]) 31 | (underlay/xy (shoe-multi-pendulum-in-scene (cdr p-lst)) 32 | (- (p 'pivotX) (max (- (p 'mass) (p 'deltaX)) 0)) 33 | (- (p 'pivotY) (max (- (p 'mass) (p 'deltaY)) 0)) 34 | (show-pendulum p))))) 35 | 36 | ;;; 37 | 38 | ;(define p1 (make-pendulum 20 250 300 50 -0.3)) 39 | ;(define p2 (make-pendulum 30 150 150 100 0.3)) 40 | ;(show-pendulum-in-scene p1) 41 | ;(shoe-multi-pendulum-in-scene (list p1 p2)) 42 | 43 | -------------------------------------------------------------------------------- /simplify.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "fundamental.rkt") 4 | 5 | (provide simplify 6 | polynomial-expansion) 7 | 8 | ;;; 9 | 10 | (define (polynomial-expansion exp) 11 | (if (product? exp) 12 | (let ([sum-lst (filter sum? (get-arg-lst exp))]) 13 | (if (null? sum-lst) 14 | exp 15 | (make-sum (map (lambda (x) (make-product (append x (filter (lambda (x) (not (sum? x))) (get-arg-lst exp))))) 16 | (element-combination (map get-arg-lst sum-lst)))))) 17 | exp)) 18 | 19 | ;(polynomial-expansion '(* x y z)) 20 | ;(polynomial-expansion '(* (+ x y) (+ z w))) 21 | ;(polynomial-expansion '(* (+ x y) 5 w)) ;'(+ (* 5 x w) (* 5 y w)) 22 | ;(polynomial-expansion '(* (+ x y) (+ z y) 5 w)) ;'(+ (* 5 x z w) (* 5 y z w) (* 5 x y w) (* 5 y y w)) 23 | 24 | ;;; 25 | 26 | (define (distributivity exp) 27 | (if (and (sum? exp) (and-lst (map product? (get-arg-lst exp)))) 28 | (let ([intersect (list-intersect (map get-arg-lst (get-arg-lst exp)))]) 29 | (make-product (cons (make-sum (map (lambda (lst) (make-product (removes intersect (get-arg-lst lst)))) (get-arg-lst exp))) intersect))) 30 | exp)) 31 | 32 | ;(distributivity '(+ 2 3 x (* x 5) (+ 2 y))) ;same 33 | ;(distributivity '(+ (* x y z) (* z y w) (* z y))) ;'(* (+ 1 x w) y z) 34 | ;(distributivity '(+ (* x y y z) (* y z y w) (* y z y))) ;'(* (+ (* x y) (* y w) y) y z) ;currently it doesn't work for duplicate paras 35 | ;(distributivity '(+ (* x y z) (* z y w) (* z))) ;'(* (+ 1 (* x y) (* y w)) z) 36 | ;(distributivity '(+ (* x y z) (* z y w) (* z y) (* 2 n))) ;'(+ (* x y z) (* z y w) (* z y) (* 2 n)) ;nothing change 37 | 38 | (define (combine-consts exp) 39 | (define counter-hash (make-hash)) 40 | (define (put-to-hash term const) 41 | (if (hash-has-key? counter-hash term) 42 | (hash-set! counter-hash term (+ (hash-ref counter-hash term) const)) 43 | (hash-set! counter-hash term const))) 44 | (define (put-in exp) 45 | (if (product? exp) 46 | (let ([prod-exp (make-product (get-arg-lst exp))]) 47 | (cond ((symbol? prod-exp) (put-to-hash prod-exp 1)) 48 | ((and (number? (car (get-arg-lst prod-exp))) (null? (cddr (get-arg-lst prod-exp)))) 49 | (put-to-hash (cadr (get-arg-lst prod-exp)) (car (get-arg-lst prod-exp)))) 50 | ((number? (car (get-arg-lst prod-exp))) 51 | (put-to-hash (make-product (cdr (get-arg-lst prod-exp))) (car (get-arg-lst prod-exp)))) 52 | (else (put-to-hash prod-exp 1)))) 53 | (put-to-hash exp 1))) 54 | (if (sum? exp) 55 | (begin 56 | (map put-in (get-arg-lst exp)) 57 | (make-sum (map (lambda (x) (make-product (list (cdr x) (car x)))) (hash->list counter-hash)))) 58 | exp)) 59 | 60 | ;(combine-consts '(* 3 a b)) ;'(* 3 a b) 61 | ;(combine-consts '(+ (* 3 a b) f 7)) ;'(+ 7 f (* 3 a b)) 62 | ;(combine-consts '(+ (* 3 a b) (* 5 a b) (* b 6 c) f 7)) ;'(+ 7 f (* 6 b c) (* 8 a b)) 63 | 64 | (define (combine-sin2-cos2 exp) 65 | (define (is-cos2? x) (and (exponentiation? x) (= (exponent x) 2) (cos? (base x)))) 66 | (define (include-cos2? exp) 67 | (and (product? exp) (not (null? (filter is-cos2? exp))))) 68 | (define (cos2-factor exp) 69 | (filter (lambda (x) (not (is-cos2? x))) exp)) 70 | (define (is-sin2? x) (and (exponentiation? x) (= (exponent x) 2) (sin? (base x)))) 71 | (define (include-sin2? exp) 72 | (and (product? exp) (not (null? (filter is-sin2? exp))))) 73 | (define (sin2-factor exp) 74 | (filter (lambda (x) (not (is-sin2? x))) exp)) 75 | (cos2-factor '(+ x y 1 (** (cos (+ z w)) 2) (** (sin (+ z w)) 2))) 76 | (if (sum? exp) 77 | (let ([cos2?-lst (filter is-cos2? exp)] 78 | [sin2?-lst (filter is-sin2? exp)] 79 | [cos2-facter?-lst (filter include-cos2? exp)] 80 | [sin2-facter?-lst (filter include-sin2? exp)]) 81 | (cond ((and (= (length cos2?-lst) 1) (= (length sin2?-lst) 1) (equal? (get-arg (base (car cos2?-lst))) (get-arg (base (car sin2?-lst))))) 82 | (make-sum (cons 1 (filter (lambda (x) (not (or (is-cos2? x) (is-sin2? x)))) (get-arg-lst exp))))) 83 | ((and (= (length cos2-facter?-lst) 1) 84 | (= (length sin2-facter?-lst) 1) 85 | (equal? (cos2-factor (car cos2-facter?-lst)) (sin2-factor (car sin2-facter?-lst))) 86 | (equal? (get-arg (base (car (filter is-cos2? (car cos2-facter?-lst))))) 87 | (get-arg (base (car (filter is-sin2? (car sin2-facter?-lst))))))) 88 | (make-sum (cons (cos2-factor (car cos2-facter?-lst)) (filter (lambda (x) (not (or (include-cos2? x) (include-sin2? x)))) (get-arg-lst exp))))) 89 | (else exp))) 90 | exp)) 91 | 92 | ;(combine-sin2-cos2 '(+ x y 1 (** (cos (+ z w)) 2) (** (sin (+ z w)) 2))) ;'(+ 2 x y) 93 | ;(combine-sin2-cos2 '(+ x y 1 (** (cos (+ z w)) 2) (** (sin (+ z x)) 2))) ;same as before 94 | ;(combine-sin2-cos2 '(+ x y 1 (* a (** (cos (+ z w)) 2)) (* (** (sin (+ z w)) 2) a))) ;'(+ 1 (* a) x y) ;we can cancel (* a) by doing another simplify, so doesn't matter. 95 | ;(combine-sin2-cos2 '(+ x y 1 (* a (** (cos (+ z w)) 2)) (* (** (sin (+ z w)) 2) a b))) ;same as before 96 | ;(combine-sin2-cos2 '(+ x y 1 (* a (** (cos (+ z x)) 2)) (* (** (sin (+ z w)) 2) a))) ;same as before 97 | 98 | (define (devition-cancellation exp) 99 | (define counter-hash (make-hash)) 100 | (define (put-to-hash term const) 101 | (if (hash-has-key? counter-hash term) 102 | (hash-set! counter-hash term (make-sum (list (hash-ref counter-hash term) const))) 103 | (hash-set! counter-hash term const))) 104 | (define (put-in exp) 105 | (if (exponentiation? exp) 106 | (let ([expo-exp (make-exponentiation (base exp) (exponent exp))]) 107 | (cond ((symbol? expo-exp) (put-to-hash expo-exp 1)) 108 | ((exponentiation? expo-exp) 109 | (put-to-hash (base expo-exp) (exponent expo-exp))) 110 | (else (put-to-hash expo-exp 1)))) 111 | (put-to-hash exp 1))) 112 | (if (product? exp) 113 | (begin 114 | (map put-in (get-arg-lst exp)) 115 | (make-product (map (lambda (x) (make-exponentiation (car x) (cdr x))) (hash->list counter-hash)))) 116 | exp)) 117 | 118 | ;(devition-cancellation '(* x y z)) ;'(* y x z) 119 | ;(devition-cancellation '(* x y (** x -1))) ;'y 120 | ;(devition-cancellation '(* x y (** x -2))) ;'(* y (** x -1)) 121 | ;(devition-cancellation '(* (+ x 1) y (** x -2) (** (+ x 1) -1))) ;'(* (** x -2) y) 122 | 123 | (define (simplify exp) 124 | (define (polynomial-expansion-choice exp) ;so in here, I only expand (a+b)c, (a+b)(c+d), but not (a+b)(c+d)(e+f). 125 | (if (and (product? exp) (< (length (filter sum? (get-arg-lst exp))) 3)) 126 | (polynomial-expansion exp) 127 | exp)) 128 | (cond ((eqn? exp) (make-eqn (simplify (eqn-LHS exp)) (simplify (eqn-RHS exp)))) 129 | ((sum? exp) ((function-chain (list combine-sin2-cos2 distributivity combine-consts)) 130 | (make-sum (map simplify (get-arg-lst exp))))) 131 | ((product? exp) ((function-chain (list polynomial-expansion-choice devition-cancellation)) 132 | (make-product (map simplify (get-arg-lst exp))))) 133 | ((exponentiation? exp) 134 | (if (exponentiation? (base exp)) 135 | (make-exponentiation (simplify (base (base exp))) (simplify (make-product (list (exponent (base exp)) (exponent exp))))) 136 | (make-exponentiation (simplify (base exp)) (simplify (exponent exp))))) 137 | (else exp))) 138 | 139 | ;(simplify '(+ 2 3 x (* x 5) (+ 2 y))) ;'(+ 7 x (* 5 x) y) 140 | ;(simplify '(* w (+ (* x y z) (* z y w) (* z y)))) ;'(* w (+ 1 x w) y z) 141 | ;(simplify '(+ (* 3 a b) (* 5 a b) (* b 6 c) f 7)) ;'(+ 7 (* 6 b c) f (* 8 a b)) 142 | ;(simplify '(+ x y 1 (* a (** (cos (+ z w)) 2)) (* (** (sin (+ z w)) 2) a))) ;'(+ 1 y x a) 143 | ;(simplify '(+ x y 1 (* 5 a) (* 6 a (** (cos (* z w)) 2)) (* 6 (** (sin (* z w)) 2) a))) ;'(+ 1 y x (* 11 a)) 144 | ;(simplify '(= (+ 2 3 x y) (* 3 z w 5))) ;'(= (+ 5 y x) (* 15 z w)) 145 | ;(simplify '(* (+ x 1) y (** (+ 5 x y (* -1 y) 2) -2) (** (+ x 1) -1))) ;'(* (** (+ 7 x) -2) y) 146 | 147 | ;(simplify '(* (** (+ -20 (** a 2)) -1) (+ 6 (* -3 (** a 2)) (* -3 (+ 2 (* -1 (** a 2))))))) ;0 148 | ;(simplify '(* (+ x y) (+ x (* -1 y)))) ;Unfortunately, this one doesn't work in current case. The computer doesn't know (* x y) = (* y x). 149 | 150 | ;(simplify '(* (+ 2 (* (** x -2) (** y 2)) (* -1 (** y 2) (** x -2))) (** r -2))) ;need permutation when check hash... -------------------------------------------------------------------------------- /solve.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "fundamental.rkt") 4 | 5 | (provide solve) 6 | 7 | (define (solve-count exp var) 8 | (cond ((number? exp) 0) 9 | ((equal? exp var) 1) 10 | ((and (variable? exp) (not (same-variable? exp var))) 0) 11 | ((function? exp) 0) 12 | ((or (eqn? exp) (sum? exp) (product? exp) (exponentiation? exp)) 13 | (apply + (map (lambda (x) (solve-count x var)) (get-arg-lst exp)))) 14 | ((or (log? exp) (sin? exp) (cos? exp)) 15 | (solve-count (get-arg exp) var)) 16 | (else (error "unknown expression type -- SOLVE-COUNT" exp)))) 17 | 18 | ;(solve-count '(= (* 3 y) x) 'y) ;1 19 | ;(solve-count '(= (* 3 (sin y)) (+ x y)) 'y) ;2 20 | 21 | ;(solve-count '(deriv (deriv (function theta1 t) t) t) '(deriv (deriv (function theta1 t) t) t)) 22 | 23 | (define (switch-LHS-RHS eqn var) 24 | (if (= (solve-count (eqn-LHS eqn) var) 1) 25 | eqn 26 | (make-eqn (eqn-RHS eqn) (eqn-LHS eqn)))) 27 | 28 | ;(switch-LHS-RHS '(= (* 3 y) x) 'y) 29 | ;(switch-LHS-RHS '(= x (* 3 y)) 'y) 30 | 31 | (define (exp-with-var exp-lst var) 32 | (car (filter (lambda (exp) (= (solve-count exp var) 1)) exp-lst))) 33 | (define (exp-lst-without-var exp-lst var) 34 | (filter (lambda (exp) (not (= (solve-count exp var) 1))) exp-lst)) 35 | 36 | ;(exp-with-var '(x (+ 3 y) z) 'y) ;'(+ 3 y) 37 | ;(exp-lst-without-var '(x (+ 3 y) z) 'y) ;'(x z) 38 | 39 | (define (solve eqn var) 40 | (cond ((and (eqn? eqn) (= (solve-count eqn var) 1)) 41 | (let ([eqnn (switch-LHS-RHS eqn var)]) 42 | (cond ((equal? (eqn-LHS eqnn) var) eqnn) 43 | ((sum? (eqn-LHS eqnn)) 44 | (solve (make-eqn (exp-with-var (get-arg-lst (eqn-LHS eqnn)) var) 45 | (make-sum (cons (eqn-RHS eqnn) (map (lambda (x) (make-product (list -1 x))) (exp-lst-without-var (get-arg-lst (eqn-LHS eqnn)) var))))) 46 | var)) 47 | ((product? (eqn-LHS eqnn)) 48 | (solve (make-eqn (exp-with-var (get-arg-lst (eqn-LHS eqnn)) var) 49 | (make-product (cons (eqn-RHS eqnn) (map (lambda (x) (make-exponentiation x -1)) (exp-lst-without-var (get-arg-lst (eqn-LHS eqnn)) var))))) 50 | var)) 51 | ((and (exponentiation? (eqn-LHS eqnn)) (= (solve-count (base (eqn-LHS eqnn)) var) 1)) 52 | (solve (make-eqn (base (eqn-LHS eqnn)) (make-exponentiation (eqn-RHS eqnn) (make-exponentiation (exponent (eqn-LHS eqnn)) -1))) var)) 53 | ((and (exponentiation? (eqn-LHS eqnn)) (= (solve-count (exponent (eqn-LHS eqnn)) var) 1)) 54 | (solve (make-eqn (exponent (eqn-LHS eqnn)) (make-product (list (make-log (eqn-RHS eqnn)) (make-exponentiation (make-log (base (eqn-LHS eqnn))) -1)))) var)) 55 | ((log? (eqn-LHS eqnn)) 56 | (solve (make-eqn (get-arg (eqn-LHS eqnn)) (make-exponentiation (exp 1) (eqn-RHS eqnn))) var)) 57 | (else (error "Don't know how to do it right now"))))) 58 | ((eqn? eqn) 59 | (error "Var appears in eqn not exactly once, don't know how to solve right now" eqn)) 60 | (else (error "Not a equation" eqn)))) 61 | 62 | ;(solve '(* 3 y) 'y) ;Not a equation (* 3 y) 63 | ;(solve '(= y (* 3 y)) 'y) ;Var appears in eqn not exactly once, don't know how to solve right now (= y (* 3 y)) 64 | ;(solve '(= y x) 'y) ;'(= y x) 65 | ;(solve '(= x y) 'y) ;'(= y x) 66 | ;(solve '(= (+ y z) x) 'y) ;'(= y (+ x (* -1 z))) 67 | ;(solve '(= x (* z y)) 'y) ;'(= y (* x (** z -1))) 68 | ;(solve '(= (** x z) y) 'x) ;'(= x (** y (** z -1))) 69 | ;(solve '(= (** x z) y) 'z) ;'(= z (* (log y) (** (log x) -1))) 70 | ;(solve '(= x (log y)) 'y) ;'(= y (** 2.718281828459045 x)) 71 | -------------------------------------------------------------------------------- /tensor.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "generic-hash.rkt" 4 | "fundamental.rkt" 5 | "simplify.rkt" 6 | "calculus.rkt") 7 | (require (only-in "linear-algebra.rkt" transpose-mat)) 8 | 9 | (provide (all-defined-out)) 10 | 11 | ;;; 12 | 13 | (define (add x y) (apply-generic 'add x y)) 14 | (define (mul x y) (apply-generic 'mul x y)) 15 | (define (simplify-generic x) (apply-generic 'simplify-generic x)) 16 | (define (partial-deriv fx x) (apply-generic 'partial-deriv fx x)) 17 | 18 | ;;; 19 | 20 | (define (scalar? datum) (eq? (type-tag datum) 'scalar)) 21 | (define (tensor? datum) (eq? (type-tag datum) 'tensor)) 22 | 23 | (define (install-scalar-package) 24 | (define (tag x) (attach-tag 'scalar x)) 25 | (define (add x y) (simplify (make-sum (list x y)))) 26 | (define (mul x y) (simplify (make-product (list x y)))) 27 | (define (simplify-generic x) (simplify x)) 28 | (define (partial-deriv fx x) (deriv fx x)) 29 | (put 'make-scalar 'scalar tag) 30 | (put 'add '(scalar scalar) (lambda (x y) (tag (add x y)))) 31 | (put 'mul '(scalar scalar) (lambda (x y) (tag (mul x y)))) 32 | (put 'simplify-generic '(scalar) (lambda (x) (tag (simplify-generic x)))) 33 | (put 'partial-deriv '(scalar scalar) (lambda (fx x) (tag (partial-deriv fx x))))) 34 | 35 | (install-scalar-package) 36 | (define (make-scalar x) ((get 'make-scalar 'scalar) x)) 37 | 38 | ;(define s (make-scalar 2)) 39 | ;(add s s) ;'(scalar . 4) 40 | 41 | ;(define x (make-scalar 'x)) 42 | ;(define fx (make-scalar '(* y z))) 43 | ;(define gx (make-scalar '(* x y z))) 44 | ;(partial-deriv fx x) ;'(scalar . 0) 45 | ;(partial-deriv gx x) ;'(scalar * y z) 46 | 47 | ;(define t (make-scalar '(+ 3 6 (+ x 5 x)))) 48 | ;(simplify-generic t) ;'(scalar + 14 (* 2 x)) 49 | 50 | (define (install-tensor-package) 51 | (define (switch-index-withmat level lst) 52 | (if (= level 1) 53 | (cons (cadr lst) (cons (car lst) (cddr lst))) 54 | (cons (car lst) (switch-index-withmat (- level 1) (cdr lst))))) 55 | (define (switch-index-mat level mat) ;For tensor Xabcd, level 1 is a<=>b, level 2 is b<=>c ... 56 | (if (= level 1) 57 | (transpose-mat mat) 58 | (map (lambda (mat) (switch-index-mat (- level 1) mat)) mat))) 59 | ;(switch-index-withmat 1 '(a b c d)) ;'(b a c d) 60 | ;(switch-index-withmat 2 '(a b c d)) ;'(a c b d) 61 | ;(switch-index-withmat 3 '(a b c d)) ;'(a b d c) 62 | ;(define mat (list (list 1 2) (list 3 4))) 63 | ;(define tam (list (list 5 6) (list 7 8))) 64 | ;(define mat-3d (list mat tam)) 65 | ;(transpose-mat mat) ;'((1 3) (2 4)) 66 | ;(switch-index-mat 1 (switch-index-mat 2 (switch-index-mat 1 mat-3d))) ; 67 | ;(switch-index-mat 2 (switch-index-mat 1 (switch-index-mat 2 mat-3d))) ;consistent 68 | 69 | (define (move-index-withmat from-level to-level lst) 70 | (cond ((= from-level to-level) lst) 71 | ((< from-level to-level) (switch-index-withmat to-level (move-index-withmat from-level (- to-level 1) lst))) 72 | ((> from-level to-level) (switch-index-withmat (+ to-level 1) (move-index-withmat from-level (+ to-level 1) lst))))) 73 | (define (move-index-mat from-level to-level mat) 74 | (cond ((= from-level to-level) mat) 75 | ((< from-level to-level) (switch-index-mat to-level (move-index-mat from-level (- to-level 1) mat))) 76 | ((> from-level to-level) (switch-index-mat (+ to-level 1) (move-index-mat from-level (+ to-level 1) mat))))) 77 | ;(move-index-withmat 1 3 '(a b c d)) ;'(a c d b) 78 | ;(move-index-withmat 3 1 '(a b c d)) ;'(a d b c) 79 | ;(switch-index-mat 2 (switch-index-mat 1 mat-3d)) 80 | ;(move-index-mat 0 2 mat-3d) ;consistent 81 | ;(switch-index-mat 1 (switch-index-mat 2 mat-3d)) 82 | ;(move-index-mat 2 0 mat-3d) ;consistent 83 | 84 | ;;; 85 | 86 | ;For the tensor defined here, the degree of freedom belong to every indices need not be the same. 87 | (define (tag x) (attach-tag 'tensor x)) 88 | ;In "make-tensor", the index-lst doesn't care about the Einstein Summation at all. 89 | ;However, it works if the index-lst includes the information of the upper/lower indices. 90 | ;The convenience in riemannian.rkt is "let ([index-lst (list '(_ a) '(^ b) '(_ c))])". 91 | ; 92 | ;Notice that for "x_ab", "a" describes the other chain while "b" describes the inner chain. 93 | ;So it is (transpose x_ab) = '((_ _ _) 94 | ; (_ _ _) 95 | ; (_ _ _)) in Racket's list notation system. 96 | (define (make-tensor index-lst contents-matrix) 97 | (cons index-lst (map-n (length index-lst) make-scalar contents-matrix))) 98 | (put 'make-tensor 'tensor (lambda (i m) (tag (make-tensor i m)))) 99 | 100 | (define (get-index tnsr) (car tnsr)) 101 | (define (get-matrix tnsr) (cdr tnsr)) 102 | (put 'get-index '(tensor) get-index) 103 | (put 'get-matrix '(tensor) get-matrix) 104 | 105 | (define (get-matrix-without-tag tnsr) 106 | (map-n (length (get-index tnsr)) contents (get-matrix tnsr))) 107 | (put 'get-matrix-without-tag '(tensor) get-matrix-without-tag) 108 | 109 | ;In "add-tensor", no matter whether the indices of x and y match or not, it follows the index of x. 110 | (define (add-tensor x y) 111 | (if (not (= (length (get-index x)) (length (get-index y)))) 112 | (error "Tensor dimensions don't match -- ADD-TENSOR" x y) 113 | (cons (get-index x) (map-n (length (get-index x)) add (get-matrix x) (get-matrix y))))) 114 | (define (mul-tensor-to-scalar tnsr sclr) 115 | (cons (get-index tnsr) 116 | (map-n (length (get-index tnsr)) 117 | (lambda (t) (mul t (make-scalar sclr))) 118 | (get-matrix tnsr)))) 119 | (define (mul-tensor-to-tensor tnsr1 tnsr2) 120 | (cons (append (get-index tnsr1) (get-index tnsr2)) 121 | (map-n (length (get-index tnsr1)) 122 | (lambda (t) (get-matrix (contents (mul t (tag tnsr2))))) 123 | (get-matrix tnsr1)))) 124 | (put 'add '(tensor tensor) (lambda (x y) (tag (add-tensor x y)))) 125 | (put 'mul '(tensor scalar) (lambda (x y) (tag (mul-tensor-to-scalar x y)))) 126 | (put 'mul '(scalar tensor) (lambda (x y) (tag (mul-tensor-to-scalar y x)))) ;We assume commutativity of scalars in here. 127 | (put 'mul '(tensor tensor) (lambda (x y) (tag (mul-tensor-to-tensor x y)))) 128 | 129 | (define (simplify-generic-tensor x) (cons (get-index x) (map-n (length (get-index x)) simplify-generic (get-matrix x)))) 130 | (put 'simplify-generic '(tensor) (lambda (x) (tag (simplify-generic-tensor x)))) 131 | 132 | (define (partial-deriv-tensor-over-scalar fx x) 133 | (cons (get-index fx) 134 | (map-n (length (get-index fx)) 135 | (lambda (f) (partial-deriv f (make-scalar x))) 136 | (get-matrix fx)))) 137 | (define (partial-deriv-scalar-over-tensor fx x) 138 | (cons (get-index x) 139 | (map-n (length (get-index x)) 140 | (lambda (x) (partial-deriv (make-scalar fx) x)) 141 | (get-matrix x)))) 142 | (define (partial-deriv-tensor-over-tensor fx x) 143 | (cons (append (get-index fx) (get-index x)) 144 | (map-n (length (get-index fx)) 145 | (lambda (f) (get-matrix (contents (partial-deriv f (tag x))))) 146 | (get-matrix fx)))) 147 | (put 'partial-deriv '(tensor scalar) (lambda (fx x) (tag (partial-deriv-tensor-over-scalar fx x)))) 148 | (put 'partial-deriv '(scalar tensor) (lambda (fx x) (tag (partial-deriv-scalar-over-tensor fx x)))) 149 | (put 'partial-deriv '(tensor tensor) (lambda (fx x) (tag (partial-deriv-tensor-over-tensor fx x)))) 150 | 151 | (define (change-index aim-index-lst tnsr) (cons aim-index-lst (get-matrix tnsr))) 152 | ;For "switch-index", it seems work when two of the indices are identical (I may need a stronger argument for that). 153 | ;However, if "X_abc != X_acb", then "X_abb" just chooses one possibility to show, which doesn't matter if we 154 | ;finally take the trace for Einstein Summation. 155 | (define (switch-index aim-index-lst x) 156 | (define (switch-index-iter aim-index aim-index-lst orignal-index-lst contents-matrix) 157 | (if (> aim-index (- (length orignal-index-lst) 1)) 158 | (cons aim-index-lst contents-matrix) 159 | (let ([original-index (index (list-ref aim-index-lst aim-index) orignal-index-lst)]) 160 | (if (> original-index aim-index) 161 | (switch-index-iter (+ aim-index 1) 162 | aim-index-lst 163 | (move-index-withmat original-index aim-index orignal-index-lst) 164 | (move-index-mat original-index aim-index contents-matrix)) 165 | (switch-index-iter (+ aim-index 1) aim-index-lst orignal-index-lst contents-matrix))))) 166 | (switch-index-iter 0 aim-index-lst (get-index x) (get-matrix x))) 167 | (put 'change-index '(expression tensor) 168 | (lambda (aim-index-lst x) (tag (change-index aim-index-lst x)))) 169 | (put 'switch-index '(expression tensor) 170 | (lambda (aim-index-lst x) (tag (switch-index aim-index-lst x)))) 171 | ) 172 | 173 | (install-tensor-package) 174 | (define (make-tensor index-lst contents-matrix) 175 | ((get 'make-tensor 'tensor) index-lst contents-matrix)) 176 | 177 | (define (get-index x) (apply-generic 'get-index x)) 178 | (define (get-matrix x) (apply-generic 'get-matrix x)) 179 | (define (get-matrix-without-tag x) (apply-generic 'get-matrix-without-tag x)) 180 | 181 | (define (change-index aim-index-lst tnsr) (apply-generic 'change-index aim-index-lst tnsr)) 182 | (define (switch-index aim-index-lst tnsr) (apply-generic 'switch-index aim-index-lst tnsr)) 183 | 184 | (define (scalar-mul k x) (mul (make-scalar k) x)) 185 | 186 | ;(define ts (make-tensor (list 'a 'b) (list (list '(+ c d) 2) (list 3 4)))) 187 | ;ts 188 | ;(get-matrix-without-tag ts) ;'(((+ c d) 2) (3 4)) 189 | ;(add ts ts) ;'(tensor (a b) ((scalar + (+ c d) (+ c d)) (scalar . 4)) ((scalar . 6) (scalar . 8))) 190 | ;(define ts (make-tensor (list 'a 'b) (list (list 1 2) (list 3 4)))) 191 | ;(switch-index '(a b) ts) 192 | ;(switch-index '(b a) ts) 193 | ;(define tss (make-tensor '(a b c) (list (list (list 1 2) (list 3 4)) (list (list 5 6) (list 7 8))))) 194 | ;(add tss tss) ;work 195 | ;(add ts tss) ; Tensor dimensions don't match 196 | ;(switch-index '(a b c) tss) 197 | ;(switch-index '(b a c) tss) 198 | ;(switch-index '(a c b) tss) 199 | ;(switch-index '(b c a) tss) 200 | ;(switch-index '(c a b) tss) 201 | ;(change-index '(c b a) tss) 202 | ;(switch-index '(c b a) tss) ;'(tensor (c b a) (((scalar . 1) (scalar . 5)) ((scalar . 3) (scalar . 7))) (((scalar . 2) (scalar . 6)) ((scalar . 4) (scalar . 8)))) 203 | ;(define xi (make-tensor (list 'd) (list 'x 'y))) 204 | ;(partial-deriv tss xi) 205 | 206 | ;(define tsss (make-tensor '(a a b) (list (list (list 1 2) (list 3 4)) (list (list 5 6) (list 7 8))))) 207 | ;(switch-index '(b a a) tsss) 208 | 209 | ;(define x (make-scalar 'x)) 210 | ;(define ts (make-tensor (list 'a) (list '(+ x y z (* -1 x) x) '(* 2 w x)))) 211 | ;(simplify-generic ts) ;'(tensor (a) (scalar + y x z) (scalar * 2 w x)) 212 | ;(mul ts x) ;'(tensor (a) (scalar * (+ x y z) x) (scalar * (* 2 w x) x)) 213 | ;(mul x ts) ;'(tensor (a) (scalar * (+ x y z) x) (scalar * (* 2 w x) x)) 214 | ;(scalar-mul 'x ts) 215 | ;(partial-deriv ts x) ;'(tensor (a) (scalar . 1) (scalar * 2 w)) 216 | ;(define yi (make-tensor (list 'a) (list 'x 'y 'z))) 217 | ;(define h (make-scalar '(* x y))) 218 | ;(partial-deriv h yi) ;'(tensor (a) (scalar . y) (scalar . x) (scalar . 0)) 219 | ;(define gj (make-tensor (list 'b) (list '(+ (* y z) z) '(* x y)))) 220 | ;(partial-deriv gj yi) ;'(tensor (b a) ((scalar . 0) (scalar . z) (scalar + 1 y)) ((scalar . y) (scalar . x) (scalar . 0))) 221 | ;(mul gj yi) ;correct 222 | 223 | ;(define ts (make-tensor (list '(_ a) '(^ b)) (list (list 1 2) (list 3 4)))) 224 | ;(switch-index '((_ a) (^ b)) ts); works 225 | ;(switch-index '((^ b) (_ a)) ts); works 226 | ;(switch-index '((^ a) (_ b)) ts); ERROR 227 | --------------------------------------------------------------------------------