[ { "path": ".gitignore", "content": "/.project\n/.settings\n/target\n/.classpath\n/classes\n*#\n*~\n.#*\n.lein-failures\n.lein-repl-history" }, { "path": ".travis.yml", "content": "language: java\njdk:\n - oraclejdk7\n - openjdk7\n - openjdk6\n" }, { "path": "README.md", "content": "expresso\n========\n\nA clojure library for symbolic manipulation of Algebraic Expressions. \n\n\n[![Build Status](https://travis-ci.org/clojure-numerics/expresso.png?branch=master)](https://travis-ci.org/clojure-numerics/expresso)\n\n```clojure\n(solve 'blue\n (ex (= pencils (+ green white blue red)))\n (ex (= (/ pencils 10) green))\n (ex (= (/ pencils 2) white))\n (ex (= (/ pencils 4) blue))\n (ex (= red 45))) ;=> #{{blue 75N}}\n```\n### Objectives\n\nexpresso aims to be a general library for manipulating mathematical expressions.\nThis are the key objectives:\n\n - Enable mathematical expressions to be encoded\n - Provide a powerful facility for general expression manipulation (aka term rewriting)\n - Provide a range of very useful manipulations, which include\n - simplifying mathematical expressions\n - solving a (set of) equations in regard to unknowns\n - differentiating expressions\n - optimizing of an expression for performance\n - compiling an expression to a clojure function\n - Be extensible through adding domain knowledge\n - Full compatibility with [core.matrix](https://github.com/mikera/matrix-api)\n \n \n### Getting started\n\nAdd the following line to your leiningen dependencies:\n```clojure\n[expresso \"0.2.4\"]\n```\nFor an in-depth tutorial and showcase of expresso, see the [expresso tutorial](https://github.com/mschuene/expresso-tutorial)\n### Defining expressions\n\nexpresso's expressions are just normal clojure s-expressions. expresso has various convenience functions/macros\nfor creating expressions:\n\n```clojure\n;;the ex macro constructs an expression with automatic quoting of variables\n(let [x 3]\n (ex (+ x ~x))) ;=> (+ x 3)\n\n;;the ex' macro constructs an expression with explicit quoting of variables\n(let [x 3]\n (ex' (+ x 'x))) ;=> (+ 3 x)\n\n;;all functions in the core namespace also support pure s-exp as parameters\n(solve '[x] '(= (+ 1 x) 3)) ;=> #{2}\n```\n### manipulations of algebraic expressions\n\n```clojure\n(use 'numeric.expresso.core)\n\n(simplify (ex (+ (* 4 a) (* 3 a) (* -1 (* 7 a))))) \n=> 0\n\n(def F1 (ex (= Y (+ X Z)))\n(def F2 (ex (= X [1 2 3]))\n(def F3 (ex (= Z (* 2.0 X)))\n\n(solve [Y] F1 F2 F3)\n=> #{[3.0 6.0 9.0]} \n\n(def opt (optimize (ex (+ b (* (+ 5 b) (** y (+ a b)) (** z (+ b a)))))))\nopt\n=> (let [local478813 (+ a b)] (+ (* b 6) (** y local478813) (** z local478813)))\n\n(def f (compile-expr [a b y z] opt))\n\n(f 1 2 3 4)\n=> 103.0\n```\nThe public API is in numeric.expresso.core - go test it out!\n\n### General Manipulation of Expressions\nExpresso supports a powerful way to manipulate expressions with rewrite rules, which are built ontop of \ncore.logic. Here are a few example rules\n\n```clojure\n(use 'numeric.expresso.rules)\n\n;;?&* matches zero or more items\n(def r [(rule (ex (* 0 ?&*)) :=> 0)\n (rule (ex (* 1 ?&*)) :=> (ex (* ?&*)))\n ;;supports optional guard with :if\n (rule (ex (/ ?x ?x)) :=> 1 :if (guard (not= ?x 0)))])\n\n;;rules match semantically. because * is commutative the rules match regardless of the order of arguments\n(transform-expression r (ex (+ (* 2 (/ 4 4) 3) a (* 4 0))))\n=> (+ (* 2 3) a 0)\n\n;;The right hand side and guard of a rule can be 'arbitrary core.logic relations'.\n;;The trans and guard macro create suitable core.logic relations out of normal clojure code.\n;;==> is a shorthand for trans\n\n(apply-rule (rule (ex (map ?f ?coll)) :==> (map ?f ?coll) :if (guard (coll? ?coll)))\n \t (ex (map ~inc [1 2 3]))) ;=> (2 3 4)\n```\n\n### Status \nThis library is ready to use, but still in an early state so you might find some\nbugs. Any bug reports/feature recommendations are very welcome.\n\n### Future Development\nCurrently, expresso is well suited for manipulations of symbolic expressions in clojure, it also has some support for\nsolving equations, etc what you excpect from a computer algebra system. However it is still far from a full featured \nCAS System like Maxima. Any contributions to help it become a real clojure Computer Algebra System are very welcome!\n\nIn the short term I am hoping to get symbolic matrices working soon. That means having an expression as a core.matrix implementation. This will be possible with the generic core.matrix api which is currently in development.\n\nAlso I am planning to replace the current rule based engine with a more faster one and to have proper compilation from \nrules to fast clojure functions. Kovas Boguta has made some very interesting experiments in this direction with his\n[combinator](https://github.com/kovasb/combinator) project.\n" }, { "path": "pom.xml", "content": "\n \t4.0.0\n \texpresso\n \t0.2.3\n \n \t\n \t\tnet.mikera\n \t\tclojure-pom\n \t\t0.1.0\n \t\n \n \t\n \t\t\n \t\t\tnet.mikera\n \t\t\tcore.matrix\n \t\t\t0.59.0\n \t\t\n \t\t\n \t\t instaparse\n \t\t instaparse\n \t\t 1.4.5\n \t\t\n \t\t\n \t\t\torg.clojure\n \t\t\tclojure\n \t\t\t1.8.0\n \t\t\n \t\t\n \t\t\tmschuene\n \t\t\tcore.logic\n \t\t\t0.8.11.1\n \t\t\n \t\t\n \t\t org.clojure\n \t\t core.memoize\n \t\t 0.5.8\n \t\t\n \t\t\n \t\t\tnet.mikera\n \t\t\tclojure-utils\n \t\t\t0.4.0\n \t\t\n \t\t\n \t\t\tnet.mikera\n \t\t\tcljunit\n \t\t\t0.3.0\n \t\t\ttest\n \t\t\n \t\t\n \t\t\tcriterium\n \t\t\tcriterium\n \t\t\t0.4.2\n \t\t\ttest\n \t\t\n \t\t\n \t\t\torg.clojure\n \t\t\ttools.trace\n \t\t\t0.7.6\n \t\t\ttest\n \t\t\n \t\n \n \t\n \t\t\n \t\t\tThe MIT License\n \t\t\thttp://opensource.org/licenses/mit-license.php\n \t\t\n \t\n \n \t\n \t\t\n \t\t\tclojars.org\n \t\t\tClojars repository\n \t\t\thttps://clojars.org/repo\n \t\t\n \t\n \n \t\n \t\tscm:git:git@github.com:clojure-numerics/${project.artifactId}.git\n \t\tscm:git:git@github.com:clojure-numerics/${project.artifactId}.git\n \t\tscm:git:git@github.com:clojure-numerics/${project.artifactId}.git\n \t\tHEAD\n \t\n \n" }, { "path": "pom.xml.asc", "content": "-----BEGIN PGP SIGNATURE-----\nVersion: GnuPG v1\n\niQEcBAABAgAGBQJZGND4AAoJEDhhxra0UbKhY7cH/A1ty5OviD3SKOV7fM92juPD\nAI7UEa9TqI9TvcdjpSnhJ2GKcUPiZ1YjJ/QPCU7rqAIoMG0U95oryR/JzbldlvCf\nUaTQtarBr0qNAbr8E6qZM1GpvBRBOYDiM1vKzmW8c4XWxGz5X2pArEedCr9E6fqa\nTvOh+Jhrei/OZ+ynyTn++cGsXdJQ+zKo8RWx3VTtCfkZEO0fxMu8qTXSaXuQOWtG\nGgj1kPqA87ulqlci4KKgoXVLzT3DUBxoErFBzvSs6cAo7wKd/guTFnCWIAT6Bm4i\nVXQtigjMT405zsrmx/zxXynh+jwGBfT8aW4K06DLC404NLTAusQCwxG0etHWFuY=\n=I9XE\n-----END PGP SIGNATURE-----\n" }, { "path": "project.clj", "content": "(defproject expresso \"0.2.4\"\n :description \"a general Algebraic Expression manipulation library in clojure\"\n :url \"https://github.com/clojure-numerics/expresso\"\n :license {:name \"The MIT License\"\n :url \"http://opensource.org/licenses/mit-license.php\"}\n :profiles {:dev {:dependencies [[org.clojure/tools.trace \"0.7.8\"]\n [criterium \"0.4.3\"]]}}\n :dependencies [[org.clojure/clojure \"1.11.1\"]\n [instaparse \"1.4.5\"]\n [net.mikera/core.matrix \"0.63.0\"]\n [org.clojure/core.memoize \"0.5.8\"]\n [mschuene/core.logic \"0.8.11.1\"]]\n :source-paths [\"src\" \"src/main/clojure\"]\n :test-paths [\"test\" \"src/test/clojure\"]\n :aot [numeric.expresso.impl.pimplementation])\n\n" }, { "path": "src/main/clojure/numeric/expresso/calculus.clj", "content": "(ns numeric.expresso.calculus\n (:use [numeric.expresso.construct]\n [numeric.expresso.protocols]\n [numeric.expresso.simplify]\n [numeric.expresso.rules]))\n\n;;implementation of the diff-function multimethod which dispatches to the\n;;right operator.\n\n(defmethod diff-function '+ [[expr v]]\n (let [args (expr-args expr)]\n (cev '+ (map #(differentiate-expr % v) args))))\n\n(defmethod diff-function '* [[expr v]]\n (let [args (vec (expr-args expr))\n c (count args)]\n (cev '+ (loop [i 0 exprs []]\n (if (< i c)\n (recur (inc i)\n (conj exprs\n (cev '* (concat (subvec args 0 i)\n [(differentiate-expr\n (nth args i) v)]\n (subvec args (inc i))))\n ))\n exprs)))\n ))\n\n\n(defmethod diff-function '- [[expr v]]\n (let [args (vec (expr-args expr))]\n (if (= 1 (count args))\n (ce '- (differentiate-expr (first args) v))\n (differentiate-expr\n (cev '+ (concat [(first args)] (map #(ce '- %) (rest args)))) v))))\n\n(defmethod diff-function '/ [[expr v]]\n (let [args (vec (expr-args expr))]\n (if (= 1 (count args))\n (differentiate-expr (ce '** (first args) -1) v)\n (differentiate-expr\n (cev '* (concat [(first args)] (map #(ce '/ %) (rest args)))) v))))\n\n(defmethod diff-function '** [[expr v]]\n (let [args (vec (expr-args expr))]\n (if (= (count args) 2)\n (if (= (nth args 0) v)\n (ce '* (nth args 1) (ce '** (nth args 0)\n (apply-rules eval-rules\n (ce '- (nth args 1) 1)))\n (differentiate-expr (nth args 0) v))\n (differentiate-expr\n (ce 'exp (ce '* (nth args 1) (ce 'log (nth args 0)))) v))\n (differentiate-expr\n (cev '** (concat [(ce '** (nth args 0) (nth args 1))] (subvec args 2)))\n v))))\n\n(defmethod diff-function 'log [[expr v]]\n (ce '* (ce '/ (second expr)) (differentiate-expr (second expr) v)))\n\n(defmethod diff-function 'sin [[expr v]]\n (ce '* (ce 'cos (second expr)) (differentiate-expr (second expr) v)))\n\n(defmethod diff-function 'cos [[expr v]]\n (ce '* (ce '- (ce 'sin (second expr))) (differentiate-expr (second expr) v)))\n\n(defmethod diff-function 'exp [[expr v]]\n (ce '* (cev 'exp (rest expr)) (differentiate-expr (second expr) v)))\n\n(def differentiation-rules\n (with-meta\n (concat eval-rules universal-rules\n simplify-rules)\n {:id :dr}))\n\n(defn differentiate\n \"differentiates expression in regard to variable v\"\n [v expr]\n (->> expr\n (#(differentiate-expr % v))\n (transform-expression differentiation-rules)))" }, { "path": "src/main/clojure/numeric/expresso/construct.clj", "content": "(ns numeric.expresso.construct\n (:refer-clojure :exclude [== record?])\n (:use [numeric.expresso.properties]\n [clojure.core.logic])\n (:require [clojure.walk :as walk]\n [clojure.set :as set]\n [numeric.expresso.protocols :as protocols]\n [numeric.expresso.impl.pimplementation :as impl]\n [numeric.expresso.types :as types]\n [clojure.core.matrix :as mat]\n [clojure.core.matrix.operators :as mop]\n [numeric.expresso.utils :as utils])\n (:import [numeric.expresso.impl.pimplementation PolynomialExpression\n BasicExtractor]))\n(declare ce cev create-normal-expression)\n\n;;This is the namespace for constructing expressions. Its main function is\n;;ce (for create expression) which behaves like list* but adds important meta\n;;data to the expression which expresso uses for its manipulations.\n;;The constructing is also based on multimethod dispatch so it can be extended\n;;to custom operators easily\n;;I recommend reading the ce functions first.\n\n\n;;the shape of the inner-product expression is dependend on the first\n;;and last position of a shape which is not just []\n\n(defn- first-last-pos-mshape\n \"finds the first and the last position of nun-number-shaped arg in args\"\n [args]\n (let [args (vec args)\n n (count args)\n f (loop [i 0] (if (< i n) (if (< (count (nth args i)) 2)\n (recur (inc i)) i) nil))\n l (loop [i (dec n)] (if (<= 0 i) (if (< (count (nth args i)) 2)\n (recur (dec i)) i) nil))]\n (and f l [f l])))\n\n\n\n(defn- inner-product-shape\n \"calculates the shape of an inner-product expression\"\n [& symb]\n (if-let [[f l] (first-last-pos-mshape symb)]\n (if (= f l) (if (or (= 0 f) (= (dec (count symb)) f))\n (nth symb f) [])\n (vec (concat (butlast (nth symb f)) (rest (nth symb l)))))\n (let [vs (remove empty? symb)]\n (if (even? (count vs)) [] (last vs)))))\n\n;;special constructing function for the inner-product. Constructs the expression\n;;in the normal way and sets its shape to the (evaled if possible) shape\n;;expression\n\n(defn- create-inner-product\n \"creates an inner-product expression\"\n [[symb args]]\n (let [shapes (map protocols/shape args)\n expr (create-normal-expression symb args)]\n (-> expr (protocols/set-shape \n (impl/eval-if-determined\n (create-normal-expression\n `inner-product-shape shapes))))))\n\n\n(defn- longest-shape\n \"returns the longest-shape of its args\"\n [& args]\n (first (sort-by (comp - count) args)))\n\n;;creates the elemwise-operations from core.matrix with the shape computed\n;;with the implicit broadcasting semantics from core.matrix\n(defn create-elemwise-operation [symb args]\n (let [shapes (map protocols/shape args)]\n (-> (create-normal-expression symb args)\n (protocols/set-shape\n (if-not (some #(or (lvar? %) (symbol? %) (protocols/expr-op %)) shapes)\n (first (sort-by (comp - count) shapes))\n (create-normal-expression `longest-shape shapes))))))\n \n\n;;constructing dispatch for known symbols to expresso\n \n(defmulti create-special-expression\n \"dispatch method for expression construction used for ce\"\n first)\n(defmethod create-special-expression :default [_] nil)\n(defmethod create-special-expression 'inner-product [x]\n (create-inner-product x))\n(defmethod create-special-expression 'mmul [x]\n (create-inner-product x))\n(defmethod create-special-expression 'negate [[symb args]]\n (create-elemwise-operation '- args))\n(defmethod create-special-expression 'add [[symb args]]\n (create-elemwise-operation '+ args))\n(defmethod create-special-expression 'sub [[symb args]]\n (create-elemwise-operation '- args))\n(defmethod create-special-expression 'emul [[symb args]]\n (create-elemwise-operation '* args))\n(defmethod create-special-expression 'mul [[symb args]]\n (create-elemwise-operation '* args))\n(defmethod create-special-expression 'div [[symb args]]\n (create-elemwise-operation '/ args))\n(defmethod create-special-expression '+ [[symb args]]\n (create-elemwise-operation '+ args))\n(defmethod create-special-expression '- [[symb args]]\n (create-elemwise-operation '- args))\n(defmethod create-special-expression '* [[symb args]]\n (create-elemwise-operation '* args))\n(defmethod create-special-expression '/ [[symb args]]\n (create-elemwise-operation '/ args))\n\n;;An example of what this dispatch allows. This is te construction of a\n;;sum expression so that (sum k 0 5 k) means (sum k (<= 0 k 5) k)\n;;the also the execute function for sum expressions and the\n;;emit-code function in properties.clj\n\n(defmethod create-special-expression 'sum [[symb args]]\n (let [args (vec args)]\n (case (count args)\n 3 (create-normal-expression 'sum args)\n 4 (create-normal-expression 'sum [(nth args 0)\n (create-normal-expression\n '<= [(nth args 1) (nth args 0)\n (nth args 2)])\n (nth args 3)]))))\n \n\n;;expresso construct symbols from the whole namespace qualified name of a\n;;symbol. For known symbols expresso uses short symbols according to this\n;;multimethods\n(defmulti expresso-name\n \"transforms the fully-qualified symbol to a short symbol used in expresso\"\n identity)\n(defmethod expresso-name :default [s]\n (if (= (str s) \"clojure.core//\") '/ s))\n(defmethod expresso-name 'clojure.core/* [_] '*)\n(defmethod expresso-name 'clojure.core/+ [_] '+)\n(defmethod expresso-name 'clojure.core/- [_] '-)\n(defmethod expresso-name 'clojure.core// [_] '/)\n(defmethod expresso-name 'clojure.core/abs [_] 'abs)\n(defmethod expresso-name `= [_] '=)\n(defmethod expresso-name 'numeric.expresso.core/** [_] '**)\n(defmethod expresso-name `mop/* [_] '*)\n(defmethod expresso-name `mop/+ [_] '+)\n(defmethod expresso-name `mop/- [_] '-)\n(defmethod expresso-name `mat/emul [_] '*)\n(defmethod expresso-name `mat/div [_] '/)\n(defmethod expresso-name `mat/add [_] '+)\n(defmethod expresso-name `mat/sub [_] '-)\n(defmethod expresso-name 'Math/abs [_] 'abs)\n(defmethod expresso-name 'Math/acos [_] 'acos)\n(defmethod expresso-name 'Math/asin [_] 'asin)\n(defmethod expresso-name 'Math/atan [_] 'atan)\n(defmethod expresso-name 'Math/cos [_] 'cos)\n(defmethod expresso-name 'Math/cosh [_] 'cosh)\n(defmethod expresso-name 'Math/exp [_] 'exp)\n(defmethod expresso-name 'Math/log [_] 'log)\n(defmethod expresso-name 'Math/log10 [_] 'log10)\n(defmethod expresso-name 'Math/sin [_] 'sin)\n(defmethod expresso-name 'Math/sinh [_] 'sinh)\n(defmethod expresso-name 'Math/sqrt [_] 'sqrt)\n(defmethod expresso-name 'Math/tan [_] 'tan)\n(defmethod expresso-name 'Math/tanh [_] 'tanh)\n(defmethod expresso-name 'mat/negate [_] '-)\n(defmethod expresso-name `mat/mul [_] 'mul)\n(defmethod expresso-name `mat/inner-product [_] 'inner-product)\n\n;;single expression creation\n(defn- create-expression\n \"constructing function for Expression Datatype\"\n [symbol args]\n (numeric.expresso.impl.pimplementation.Expression. symbol (vec args)))\n\n(defn create-extractor\n \"creates an expreator from the symbol and arguments\"\n [symb args]\n (when-let [rel (extractor-rel symb)]\n (numeric.expresso.impl.pimplementation.BasicExtractor. symb args rel)))\n\n;;adds metadata to a symbol in the expression and adds type and shape information\n;;in it. by default it is assumed to be a number.\n;;if it has a type key in its metadata than the corresponging expresso type\n;;is used. this makes it possible to construct a matrix symbol very easy like in\n;;(ex (+ a ^:matrix b)) where a is a normal number and b is a matrix of undeter-\n;;mined shape\n\n(defn construct-symbol\n \"adds metadata the the symbol which occurs in an unprocessed expression\"\n [arg]\n (let [type (cond (:matrix (meta arg)) types/matrix\n (:number (meta arg)) types/number\n (:double (meta arg)) types/double\n (:long (meta arg)) types/long\n (:int (meta arg)) types/integer\n :else (if (sequential? (:shape (meta arg)))\n types/matrix\n types/number))\n shape (cond (isa? type types/number) []\n (= type types/matrix) (or (:shape (meta arg))\n (lvar 'shape))\n :else (lvar 'shape))]\n (with-meta arg (merge {:type type :shape shape} (meta arg)))))\n\n;;creates a list of (op args*). Creates a real instance of PersistentList.\n;;This is the fastest way to construct the Persistent list after some\n;;experiments. It adds the metadata to the symbol. See properties.clj for details\n\n(defn create-normal-expression\n \"creates a metadata attached list of (symb args*)\"\n [symb args]\n (into '() (concat (reverse args) [(with-meta symb (add-information symb))])))\n\n;;Main construction function for expressions.\n;;uses the short name for the fully namespace qualified symbol if expresso\n;;knows about the expression. It adds the right metadata to all symbols in the\n;;argument list. It than uses the dispatch functions create-special-expression\n;;and create-extractor to construct the expression, backing up to just creating\n;;the expression with create-normal-expression\n\n(defn ce\n \"constructs an expression from the symbol with the supplied args\"\n [symb & args]\n (let [symb (expresso-name symb)\n args (map #(if (symbol? %) (construct-symbol %) %) args)]\n (or (create-special-expression [symb args])\n (create-extractor symb args)\n (create-normal-expression symb args))))\n\n;;same as ce but doesn't take variable args\n(defn cev\n \"same as ce. Treats args as vector\"\n [symb args]\n (apply (partial ce symb) args))\n\n;;explicit constructing functions for symbols to use in expressions.\n;;not explicitly neccessary for the most cases but very useful if one\n;;particular (matrix) symbol is used in many places in the expression\n\n(defn expresso-symb\n \"creates a symbol for further use in expresso\n adds the shape, type and properties specified\"\n [symb & {:keys [shape type properties]\n :or {shape (lvar 'shape)\n type types/number\n properties #{}}}]\n (let [meta\n (cond\n (= type types/number)\n (if (or (lvar? shape) (= shape []))\n {:shape [] :type type :properties properties}\n {:shape shape :type types/matrix :properties properties})\n :else {:shape shape :type type :properties properties})]\n (construct-symbol (with-meta symb meta))))\n\n\n(defn matrix-symb\n \"creates a symbol representing a matrix in expresso\"\n [symb &{:keys [shape properties]\n :or {shape (lvar 'shape)\n properties #{}}}]\n (expresso-symb symb :shape shape :properties properties :type types/matrix))\n\n(defn zero-matrix\n \"creates a symbol representing a zero-matrix in expresso\"\n [& {:keys [shape symb properties]\n :or {shape (lvar 'shape)\n symb (gensym \"zeromat\")\n properties #{:mzero}}}]\n (expresso-symb symb :shape shape :type types/matrix\n :properties (set/union #{:mzero} properties)))\n\n(defn identity-matrix\n \"creates a symbol representing an identity-matrix in expresso\"\n [& {:keys [shape symb properties]\n :or {shape (lvar 'shape)\n symb (gensym \"identitymat\")\n properties #{:midentity}}}]\n (expresso-symb symb :shape shape :type types/matrix\n :properties (set/union #{:midentity} properties)))\n\n;;; The rule based translator matches the operator symbol with respect to\n;;; clojures hierarchy semantics, so a rule written for 'e/ca-op matches all\n;;; commutative-associative operators -- this hierarchies aren't used very much\n;;; in expresso up to now\n\n(derive 'e/ca+ 'e/ca-op)\n(derive 'e/ca* 'e/ca-op)\n(derive 'e/+ 'e/ca+)\n(derive 'e/* 'e/ca*)\n(derive 'e/add 'e/ca-op)\n(derive 'clojure.core/+ 'e/ca+)\n(derive 'clojure.core/* 'e/ca*)\n(derive 'clojure.core/- 'e/-)\n(derive 'clojure.core// 'e/div)\n(derive 'clojure.core.matrix.operators/+ 'e/ca-op)\n(derive 'clojure.core.matrix/add 'e/ca-op)\n(derive `° 'e/ao-op)\n\n;;constructing and manipulation functions for sequential-matchers\n;;The rule based translator has a feature called seq-matching where one\n;;symbol starting with ?& can match a whole sequence from the expression.\n;;Internally seq-matchers are represented by a vector of [::seq-match data]\n\n;;The functions seq-matcher and matcher-args are used to construct and\n;;deconstruct seq-matchers\n;;There are also a few utility functions which wrap ad unwrap the seq-matcher\n;;like map-sm zip-sm, ... they can be recognized by the -sm suffix\n(defn seq-matcher\n \"constructs a sequential-matcher containing the specified data\"\n [data]\n [::seq-match data])\n\n(defn matcher-args\n \"returns the data of the seq-matcher\"\n [seq-matcher]\n (if (and (sequential? seq-matcher) (= (first seq-matcher) ::seq-match))\n (second seq-matcher)\n [seq-matcher]))\n\n(defn zip-sm\n \"zips the seq-matcher with the specified colls\"\n [sm & colls]\n (apply (partial map (fn [& a] a) (matcher-args sm)) colls))\n\n(defn map-sm\n \"maps the content of the sec-matchers with func\"\n [func & sm]\n (->> sm (map matcher-args) (apply (partial map func)) seq-matcher))\n\n(defn first-sm\n \"returns the first element of the seq-matcher\"\n [sm]\n (first (matcher-args sm)))\n(defn rest-sm\n \"returns the rest of the seq-matcher data\"\n [sm]\n (seq-matcher (rest (matcher-args sm))))\n\n(defn last-sm\n \"returns the last element of the seq-matcher data\"\n [sm]\n (last (matcher-args sm)))\n\n(defn count-sm\n \"returns the count of the seq-matcher data\"\n [sm]\n (count (vec (matcher-args sm))))\n\n(defn split-in-pos-sm\n \"splits the seq-matcher data to [left pos-elem right]\"\n [sm pos]\n (let [args (vec (matcher-args sm))]\n [(seq-matcher (subvec args 0 pos))\n (nth args pos)\n (seq-matcher (subvec args (+ pos 1) (count args)))]))\n\n\n;;Because ce only constructs one level of an expression one would have to\n;;construct expressions like this: (ce '+ 1 2 (ce '- 3 4)). The higher level\n;;construction macros presented here allow you to construct expressions like this\n;;(ex (+ 1 2 (- 3 4))) by expanding into the appropriate calls to ce\n;;ex does implicit quoting while ex' does implifit quoting both allow for ~\n;;to be used in the supplied list\n\n(defn- var-to-symbol [v]\n (let [s (str v)\n erg (-> (.substring s 2 (.length s)) symbol)]\n erg))\n\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n;;construct-with macro. This macro kaves a symbol vector and encloses arbitrary\n;;code. The enclosed code is then walked and every occurrence of one symbol in\n;;the symbol vector which is in function position in the code is replaced by a\n;;call to ce\n;;especially useful when constructing rules.\n;;This macro is a workaround about some annoyances with clojures namespaces\n;;using this macro has the same effect as using the functions in\n;;numeric.expresso.constructing-functions specified in the symbol vector for\n;;the enclosed code and has no other distorting effect on code outside of the\n;;enclosing code. This is more convenient than using the constructing-functions\n;;and having to use aliases for the clojure +,-,*,/,= for the whole rest of\n;;the namespace.\n(defn- replace-with-expresso-sexp\n \"if s-exp has op in symbs replace if be call to ce function\"\n [symbs s-exp]\n (if (and (seq? s-exp) (symbs (first s-exp)))\n (let [f (first s-exp)\n symb (if-let [r (resolve f)] (var-to-symbol r) f)]\n (list* `ce (list 'quote symb) (rest s-exp)))\n s-exp))\n\n(defn- construct-with*\n \"replaces all calls to functions in symbv with calls to ce\"\n [symbv & code]\n (let [s-set (set symbv)]\n `(do \n ~@(clojure.walk/postwalk #(replace-with-expresso-sexp s-set %) code))))\n\n(defmacro construct-with\n \"replaces all calls to functions in symbv with expression constructing\n functions.\"\n [symbv & code]\n (apply (partial construct-with* symbv) code))\n\n\n;;the ex' macro replaces in its body all function position operators with\n;;calls to ce. The operators are fully namespace-qualified when calling ce.\n;;It does not automatically quote a symbol in the expr\n(declare resolve-op)\n\n(defn- create-expression-with-explicit-quoting\n [s expr]\n (if (and (seq? expr) (symbol? (first expr)) (not= (first expr) 'quote))\n (if (= 'clojure.core/unquote (first expr))\n (second expr)\n (list* `ce (list 'quote (resolve-op (first expr)))\n (map #(create-expression-with-explicit-quoting s %) (rest expr))))\n (if (s expr) (list 'quote expr) expr)))\n\n(defn ex'*\n \"function version of ex'\"\n [& expr]\n (let [[s expr]\n (if (= (count expr) 1)\n [#{} (first expr)]\n [(into #{} (first expr)) (second expr)])]\n (create-expression-with-explicit-quoting s expr)))\n\n(defmacro ex'\n \"creates an expression with explicit quoting.\"\n [& expr]\n (apply ex'* expr))\n\n;;The ex macro\n;;Like the ex' macro but implicitly quotes the arguments. It is the most useful\n;;and most used construction macro so far.\n\n(defn- resolve-op\n \"resolves the operator op\"\n [op]\n (if-let [r (resolve op)] (var-to-symbol r) op))\n\n\n(defn- create-expression-with-implicit-quoting\n \"creates an expression with implicit quoting\"\n [expr]\n (if (and (seq? expr) (symbol? (first expr)))\n (if (= 'clojure.core/unquote (first expr))\n (second expr)\n (list* `ce (list 'quote (resolve-op (first expr)))\n (map create-expression-with-implicit-quoting (rest expr))))\n (list 'quote expr)))\n\n(defn ex*\n \"function version of ex\"\n [expr]\n (create-expression-with-implicit-quoting expr))\n\n(defmacro ex\n \"creates expression with implicit quoting of variables\"\n [expr]\n (ex* expr))\n\n\n(defn let-expr\n \"creates a let-expression with specified bindings and code vector\"\n [bindings code]\n (numeric.expresso.impl.pimplementation.LetExpression. bindings code))\n\n(defn to-expression\n \"converts the given expr, which consists of normal clojure s-expr\n to s-expr with expresso metadata added, so that it can be handled\n by the manipulation functions in expr. Is called on the input of all\n numeric.expresso.core functions. Does nothing if expr is already a\n valid expresso expression\"\n [expr]\n (if-let [op (protocols/expr-op expr)]\n expr\n (walk/postwalk #(if (and (seq? %) (symbol? (first %)))\n (apply (partial ce (first %)) (rest %))\n %) expr)))\n\n(defn extractor?\n \"checks whether x is an extractor\"\n [x]\n (instance? BasicExtractor x))\n" }, { "path": "src/main/clojure/numeric/expresso/constructing_functions.clj", "content": "(ns numeric.expresso.constructing-functions\n (:refer-clojure :exclude [== + - * /])\n (:use [numeric.expresso.construct]\n [clojure.test]))\n\n \n(defmacro define-constructing-functions\n \"defines expresso construction functions for the operators. The operators can\n not be namespace qualified. An operator can also be a 2-element vector\n instead of a symbol. In this case the function generated will have the name\n of the first element and will construction the operation specified in the\n second element (which can then be qualified). The symbols should not be\n quoted.\"\n [operators]\n `(do ~@(for [op operators]\n (if (vector? op)\n `(defn ~(first op) [& ~'args]\n (cev (quote ~(second op)) ~'args))\n `(defn ~op [& ~'args]\n (cev (quote ~op) ~'args))))))\n\n(defn ^:dynamic ** [& args] (cev '** args))\n\n(define-constructing-functions [+ - * / mul div sub add\n sqrt log sin cos log asin atan\n acos emul inner-product scale mul\n add-product add-scaled add-scaled-product\n normalise normalise-probabilities dot\n outer-product cross distance det\n inverse negate trace length length-squared\n pow log rank sum abs exp is? cons? mzero?\n midentity? as? shape?])\n" }, { "path": "src/main/clojure/numeric/expresso/core.clj", "content": "(ns numeric.expresso.core\n (:refer-clojure)\n (:require [clojure.core.logic :as logic]\n [numeric.expresso.solve :as solve]\n [numeric.expresso.simplify :as simp]\n [numeric.expresso.optimize :as opt]\n [numeric.expresso.protocols :as protocols]\n [numeric.expresso.rules :as rules]\n [numeric.expresso.parse :as parse]\n [numeric.expresso.calculus :as calc]\n [numeric.expresso.types :as types]\n [numeric.expresso.utils :as utils]\n [numeric.expresso.properties :as props]\n [numeric.expresso.impl.polynomial :as poly]\n [numeric.expresso.construct :as constr]))\n\n(defmacro ex\n \"constructs an expression from the given s-exp. variables are automatically\n quoted. Unquote can be used to supply the value for a variable in scope\n example:\n (ex (+ x (* x y)))\n (let [x 3]\n (ex (+ x (* ~x y))))\n Expresso expressions are still clojure s-expressions and can be fully\n manipulated with the clojure seq functions if wished.\"\n [expr]\n (constr/ex* expr))\n\n(defmacro ex'\n \"like ex but constructs the expressions with explicit quoting needed, so\n (let [x 3] (ex' (+ 3 x))) :=> (+ 3 3)\n supports an optional vector of symbols as first argument, which are implicitly\n quoted in the expression:\n (let [x 3] (ex' [x] (+ 3 x))) :=> (+ 3 x)\"\n ([expr] (constr/ex'* expr))\n ([symbv expr] (apply constr/ex'* [symbv expr])))\n\n(defn expression?\n \"tests whether the input is a compound expression.\n Examples: (expression? (ex (+ 1 2))) ;=> true\n (expression? '(+ 1 2)) ;=> true\n (expression? [+ 1 2]) ;=> false\"\n [expr]\n (-> expr\n constr/to-expression\n protocols/expr-op\n boolean))\n\n(defn constant?\n \"tests whether the input is a constant. The negation of expression?.\n Examples: (constant? 5) ;=> true\n (constant? [+ 1 2]) ;=> true\n (constant? '(+ 1 2)) ;=> false\"\n [expr]\n (not (expression? expr)))\n\n\n(defn properties\n \"returns the set of properties which the given expression contains\n Example: (properties (expresso-symbol 'x :properties #{:positive}))\n => #{:positive})\"\n [expr]\n (protocols/properties expr))\n\n(defn vars\n \"returns the set of variables in the given expression\n Example: (vars (ex (* x y x))) ;=> #{x y}\"\n [expr]\n (protocols/vars expr))\n\n(defn shape\n \"returns the shape of the given expression. Can also return an lvar or an\n expression indicating that the shape couldn't fully be inferred.\n Example: (shape (ex (+ 1 2))) ;=> [], (shape (matrix-symbol 'x)) ;=> lvar...\"\n [expr]\n (protocols/shape expr))\n\n(defn expresso-symbol\n \"annotates the given symbol with the information of its shape, type and\n properties. Types are defined in numeric.expresso.types.\n Example: (expresso-symbol 'x) ;=> x,\n (expresso-symbol 'x :properties #{:positive})\n ;=> 'x and (properties x) :=> #{:positive}\"\n [symb & {:keys [shape type properties]\n :or {shape (logic/lvar 'shape)\n type types/number\n properties #{}}}]\n (constr/expresso-symb symb :shape shape :type type :properties properties))\n\n(defn matrix-symbol\n \"annotates the symbol so that it represents a matrix in expresso. Also accepts\n shape and properties keyword arguments\n Example: (matrix-symbol 'x :shape [2 2]) => 'x\"\n [symb &{:keys [shape properties]\n :or {shape (logic/lvar 'shape)\n properties #{}}}]\n (constr/matrix-symb symb :shape shape :properties properties))\n\n(defn zero-matrix\n \"creates a symbol (or annotates the given symbol) to represent a zero-matrix\n Example: (properties (zero-matrix)) ;=> #{:mzero}\"\n [& {:keys [shape symb properties]\n :or {shape (logic/lvar 'shape)\n symb (gensym \"zeromat\")\n properties #{:mzero}}}]\n (constr/zero-matrix :symb symb :shape shape :properties properties))\n\n(defn identity-matrix\n \"creates a symbol (or annotates the given symbol) to represent an\n identity-matrix. Example: (properties (identity-matrix)) ;=> #{:midentity}\"\n [& {:keys [shape symb properties]\n :or {shape (logic/lvar 'shape)\n symb (gensym \"identitymat\")\n properties #{:midentity}}}]\n (constr/identity-matrix :shape shape :symb symb :properties properties))\n\n(defn parse-expression\n \"parses the expression from the given string supports = + - * / ** with the\n normal precedence. Also supports arbitrary functions in the input.\n Unnests operators where possible. You can escape symbols with `\n examples:\n (parse-expression \\\"1+2+3\\\") :=> (+ 1 2 3)\n (parse-expression \\\"1+2*3**4+5\\\")\n :=> (+ 1 (* 2 (** 3 4)) 5)\n (parse-expression \\\"sin(x)**2 + cos(x)**2 = 1\\\")\n :=> (= (+ (** (sin x) 2) (** (cos x) 2)) 1)\n (parse-expression \\\"`inner-product`(a)\\\" :=> (inner-product a)\"\n [s]\n (parse/parse-expression s))\n\n(defn evaluate\n \"evaluates the expression after replacing the symbols in the symbol map with\n their associated values. Example: (evaluate (ex (* 2 x)) {'x 3}) :=> 6\"\n ([expr] (evaluate expr {}))\n ([expr sm]\n (-> expr\n constr/to-expression\n (protocols/evaluate sm))))\n\n(defn substitute \n \"substitutes every occurrence of a key in the replacement-map by its value\n Example: (substitute (ex (+ (* a b) (* a b) (/ c d)))\n {(ex (* a b)) 'x 'c 'y 'd 'z}) => (+ x x (/ y z))\"\n [expr repl]\n (-> expr\n constr/to-expression\n (protocols/substitute-expr repl)))\n\n\n(defn- ratio-test [simplified-expr expr ratio]\n (if-not ratio\n simplified-expr\n (let [expr-count (-> expr flatten count)\n simplified-expr-count (-> simplified-expr flatten count)]\n (when (<= (/ simplified-expr-count expr-count) ratio)\n simplified-expr))))\n\n\n(defn simplify\n \"best heuristics approach to simplify the given expression to a 'simpler' form.\n The optional ratio argument gives control about what is the maximal ratio of\n simplified/original-expression after the invokation of simplify.\n example: (simplify (ex (+ (* a b) (* a c) 5 -5))) => (* a (+ b c))\n (simplify (ex (+ (* a b) (* a c) 5 -5)) :ratio 0.5) => nil\"\n [expr & {:keys [ratio] :or {ratio nil}}]\n (-> expr\n constr/to-expression\n simp/simp-expr\n (ratio-test expr ratio)))\n\n(defn multiply-out\n \"fully multiplies out the given expression. Example:\n (multiply-out (ex (+ (* a (+ b c)) (** (+ d e) 2))))\n => (+ (** e 2) (* 2 d e) (** d 2) (* b a) (* c a))\"\n [expr]\n (-> expr\n constr/to-expression\n simp/multiply-out))\n\n(defn evaluate-constants\n \"evaluates fully determined (sub-) expressions and folds determined factors\n in commutative and associative functions.\n (evaluate-constants (ex (+ (* (- 5 2) a) (* 4 5))))\n => (+ (* 3 a) 20)\"\n [expr]\n (-> expr\n constr/to-expression\n simp/evaluate-constants))\n\n(defn to-polynomial-normal-form\n \"transforms the given expression to a fully expanded (recursive) polynomial\n representation with v as main variable.\n Example: (to-polynomial-normal-form 'x (ex (* (+ x a 1) (* x (+ 1 a)))))\n :=> (+ (* (+ 1 (* 2 a) (** a 2)) x) (* (+ 1 a) (** x 2)))\"\n [v expr]\n (some->> expr\n constr/to-expression\n (poly/poly-in v)\n (rules/transform-expression simp/universal-rules)))\n\n(defn rearrange\n \"if the equation contains only one occurrence of v it will be rearranged so\n that v is the only symbol on the lhs of the equation. returns a list of the\n possible rearrangements.\n (rearrange 'x (ex (= (abs x) 3)))\n => ((= x 3) (= x (- 3)))\n (rearrange 'x (ex (= (+ x x) 0))) => nil\"\n [v eq]\n (->> eq\n constr/to-expression\n utils/validate-eq\n (solve/rearrange v)))\n\n(defn solve\n \"general solving function. Dispatches to different solving strategies based on\n the input equations. Can solve one or more equations according to the\n variables in the symbol vector/set/list.\n In case of only one symbol to solve for symbv can be the symbol itself.\n examples:\n (solve 'x (ex (= 2 (* 4 x)))) ;=> #{1/2}\n (solve '[x y] (ex (= (+ (** x 2) (** y 2)) 1))\n (ex (= (+ x y) a)))\n ;=>\n #{{y (+ (* a 1/2) (* -1/4 (- (sqrt (+ (* -4.0 (** a 2)) 8))))),\n x (+ (* 1/2 a) (* (- (sqrt (+ (* -4.0 (** a 2)) 8))) 1/4))}\n {y (+ (* a 1/2) (* -1/4 (sqrt (+ (* -4.0 (** a 2)) 8)))),\n x (+ (* 1/2 a) (* (sqrt (+ (* -4.0 (** a 2)) 8)) 1/4))}}\"\n ([symbv eq]\n (let [symbv (if (coll? symbv) symbv [symbv])]\n (->> eq\n constr/to-expression\n utils/validate-eq\n (solve/solve (first symbv)))))\n ([symbv eq & reqs]\n (let [symbv (if (coll? symbv) symbv [symbv])]\n (->> (conj reqs eq)\n (map constr/to-expression)\n (map utils/validate-eq)\n (into #{})\n (solve/solve-system symbv)))))\n\n\n(defn differentiate\n \"Differentiates the given expression regarding the symbols in the symbol\n vector symbv\n example:\n (differentiate '[x] (ex (* (** x 3) (* 3 x))))\n ;=> (* 12 (** x 3))\n To differentiate twice:\n (differentiate '[x x] (ex (* (** x 3) (* 3 x))))\n ;=> (* 36 (** x 2))\"\n [symbv expr]\n (let [expr (->> expr constr/to-expression)]\n (reduce #(calc/differentiate %2 %1) expr symbv)))\n\n(defmacro compile-expr\n \"compiles the given expression to a clojure function which can be called\n according to the bindings vector. The compiled function will not have the\n overhead of walking the expression to excecute it. Compile-expr transforms\n the expression to clojure code which is then evaluated to a function\n example:\n ((compile-expr [x] (ex (+ 1 x))) 2) ;=> 3\"\n [bindings expr]\n `(opt/compile-expr* ~(list 'quote bindings) ~expr))\n\n(defn compile-expr*\n \"function equivalent of compile-expr. The bindings vector has to be quoted.\n Example: ((compile-expr* '[x] (ex (+ 1 x))) 2) ;=> 3\"\n [bindings expr]\n (->> expr\n constr/to-expression\n (opt/compile-expr* bindings)))\n\n(defn optimize\n \"transforms the expr to a more optimized form for excecution. The optimized\n form can be compiled with compile-expr. supports optimizations like compile\n time computation, removing unneeded code, common-subexpression detection,\n matrix chain order optimization ...\n example:\n (optimize (ex (+ b (* 5 b) (** y (+ a b)) (** z (+ b a)))))\n ;=> (let [local478813 (+ a b)] (+ (* b 6) (** y local478813)\n (** z local478813)))\"\n [expr]\n (-> expr\n constr/to-expression\n opt/optimize))\n\n" }, { "path": "src/main/clojure/numeric/expresso/impl/matcher.clj", "content": "(ns numeric.expresso.impl.matcher\n (:refer-clojure :exclude [== record?])\n (:use [numeric.expresso.impl.pimplementation]\n [numeric.expresso.protocols]\n [clojure.core.logic])\n (:require [clojure.walk :as walk]\n [numeric.expresso.utils :as utils]))\n(declare match-expressiono expression-matcho isao add-replacemento)\n;;This namespace implements the semantic matching algorithms used in expresso\n;;The idea is to let the pattern itself decide what mathching algorithm is used\n\n;;Therefore the matching is abstracted by the PMatch protocol whose default\n;;expression implementation is datadriven by the metadata :metch-rel key\n\n\n(extend-protocol PMatch\n java.lang.Object\n (match [this that] (== this that))\n numeric.expresso.impl.pimplementation.Expression\n (match [this that]\n (if-let [m (and (expr-op that) (meta (expr-op this)))]\n (fresh []\n (isao (expr-op that) (expr-op this))\n (add-replacemento (expr-op that) (expr-op this))\n ((:match-rel m) (expr-args this) (expr-args that)))\n fail))\n clojure.lang.ISeq\n (match [this that]\n (if-let [m (and (expr-op that) (meta (expr-op this)))]\n (fresh []\n (isao (expr-op that) (expr-op this))\n (add-replacemento (expr-op that) (expr-op this))\n ((:match-rel m) (expr-args this) (expr-args that)))\n fail))\n numeric.expresso.impl.pimplementation.BasicExtractor\n (match [this that]\n (let [args (.args this)\n rel (.rel this)]\n (rel args that))))\n\n;;weird isa? function because\n;;1. isa? doesn't behave well on clojure.core// as well as other symbol based\n;; method in clojure. Hopefully this changes in 1.6\n;;2. since expresso uses short, unqualified functions to represent known functios\n;; it can't derive hierarchies from these, so the convention is to derive\n;; hierarchies with e/short-symbol. This function also checks if the symbol\n;; prepended with e/ is isa? of b\n(defn exp-symb-isa? [a b]\n (let [res (or (isa? a b) (= (str a) (str b) \"clojure.core//\")\n (and (symbol? a) (not (some #{\\/} (butlast (str a))))\n (isa? (symbol (str \"e/\" a)) b)))]\n res))\n\n(defn isao\n \"succeeds if a isa? b or if any argument is unbound - in this case\n unifying them\"\n [a b]\n (conda\n ((== a b))\n ((project [a b]\n (== true (exp-symb-isa? a b))))))\n\n\n(defn is-expro [v]\n (project [v]\n (== true (boolean (expr-op v)))))\n\n(defn- memberposo\n \"like membero l (zip x (range))\"\n [l x]\n (project [x]\n (membero l (map (fn [& a] a) x (range)))))\n\n\n(defn- removeo\n \"binds xr to x with element at position i removed\"\n [i x xr]\n (project [i x]\n (== xr (concat (take i x) (drop (+ i 1) x)))))\n\n(defn- positivo\n \"succeeds if n is bigger than 0\"\n [n]\n (project [n] (if (> n 0) succeed fail)))\n\n(defn- deco\n \"binds nn to (dec n)\"\n [n nn]\n (project [n] (== nn (- n 1))))\n\n(defn- append-veco\n \"appendo on real vectors\"\n [ap r nap]\n (project [ap r]\n (== nap (conj (vec ap) r))))\n\n(defn- membersplito\n \"generates all possible splits of removing an element from x\n l will be bound to [removed-element rest-of-x]\"\n [l x]\n (project [x]\n (fresh [a i xr]\n (memberposo [a i] x)\n (removeo i x xr)\n (== l [a xr]))))\n\n(defn- subseto\n \"generates all subsets of size n from x with initial\n elements in ap\"\n [n x ap res]\n (fresh []\n (conda\n ((positivo n)\n (fresh [r rx nap nn]\n (membersplito [r rx] x)\n (append-veco ap r nap)\n (deco n nn)\n (subseto nn rx nap res)))\n ((== res [ap x])))))\n \n \n(defn zip\n \"utility to zip collections\"\n [& colls]\n (apply (partial map (fn [& a] a)) colls))\n\n(defn seq-matcher?\n \"A sequential matcher is a logic variable with a name starting with ?&\"\n [elem]\n (and (lvar? elem) (.startsWith ^String (:name elem) \"?&\")))\n\n(defn- counto\n \"unifies q to the count of pat or 1 if it is not a collection\"\n [pat q]\n (project [pat]\n (== q (if (coll? pat) (count pat) 1))))\n\n(defn- get-positions-of-seq-matchers\n \"returns all positions of sequential matchers in the pattern\"\n [pat]\n (reduce (fn [ps [p elem]]\n (if (seq-matcher? elem)\n (conj ps p)\n ps))\n [] (zip (range) (if (coll? pat) pat [pat]))))\n\n(defn- pos-of-seq-matcherso\n \"core.logic version of get-positions-of-seq-matchers\"\n [pat res]\n (project [pat]\n (== res (get-positions-of-seq-matchers pat))))\n\n\n(defn +-seq-matcher?\n \"a lvar starting with ?&+ is a +-seq-matcher. It matches one or more\n variables\"\n [psm] (.startsWith ^String (:name psm) \"?&+\"))\n\n(defn- check-boundso\n \"makes sequential matching fail if a ?&+ shall be unified with zero\n elements\"\n [psm esm]\n (project [esm]\n (if (and (+-seq-matcher? psm) (empty? esm))\n fail succeed)))\n\n(defn seq-expr-matcho\n \"matches psm with the elements in esm\"\n [psm esm]\n (fresh []\n (check-boundso psm esm)\n (== psm [:numeric.expresso.construct/seq-match esm])))\n\n(defn- split-expr\n \"splits pargs and eargs in normal and seq-matcher part - only supports\n &* matcher at last position in pargs\"\n [pargs eargs]\n (let [pos (get-positions-of-seq-matchers pargs)]\n (if (= (count pos) 0)\n [[pargs nil] [eargs nil]]\n (if (or (> (count pos) 1) (not= (first pos) (- (count pargs) 1)))\n (throw (Exception. \"only one seq-match in last position is supported\"))\n (let [cpa (count pargs)]\n [[(butlast pargs) (last pargs)] [(take (- cpa 1) eargs) (drop (- cpa 1) eargs)]])))))\n\n(defn- split-expro\n \"core.logic version of split-expr\"\n [pargs eargs res]\n (project [pargs eargs]\n (== res (split-expr pargs eargs))))\n\n\n(defna match-expressionso\n \"matches each of pargs and eargs according to the right matching function\"\n [pargs eargs]\n ([[p . ps] [e . es]] (match-expressiono p e) (match-expressionso ps es))\n ([[] []] succeed)\n ([_ _] fail))\n\n\n\n(defn single-expr-matcho\n \"default matching function if there are no seq-matchers in pargs\"\n [pargs eargs]\n (project [pargs eargs]\n (if (not= (count pargs) (count eargs))\n fail\n succeed))\n (match-expressionso pargs eargs))\n\n\n(defn- any-seq-matcherso\n \"succeeds when there is at least a seq-matcher in pattern\"\n [pargs]\n (project [pargs]\n (== false (if (coll? pargs) (not (some seq-matcher? pargs)) true))))\n\n(declare match-with-seq-matcherso)\n(defn expression-matcho\n \"default matching function - matches each element of pargs against the element\n at the same position in eargs using the right matching function. also supports\n sequential matchers\"\n [pargs eargs]\n (fresh []\n (conda\n ((any-seq-matcherso pargs) (match-with-seq-matcherso pargs eargs))\n ((single-expr-matcho pargs eargs)))))\n\n(defn- split-list\n \"creates the possible splits of v by removing an element if it is not a vlar\"\n [v]\n (let [res\n (for [x (range (count v)) :when (not (lvar? (nth v x)))] \n (let [elem (nth v x)\n left (take x v)\n right (drop (clojure.core/+ x 1) v)]\n [elem (concat left right)]))]\n res))\n\n\n(defn- split-listo\n \"core.logic version of split-list\"\n [l erg]\n (project [l ]\n (== erg (split-list l))))\n\n(defn only-lvarso\n \"succeeds when there are only lvars in args\"\n [args]\n (project [args]\n (== true (every? lvar? args))))\n\n(defn split-pargs\n \"splits pargs to the normal part and the sequential matcher part\n associative matching only supports one seq-matcher at any position\"\n [pargs]\n (let [p (filter #(seq-matcher? (second %)) (zip (range) pargs))]\n (if (not= (count p) 1)\n (throw (Exception. \"only one seq-matcher supported in commutative matching\"))\n (let [pp (first (first p))\n sm (second (first p))]\n [(concat (take pp pargs) (drop (+ pp 1) pargs)) sm]))))\n\n(defn- split-pargso\n \"core.logic version of split-pargs\"\n [pargs res]\n (project [pargs]\n (== res (split-pargs pargs))))\n\n(defn- no-seq-matcherso\n \"succeeds if there ale no seq-matchers in pargs\"\n [pargs]\n (project [pargs] (== 0 (count (filter seq-matcher? pargs)))))\n\n(defn- match-lvars-commutativeo\n \"generates the possible matches of eargs with the lvars in pargs\"\n [pargs eargs]\n (fresh [perm npargs sm cnp neargs to-seq-match]\n (conda\n ((no-seq-matcherso pargs)\n (permuteo pargs perm)\n (== perm eargs))\n ((split-pargso pargs [npargs sm])\n (project [npargs] (== cnp (count npargs)))\n (subseto cnp eargs [] [neargs to-seq-match])\n (== neargs npargs)\n (seq-expr-matcho sm to-seq-match)))))\n\n(defn match-commutativeo\n \"the matching function for commutative expressions.\n Matches if one permutation matches. also supports\n a seq-matcher\"\n [pargs eargs]\n (fresh [esl psl eng png er pr]\n (conda\n ((only-lvarso pargs) (match-lvars-commutativeo pargs eargs))\n ((only-lvarso eargs) (match-lvars-commutativeo pargs eargs))\n ((split-listo pargs psl)\n (membero [png pr] psl)\n (split-listo eargs esl)\n (membero [eng er] esl)\n (match-expressiono png eng)\n (match-commutativeo pr er)))))\n\n\n(defn- split-seq-matchers\n \"splits pargs and eargs in the fix part and the variable parts\"\n [pargs eargs]\n (let [indices (map first (filter (comp seq-matcher? second) (zip (range) pargs)))\n sections (partition 2 1 indices)\n v-part (concat (map (fn [[f l]] [(nth pargs f) (subvec pargs (inc f) l)]) sections) [[(nth pargs (last indices)) []]])]\n [(first indices) (last indices)\n (- (count eargs) (- (count pargs) (last indices)))\n v-part]))\n\n(defn- split-seq-matcherso\n \"core.logic version of split-seq-matchers\"\n [pargs eargs res]\n (project [eargs pargs]\n (== res (split-seq-matchers (vec pargs) (vec eargs)))))\n\n(defn- match-in-positionso\n \"matches the elements between fp and tp in pargs and\n fe and te in eargs\"\n [fp tp fe te pargs eargs]\n (project [fp tp fe te pargs eargs]\n (if (or (> tp (count pargs)) (> te (count eargs)))\n fail\n (if (and (< fp tp) (< fe te))\n (fresh []\n (match-expressiono (nth pargs fp) (nth eargs fe))\n (match-in-positionso (+ fp 1) tp (+ fe 1) te pargs eargs))\n succeed))))\n(defn- match-fix-parto\n \"matches the fix part of pargs and eargs\"\n [sm-start sp-end sm-end pargs eargs]\n (project [sm-start sp-end sm-end pargs eargs]\n (fresh []\n (match-in-positionso 0 sm-start 0 sm-start pargs eargs)\n (match-in-positionso (+ sp-end 1) (count pargs)\n (+ sm-end 1) (count eargs)\n pargs eargs))))\n\n(defn- start-positionso\n \"generates the possible starting positions for the first vpart in v-parts\n between from and to\"\n [from v-parts to pos]\n (project [from v-parts to]\n (let [s (apply + (map (comp count second) v-parts))\n anz-positions (- (+ to 1) from s)]\n (== pos (range from (+ from anz-positions 1))))))\n\n(defn- match-parto\n \"matches a variable part starting at start in eargs matching the seq matcher\n to te position in eargs from start to from\"\n [from part start eargs]\n (project [from part start eargs]\n (let [\n p (second part)\n sm (first part)\n tsm (subvec eargs from start)]\n (fresh []\n (match-in-positionso 0 (count p) start (+ start (count p))\n p eargs)\n (seq-expr-matcho sm tsm)))))\n\n(defn- match-last-seq-matchero\n \"matches the seq-matcher at the end of the variable part from from to to in\n eargs\"\n [from to seq-matcher eargs]\n (project [from to seq-matcher eargs]\n (let [sm (first seq-matcher)\n tsm (subvec eargs from (+ to 1))]\n (seq-expr-matcho sm tsm))))\n\n(defna match-variable-parto\n \"matches the variable patrs in eargs and the seq-matchers between them in the\n variable part of eargs starting at from to to\"\n [from to v-parts eargs]\n ([_ _ [part . '()] _]\n (match-last-seq-matchero from to part eargs))\n ([_ _ [part . parts] _]\n (fresh [pos start]\n (start-positionso from v-parts to pos)\n (membero start pos)\n (match-parto from part start eargs)\n (project [from part start]\n (match-variable-parto (+ start (count (second part)))\n to parts eargs)))))\n\n(defn match-with-seq-matcherso\n \"default matching function when there are seq-matchers. Matches the arguments\n in order and supports an arbitrary number of seq-matchers in any position\"\n [pargs eargs]\n (project [pargs eargs]\n (let [pargs (vec pargs) eargs (vec eargs)]\n (fresh [from top toe v-parts]\n (split-seq-matcherso pargs eargs [from top toe v-parts])\n (match-fix-parto from top toe pargs eargs)\n (match-variable-parto from toe v-parts eargs)))))\n\n\n\n\n(defn- get-symbol\n \"gets the symbol of the expression\"\n [expr]\n (if (coll? expr) (first expr) expr))\n\n(defmulti matcher\n \"the multimethod to get the right matching functions from the expression\"\n get-symbol)\n\n(defmethod matcher :default [_]\n expression-matcho)\n\n(defmethod matcher 'e/ca-op [_] match-commutativeo)\n\n(def replacements (atom {}))\n\n(defmulti extractor\n \"multimethod to get the right extractor function for the extractor\"\n get-symbol)\n\n\n(defn extract-is [pargs expr]\n (project [pargs]\n (let [[lv pred] pargs] \n (if (pred expr)\n (== lv expr)\n fail))))\n\n(defn extract-cons [pargs expr]\n (project [pargs]\n (let [[p ps] pargs]\n (conso p ps expr))))\n\n\n(defmethod extractor 'is? [_] extract-is)\n\n(defmethod extractor 'cons? [_] extract-cons)\n\n(defmethod extractor :default [_] (fn [a b] fail))\n\n(defn replace-symbolso\n \"replaces the symbols in old wich were replaced during the last match with\n the replacements - method will change\"\n [old new]\n (project [old]\n (let [res (if (empty? @replacements)\n old\n (walk/prewalk-replace @replacements old))\n res (utils/splice-in-seq-matchers res)]\n (do (reset! replacements {})\n (== res new)))))\n\n(defn add-replacemento\n \"adds a replacement from ps to es to the replacements - will change\"\n [es ps]\n (project [es ps]\n (if (= es ps)\n succeed\n (do (swap! replacements assoc ps es)\n succeed))))\n\n;;The top level matching relation.\n;;First tries to unify pat and exp ad succeeding fast in that case\n;;if not either one has to succeed:\n;;1. exp is a real expression than also pat has to be an expression\n;;2. pat is a real expression (mostly in case for extractors)\n;;if not, pat and exp are just matched like with normal unification\n;;but the parts of them are matched with a call to match itself.\n;;this enables semantic matching of expressions inside of a vector for example\n\n(defn match-expressiono\n \"matches pattern against exp. Dispatches to the right matching function.\n Tries simple unification first to save overhead in the simple case\"\n [pat exp]\n (conde\n ((== pat exp))\n ((conda\n ((is-expro exp) (is-expro pat)\n (project [pat exp]\n (match pat exp)))\n ((is-expro pat)\n (project [pat exp]\n (match pat exp)))\n ((expression-matcho pat exp))) (!= pat exp))))\n" }, { "path": "src/main/clojure/numeric/expresso/impl/pimplementation.clj", "content": " (ns numeric.expresso.impl.pimplementation\n (:refer-clojure :exclude [== record?])\n (:use [clojure.test]\n [clojure.core.logic.protocols]\n [numeric.expresso.protocols]\n [clojure.core.logic :exclude [is]])\n (:require \n [clojure.set :as set]\n [numeric.expresso.types :as types]\n [clojure.core.matrix :as mat]\n [clojure.walk :as walk]))\n\n;;Constraint checking code\n;;The constraints added to expressions encode constraints mainly on lvars in meta\n;;data. Because metadata is normally not touched by core.logic it has to be\n;;brought in scope and then all constraints are run.\n\n\n(defn all*\n \"function version of all macro in logic.clj\n Like fresh but does does not create logic variables.\"\n ([] clojure.core.logic/s#)\n ([goals] (fn [a] (reduce (fn [l r] (bind l r)) a goals))))\n\n\n(defn to-relations\n \"Maps the constraint in the form [rel args*] to the real clojure relation\"\n [constraint]\n (let [[rel & args] constraint]\n (apply rel args)))\n\n;;core.logic lvars can be in the type and shape metadata. To make it visible\n;;transform the expression to {:type (type-of expresion)\n;; :shape (shape expression) :value expression\n(defn with-meta-informations [value]\n (let [type (type-of value)\n shape (shape value)\n value (if-let [op (expr-op value)]\n (with-meta\n (list* op\n (map with-meta-informations (expr-args value)))\n (meta value))\n (if (sequential? value)\n (with-meta (mapv with-meta-informations value)\n (meta value))\n value))]\n {:type type :shape shape :value value}))\n\n;;After the query is run against the transformed expression, it has to be\n;;retransformed afterwards back to its original shape \n(defn restore-expression [wmi]\n (let [type (:type wmi)\n shape (:shape wmi)\n value (:value wmi)\n value (if-let [op (expr-op value)]\n (with-meta\n (list* op (map restore-expression (expr-args value)))\n (meta value))\n (if (sequential? value)\n (with-meta (mapv restore-expression value) (meta value))\n value))]\n (-> value (set-shape shape))))\n\n;;Now comes the constrait checking part.\n;;1. make the constraints to relations\n;;2. transform-the expression\n;; 3. run the query - the :reify-vars kv takes care that fresh lvars\n;; stay fresh after the run block\n;; 4. If the result is not unambiguous the transfomred expression is\n;; retransformed\n;; 5. If the constraint check failed throw exception\n\n(defn check-constraints\n \"checks the constraints on value.\n throws exception if they don't hold\"\n [value]\n (let [cs (map to-relations (constraints value))\n res (-run {:occurs-check true :n 2 :reify-vars (fn [v s] s)} [q]\n (fresh []\n (all* cs)\n (== q (with-meta-informations value))))]\n (if (not= res '())\n (if (= 1 (count res))\n (restore-expression (first res))\n value)\n (throw (Exception. \"constraint check failed\")))))\n\n\n;;The Expression deftype could be a replacement for normal clojure lists as\n;;expression datatype. It demonstrates how a custom datatype can play nicely\n;;with clojures abstractions and also with core.logic\n;;many protocol implemetation will have the same code for ISeq and Expression\n;;implements sequential, counted and ISeq mimicking the list (op args*)\n;;in the ISeq implementation. Seqable returns itself because it iimplements\n;;ISeq itself. Implementating clojures abstractions for custom expresso types\n;;could be made simpler by a bit macro magic in the future\n\n(deftype Expression [op args]\n clojure.lang.Sequential\n clojure.lang.Counted\n (count [this] (+ 1 (count args)))\n clojure.lang.ISeq\n (next [this] (next (list* op (map value args))))\n (first [this] op)\n (more [this] (.more (list* op (map value args))))\n (cons [this obj] (cons obj (list* op args)))\n (equiv [this that] (= (list* op (map value args)) that))\n (empty [this] false)\n clojure.lang.Seqable\n (seq [this] this);(seq (list* op (map value args))))\n java.lang.Object\n (hashCode [a]\n (.hashCode args))\n (toString [expr]\n (str (list* op args)))\n (equals [this that]\n (and (= op (expr-op that))\n (= args (expr-args that))))\n PExpression\n (expr-op [this] op)\n (expr-args [this] args)\n PProps\n ;;stub properties in metadata of operator is not the best idea\n (properties [this] (when-let [m (meta op)] (:properties m))))\n\n\n;;PolynomialExpression\n;;A polynomialExpression is represented as the main-variable v and the\n;;coeff clojure vector. x is the represented as\n;;PolynomialExpression 'x [0 1]\n;;Multivariate polynomial are represented in a recursive way according to a\n;;order on the variables. See polynomial.clj for details\n\n(deftype PolynomialExpression [v coeffs]\n Object\n (equals [this other]\n (and (instance? PolynomialExpression other)\n (= v (.-v ^PolynomialExpression other))\n (= coeffs (.-coeffs ^PolynomialExpression other))))\n (toString [this]\n (str v coeffs))\n clojure.lang.Seqable\n (seq [this] this)\n clojure.lang.Sequential\n clojure.lang.ISeq\n (next [this] (next (to-sexp this)))\n (first [this] (first (to-sexp this)))\n (more [this] (.more (to-sexp this)))\n (cons [this obj] (cons obj (to-sexp this)))\n (equiv [this that] (or (.equals this that)\n (= (to-sexp this) that)))\n (empty [this] false)\n PExpression\n (expr-op [this] `+)\n (expr-args [this] (vec (rest (to-sexp this))))\n PExprEvaluate\n ;;faster evaluate than evaluating the to-sexp representation\n (evaluate [poly sm]\n (if-let [vval (v sm)]\n (let [c (count coeffs)]\n (loop [^double res (first coeffs) i 1]\n (if (= i c) res\n (let [nres (+ res (* (nth coeffs i)\n (Math/pow vval i)))]\n (recur nres (inc i)))))))))\n\n(defn make-poly [v coeff]\n (PolynomialExpression. v coeff))\n\n;;BasicExtractor\n;;Extractors are used in the rule based translator\n;;They have their own implementation of match which lets them\n;;bring their own matching semantics\n;;for example (is? some-predicate ?x) can mean match the expression\n;;if the predicate is true on it and unify it with ?x then\n\n(deftype BasicExtractor [name args rel]\n java.lang.Object\n (toString [this] (str (list* name args)))\n PExpression\n (expr-op [this] name)\n (expr-args [this] args))\n\n;;LetExpression\n;;A custom type for a let expression. Is used for the optimizer to remove\n;;common subexpresions from the expression tree. Mimicks the normal clojure\n;;let expression in its ISeq implementation.\n(deftype LetExpression [bindings code]\n java.lang.Object\n (toString [this] (str `(let ~bindings ~@code)))\n PExpression\n (expr-op [this] 'let)\n (expr-args [this] code)\n clojure.lang.Sequential\n clojure.lang.Counted\n (count [this] (+ 1 (count code)))\n clojure.lang.ISeq\n (next [this] (next `(let ~bindings ~@code)))\n (first [this] 'let)\n (more [this] (.more `(let ~bindings ~@code)))\n (cons [this obj] (cons obj `(let ~bindings ~@code)))\n (equiv [this that] (= `(let ~bindings ~@code) that))\n (empty [this] false)\n clojure.lang.Seqable\n (seq [this] this)\n PExprEvaluate\n ;;evaluate the first binding and merge the kv pair info the sm and then\n ;;evaluate the next. evaluate the body afterwards\n (evaluate [this sm]\n (let [nsm (->> bindings (partition 2)\n (map (fn [[a b]] [a (evaluate b sm)])) (into {}))\n nnsm (merge sm nsm)]\n (last (map #(evaluate % nnsm) code)))))\n\n;;The implementations for PValue. Mostly identity for know only matrix symbols\n;;with mzero and midentity property evaluate to a real value at the moment.\n\n(extend-protocol PValue\n nil\n (value [this] nil)\n clojure.lang.Symbol\n (value [this]\n (let [props (properties this)]\n (if (or (contains? props :midentity) (contains? props :mzero))\n (let [shape (shape this)]\n (if (not (or (lvar? shape) (expr-op shape)))\n (cond\n (props :midentity) (if (= [] shape) 1 (mat/identity-matrix\n (first shape)))\n (props :mzero) (mat/new-array shape))\n this))\n this)))\n java.lang.Object\n (value [this] this))\n\n;;The implementations for PExpressions. Defaults to saying 'I'm a constant by\n;;returning nil for expr-op. ISeq checks if it is a real expresso expression\n;;by checking the mandatory part of the metadata added to the first symbol\n;;which is :expression true\n(extend-protocol PExpression\n nil\n (expr-op [obj] nil)\n java.lang.Object\n (expr-op [obj] nil)\n clojure.lang.ISeq\n (expr-op [obj]\n (let [f (first obj)]\n (cond\n (and f (symbol? f) (contains? (meta f) :expression)) f\n (and f (lvar? f)) f\n :else nil)))\n (expr-args [obj] (vec (rest obj))))\n\n;;implementations for to-sexp for polynomial and default.\n;;The polynomial implementation does some simplifications on the s-expressions\n;;so that only the nonzero coefficients are shown in the sexp and also not\n;;(** x 0) and (** x 1)\n(extend-protocol PExprToSexp\n PolynomialExpression\n (to-sexp [poly]\n (let [v (.-v poly) coeffs (.-coeffs poly)\n r (->> (map #(let [s (to-sexp %1)\n exp (if (clojure.core/== 0 %2)\n v\n (list '** v (inc %2)))]\n (if (not (and (number? s) (clojure.core/== 0 s)))\n (if (and (number? s) (clojure.core/== 1 s))\n exp\n (list '* s exp))))\n (rest coeffs) (range))\n (filter identity))]\n (if (and (number? (nth coeffs 0)) (clojure.core/== (nth coeffs 0) 0))\n (list* '+ r)\n (list* '+ (to-sexp (nth coeffs 0)) r))))\n java.lang.Object\n (to-sexp [expr]\n (if-let [op (expr-op expr)]\n (list* op (map to-sexp (expr-args expr)))\n (value expr))))\n\n;;The execution function used when evaluating is currently stortd as :exec-func\n;;in the metadata of the operator. If not it is tried to sesolve it\n(extend-protocol PExprExecFunc\n java.lang.Object\n (exec-func [expr]\n (if-let [op (expr-op expr)]\n (or (and (meta op) (:exec-func (meta op))) (resolve op))\n (throw (Exception. (str \"no excecution function found for \" expr))))))\n\n;;The default implementation for Evaluate differentiates between constants and\n;;expressions. from expressions, the eval-func is obtained and invoked on the\n;;evaluation of all its arguments.\n;;If it is a constant, its value is obtained and returned it if is not a\n;;symbol or lvar\n(extend-protocol PExprEvaluate\n nil\n (evaluate [expr sm] nil)\n java.lang.Object\n (evaluate [expr sm]\n (if-let [op (expr-op (value expr))]\n (if-let [eval-func (:eval-func (meta op))]\n (eval-func expr sm)\n (apply (exec-func expr) (map #(evaluate (value %) sm) (expr-args expr))))\n (let [val (value expr)]\n (if (or (symbol? val) (lvar? val))\n (if-let [evaled (val sm)]\n evaled\n (throw (Exception. (str \"No value specified for symbol \" val))))\n val)))))\n\n;;PVars implementation\n;;the symbol in the operator position is ignored for vars. Vars also checks\n;;the 'Value' of the expression if it is a symbol so that m-zero matrizes\n;;with determined shapes are not mistaken as variables\n\n(extend-protocol PVars\n PolynomialExpression\n (vars [expr] (apply set/union\n (concat [#{(.-v expr)}] (map vars (.-coeffs expr)))))\n nil\n (vars [expr] #{})\n java.lang.Object\n (vars [expr]\n (if-let [op (and (seq? expr) (first expr))]\n (apply set/union (map vars (rest expr)))\n (if (or (symbol? (value expr)) (lvar? (value expr)))\n #{(value expr)}\n #{}))))\n\n\n;;the core.logic extension to the custom datatypes\n;;s is the substitution map. basically unify the expr-op and the expr-args\n;;unsing the protocol function also enables matching Expression type and ISeq\n;;representation. Unification is also done on the logical value.\n;;the switch between u and v in the last line *is* neccesary, because\n;;core.logic can end up in a stackoverflow if not.\n\n(defn unify-with-expression* [u v s]\n (let [uop (expr-op u) vop (expr-op v)]\n (if uop\n (if vop\n (if-let [s (unify s uop vop)]\n (unify s (expr-args u) (expr-args v)))\n (unify s (value v) u))\n (unify s (value u) (value v)))))\n\n\n(extend-protocol IUnifyTerms\n Expression\n (unify-terms [u v s]\n (unify-with-expression* u v s)))\n\n;;An advantage one has with a custom datatype is having full control about\n;;core.logic behaviour, so the walkTerm expression can splice in the sequential\n;;matchers while walking the term. See rules.clj and matcher.clj\n;;for more about seq-matchers\n\n(defn expand-seq-matchers[args]\n (vec (mapcat #(if (and (sequential? %)\n (= (first %) :numeric.expresso.construct/seq-match))\n (vec (second %))\n [%]) args)))\n\n(defn walk-expresso-expression* [^Expression v f]\n (Expression. (walk-term (f (.-op v)) f)\n (expand-seq-matchers (mapv #(walk-term (f %) f) (.-args v)))))\n\n\n(extend-protocol IWalkTerm\n Expression\n (walk-term [v f]\n (walk-expresso-expression* v f)))\n\n;;substituting an expression is just a postwalk-replace in case of ISeq\n;;and a custom replacement in case of Expression\n\n(defn substitute-expr* [expr repl]\n (if-let [sub (get repl expr)]\n sub\n (if-let [op (expr-op expr)]\n (Expression. (get repl op op)\n (mapv #(substitute-expr* % repl) (expr-args expr)))\n (get repl (value expr) expr))))\n\n(extend-protocol PSubstitute\n clojure.lang.Symbol\n (substitute-expr [this repl]\n (repl this this))\n clojure.lang.ISeq\n (substitute-expr [this repl]\n (let [res (walk/postwalk-replace repl this)]\n res))\n Expression\n (substitute-expr [this repl]\n (substitute-expr* this repl)))\n\n(defn check-type [this type to-check]\n (if (= type to-check) this\n (throw (Exception. (str \"Invalid Type \" type \"for \"\n this \"excpected \" to-check)))))\n\n;;poc implementation of type protocol.\n\n(extend-protocol PType\n Integer\n (type-of [this] :numeric.expresso.types/integer)\n (set-type [this type] (check-type this type :numeric.expresso.types/integer))\n Long\n (type-of [this] :numeric.expresso.types/long)\n (set-type [this type] (check-type this type :numeric.expresso.types/long))\n Double\n (type-of [this] :numeric.expresso.types/double)\n (set-type [this type] (check-type this type :numeric.expresso.types/double))\n java.lang.Number\n (type-of [this] :numeric.expresso.types/number)\n (set-type [this type] (check-type this type :numeric.expresso.types/number))\n Object\n (type-of [this]\n (if-let [type (and (meta this) (:type (meta this)))]\n type\n (if (mat/array? this)\n :numeric.expresso.types/matrix\n :Unknown)))\n (set-type [this type]\n (cond\n (mat/array? this) (check-type this type :numeric.expresso.types/matrix)\n (lvar? (:type (meta this)))\n (add-constraint\n (with-meta this (assoc (meta this) :type type :shape\n (if (= type :numeric.expresso.types/matrix)\n [(lvar 'lshape) (lvar 'rshape)] [])))\n [== (:type (meta this)) type])\n :else (if (isa? (:type (meta this)) type)\n this\n (throw (Exception. (str \"invalid type \" type \" for \"\n (:type (meta this)) \" of \" this)))))))\n\n\n(defn all-execable [x]\n (if-let [op (expr-op x)]\n (and (or (exec-func x) (:eval-func (meta op)))\n (every? all-execable (expr-args x)))\n true))\n\n(defn no-symbol [x]\n (and (empty? (vars x))\n (all-execable x)))\n\n(defn eval-if-determined [expr]\n (if (expr-op expr)\n (if (no-symbol expr)\n (evaluate expr {})\n expr)\n expr))\n\n;;The implementation for shape first checks for an inferred shape.\n;;If not, it checks if its shape is an expression and evals it if it can\n;;be evaluated. otherwise it returns the expression\n(extend-protocol PShape\n nil\n (shape [this] [])\n (set-shape [this shape]\n (if (= [] shape) this (throw (Exception.\n (str \"invalid shape \" shape \"for nil\")))))\n java.lang.Number\n (shape [this] [])\n (set-shape [this shape]\n (if (= [] shape) this (throw (Exception.\n (str \"invalid shape \" shape \"for a number\")))))\n clojure.lang.ISeq\n (shape [this]\n (or (inferred-shape this)\n (eval-if-determined (:shape (meta this)))))\n (set-shape [this shape]\n (with-meta this (assoc (meta this) :shape shape)))\n java.lang.Object\n (shape [this]\n (or (inferred-shape this)\n (eval-if-determined (get (meta this) :shape\n (mat/shape this)))))\n (set-shape [this shape]\n (with-meta this (assoc (meta this) :shape shape))))\n \n(extend-protocol PInferShape\n nil\n (inferred-shape [this] (shape this))\n java.lang.Number\n (inferred-shape [this] (shape this))\n (set-inferred-shape [this shape] (set-shape this shape))\n java.lang.Object\n (inferred-shape [this] (eval-if-determined (get (meta this) :inferred-shape)))\n (set-inferred-shape [this shape]\n (with-meta this (assoc (meta this) :inferred-shape shape))))\n\n;;in the default case properites are in the properties key in the metadata\n;;for numbers the properties can be :positive, :zero, or :negative\n(extend-protocol PProps\n java.lang.Object\n (properties [this]\n (when-let [m (meta this)]\n (:properties m)))\n java.lang.Number\n (properties [this]\n (cond\n (> this 0) #{:positive}\n (= this 0) #{:zero}\n :else #{:negative})))\n\n(defn add-metadata [s m]\n (with-meta s (merge (meta s) m)))\n\n;;the constraint is added to the constraints meta key\n(defn add-constraint-normal [value constraint]\n (let [res (if-let [c (:constraints (meta value))]\n (add-metadata value {:constraints (set/union c #{constraint})})\n (add-metadata value {:constraints #{constraint}}))]\n res))\n\n;;Constraints are currently not supported on BasicExtractors and\n;;PolynomialExpressions\n(extend-protocol PConstraints\n java.lang.Number\n (constraints [this] #{})\n (add-constraint [this constraint] this)\n java.lang.Object\n (constraints [this]\n (get (meta this) :constraints #{}))\n (add-constraint [this constraint]\n (add-constraint-normal this constraint))\n BasicExtractor\n (constraints [this] #{})\n (add-constraint [this constraint] this)\n PolynomialExpression\n (constraints [this] #{})\n (add-constraint [this constraint] this)\n ;;Constraints on expressions cascade upwards so they include all the\n ;;constraints of their arguments\n clojure.lang.ISeq\n (add-constraint [this constraint]\n (add-constraint-normal this constraint))\n (constraints [this]\n (let [cs (get (meta this) :constraints #{})]\n (if (not (empty? this))\n (apply (partial set/union cs) (map constraints this)))))\n Expression\n (add-constraint [this constraint]\n (Expression. (add-constraint-normal (expr-op this) constraint)\n (expr-args this)))\n (constraints [this]\n (let [cs (get (meta this) :constraints #{})]\n (apply (partial set/union (set/union cs (constraints (expr-op this))))\n (map constraints (expr-args this))))))\n\n\n;;Rearrange ad Differentiate dispatch to their appropriate dispatch multimethod\n;;in case of Expression and ISeq\n(extend-protocol PRearrange\n Expression\n (rearrange-step [lhs pos rhs]\n (let [op (expr-op lhs)]\n (rearrange-step-function [op (expr-args lhs) pos rhs])))\n clojure.lang.ISeq\n (rearrange-step [lhs pos rhs]\n (if-let [op (expr-op lhs)]\n (rearrange-step-function [op (vec (rest lhs)) pos rhs]))))\n\n(extend-protocol PDifferentiate\n Number\n (differentiate-expr [this v] 0)\n clojure.lang.Symbol\n (differentiate-expr [this v]\n (if (= v this) 1 0))\n clojure.lang.ISeq\n (differentiate-expr [this v]\n (if-let [op (expr-op this)]\n (diff-function [this v]))))\n\n;;the normal emit-code implementation emits just the (exec-func ops*) clojure\n;;list. the let expression similary emits its normal clojure code\n(extend-protocol PEmitCode\n java.lang.Object\n (emit-code [this]\n (if-let [op (expr-op this)]\n (if-let [ef (emit-func this)]\n (ef this)\n (list* (exec-func this) (map emit-code (expr-args this))))\n this))\n LetExpression\n (emit-code [this]\n `(let ~(.-bindings this) ~@(map emit-code (.-code this)))))\n\n;;quick fix to be able to handle seqs as values in core.logic\n;;without this sets make core.logic go into an infinite loop.\n(extend-protocol IWalkTerm \n clojure.lang.IPersistentSet \n (walk-term [v f] (with-meta (set (walk-term (seq v) f)) (meta v))))\n\n\n\n;;TODO protocol evaluable\n" }, { "path": "src/main/clojure/numeric/expresso/impl/polynomial.clj", "content": "(ns numeric.expresso.impl.polynomial\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic.protocols]\n [clojure.core.logic :exclude [is] :as l]\n [numeric.expresso.properties]\n [numeric.expresso.construct]\n [clojure.test])\n (:require [clojure.core.logic.fd :as fd :exclude [record?]]\n [clojure.walk :as walk]\n [clojure.set :as set]\n [numeric.expresso.protocols :as protocols]\n [numeric.expresso.impl.pimplementation :as impl]\n [clojure.core.logic.unifier :as u :exclude [record?]]\n [numeric.expresso.types :as types]\n [clojure.core.matrix :as mat]\n [clojure.core.matrix.operators :as mop]\n [numeric.expresso.utils :as utils])\n (:import [numeric.expresso.impl.pimplementation PolynomialExpression]))\n\n(declare coef main-var poly poly+poly)\n;;polynomial canonical form code inspired by PAIP chapter 15. but extended and immutable\n\n(defn main-var [^PolynomialExpression poly]\n (if (number? poly) nil\n (.-v poly)))\n\n(defn coef [^PolynomialExpression poly ^long i]\n (if (number? poly) 0\n (nth (.-coeffs poly) i)))\n\n(defn degree [^PolynomialExpression poly]\n (if (number? poly) 0\n (- (count (.-coeffs poly)) 1)))\n\n(defn poly [x & coeffs]\n (impl/make-poly x (into [] coeffs)))\n\n(defn new-poly [x degree]\n (loop [i 0 coeffs (transient [])]\n (if (<= i degree)\n (recur (+ i 1) (conj! coeffs 0))\n (impl/make-poly x (persistent! coeffs)))))\n\n(defn set-main-var [^PolynomialExpression poly v]\n (impl/make-poly v (.-coeffs poly)))\n\n(defn set-coef [^PolynomialExpression poly i val]\n (impl/make-poly (.-v poly) (assoc (.-coeffs poly) i val)))\n\n;;these functions define the order of variables which in turns define the\n;;normal form of the recursive implementation. (bigger variables become the\n;;coefficients)\n;;dynamic rebindable to let the (power) user specify the exact form of the\n;;polynomial\n(defn ^:dynamic var= [x y] (= x y))\n(defn ^:dynamic var> [x y] (< 0 (compare x y)))\n\n(declare poly+poly normalize-poly poly*poly)\n\n(defn p== [x y]\n (if (and (number? x) (number? y))\n (clojure.core/== x y)\n (= x y)))\n\n(defn poly**n [p n]\n (if (integer? n)\n (cond\n (p== n 0) (do (assert (not (= p 0))) 1)\n (integer? p) (Math/pow p n)\n :else (poly*poly p (poly**n p (- ^long n 1))))\n :error))\n \n\n(defn normalize-poly [p]\n (if (number? p) p\n (let [coeffs (.-coeffs ^PolynomialExpression p)\n pdeg (loop [i (degree p)]\n (if (or (>= 0 i) (not (p== (nth coeffs i) 0)))\n i (recur (dec i))))]\n (cond (<= pdeg 0) (normalize-poly (coef p 0))\n (< pdeg (degree p))\n (impl/make-poly (.-v ^PolynomialExpression p)\n (subvec (.-coeffs ^PolynomialExpression p)\n 0 (inc pdeg)))\n :else p))))\n\n(defn poly*same [p q]\n (let [r-degree (+ (degree p) (degree q))\n r (new-poly (main-var p) r-degree)\n q-degree (degree q) p-degree (degree p)]\n (loop [i 0 r r]\n (if (<= i p-degree)\n (if (not (clojure.core/= (coef p i) 0))\n (recur (inc i)\n (loop [j 0 r r]\n (if (<= j q-degree)\n (recur\n (inc j) (set-coef r (+ i j)\n (poly+poly (coef r (+ i j))\n (poly*poly (coef p i)\n (coef q j)))))\n r)))\n (recur (inc i) r))\n r))))\n\n(defn polydk [^PolynomialExpression p k]\n (cond\n (p== k 0) :error\n (and (number? k) (number? p)) (/ p k)\n (number? k)\n (let [nc (mapv #(polydk % k) (.-coeffs p))]\n (if (some #{:error} nc)\n :error\n (impl/make-poly (main-var p) nc)))\n :else :error))\n\n(defn k*poly [k ^PolynomialExpression p]\n (cond\n (p== k 0) 0 (p== k 1) p\n (and (number? k) (number? p)) (* k p)\n :else\n (impl/make-poly (main-var p) (mapv #(poly*poly k %) (.-coeffs p)))))\n\n\n(defn poly*poly [p q]\n (normalize-poly\n (cond\n (number? p) (k*poly p q)\n (number? q) (k*poly q p)\n (some #{:error} [p q]) :error\n (var= (main-var p) (main-var q)) (poly*same p q)\n (var> (main-var q) (main-var p)) (k*poly q p)\n :else (k*poly p q))))\n\n(defn poly+same [p q]\n (if (> (degree p) (degree q))\n (poly+same q p)\n (let [d (degree p)]\n (loop [i 0 res q]\n (if (<= i d)\n (recur (inc i) (set-coef res i (poly+poly (coef res i) (coef p i))))\n res)))))\n\n(defn k+poly [k p]\n (cond (= k 0) p\n (and (number? k) (number? p)) (+ k p)\n :else (set-coef p 0 (poly+poly (coef p 0) k))))\n\n(defn poly+poly [p q]\n (normalize-poly\n (cond\n (number? p) (k+poly p q)\n (number? q) (k+poly q p)\n (var= (main-var p) (main-var q)) (poly+same p q)\n (var> (main-var q) (main-var p)) (k+poly q p)\n :else (k+poly p q))))\n\n(declare poly+poly poly*poly)\n\n(defn poly+ [& args]\n (reduce poly+poly args))\n\n(defn poly- [& args]\n (if (= (count args) 1)\n (poly*poly -1 (first args))\n (apply\n (partial poly+ (first args)) (map #(poly*poly -1 %) (rest args)))))\n\n(defn poly*polyc [& args]\n (reduce poly*poly args))\n\n(defn polydkc [& args]\n (reduce polydk args))\n\n(defn poly**nc [& args]\n (if (or (> (count args) 2)\n (not (number? (second args))))\n :error\n (poly**n (first args) (second args))))\n\n(defmulti construct-poly identity)\n(defmethod construct-poly :default [_] (fn [& a] :error))\n(defmethod construct-poly '+ [_] poly+)\n(defmethod construct-poly `+ [_] poly+)\n(defmethod construct-poly '- [_] poly-)\n(defmethod construct-poly `- [_] poly-)\n(defmethod construct-poly `/ [_] polydkc)\n(defmethod construct-poly '/ [_] polydkc)\n(defmethod construct-poly '* [_] poly*polyc)\n(defmethod construct-poly `* [_] poly*polyc)\n(defmethod construct-poly '** [_] poly**nc)\n\n\n(defn to-poly-normal-form*\n ([expr]\n (let [res (if (and (seq? expr) (symbol? (first expr)))\n (let [args (map to-poly-normal-form* (rest expr))]\n (if (some #{:error} args)\n :error\n (apply (construct-poly (first expr)) args)))\n (if (symbol? expr) (poly expr 0 1)\n (if (number? expr) expr :error)))]\n res))\n ([expr v>]\n (binding [var> v>]\n (to-poly-normal-form* expr))))\n\n\n(defn to-poly-normal-form\n ([expr] (when-let [res (to-poly-normal-form* expr)]\n (when (not= res :error) res)))\n ([expr v>] (when-let [res (to-poly-normal-form* expr v>)]\n (when (not= res :error) res))))\n\n\n(defn poly-in [x poly]\n (when poly\n (to-poly-normal-form (protocols/to-sexp poly)\n (fn [v y] (if (= v x)\n false\n (if (= y x)\n true\n (< 0 (compare v y))))))))\n\n\n(defn pd [u v]\n (let [m (- (count u) 1) n (- (count v) 1)]\n (loop [k (- m n) u u q (mat/new-vector (+ (- m n) 1))]\n (if (>= k 0)\n (let [q (assoc q k (/ (nth u (+ n k)) (nth v n)))\n u (loop [u u j (+ n k )]\n (if (>= j k)\n (recur\n (let []\n (assoc u j (- (nth u j) (* (nth q k) (nth v (- j k))))))\n (dec j))\n u))]\n (recur (dec k) u q))\n [q (subvec u 0 n)]))))\n\n\n(defn poly-division [^PolynomialExpression u ^PolynomialExpression v]\n (and (= (main-var u) (main-var v))\n (let [[q r] (pd (.-coeffs u) (.-coeffs v))]\n [(normalize-poly (impl/make-poly (main-var u) q))\n (normalize-poly (impl/make-poly (main-var u) r))])))\n\n(defn factors [n] (map #(/ n %) (filter #(zero? (rem n %)) (range 1 (+ n 1)))))\n\n(defn ratio-root-guesses [^PolynomialExpression poly]\n (if (every? #(and (number? %) (or (integer? %) (utils/num= (utils/round %) %)))\n (.-coeffs poly))\n (apply concat (for [n (factors (Math/abs ^double (coef poly 0)))\n d (factors (Math/abs ^double (coef poly (degree poly))))]\n [(/ n d) (/ (- n) d)]))\n '()))\n\n(defn ratio-root [poly]\n (reduce (fn [factors guess]\n (let [p (first factors)\n div (to-poly-normal-form (ce '- (main-var poly) guess))\n [quot r] (poly-division p div)]\n (if (or (= r 0) (= r 0.0))\n (list* quot div (rest factors))\n factors))) (list poly) (ratio-root-guesses poly)))\n" }, { "path": "src/main/clojure/numeric/expresso/impl/symbolic.clj", "content": "(ns numeric.expresso.impl.symbolic\n (:refer-clojure :exclude [record?])\n (:use [clojure.core.logic.protocols]\n [numeric.expresso.impl.matcher]\n [numeric.expresso.protocols]\n clojure.test)\n (:require [clojure.core.logic.fd :as fd :exclude [record?]]\n [clojure.walk :as walk]\n [clojure.core.matrix.operators :as matop]\n [numeric.expresso.utils :as utils]\n [clojure.core.matrix :as mat]\n [numeric.expresso.construct :as c]))\n\n(def plus (partial mat/emap (partial c/ce `+)))\n(defn emul [m s]\n (mat/emap (partial c/ce `* s) m))\n(def scale emul)\n\n(defn vector-dot [a b]\n (reduce (partial c/ce `+) (map (partial c/ce `*) a b)))\n(defn mul [m a]\n (let [mdims (long (mat/dimensionality m))\n adims (long (mat/dimensionality a))]\n (cond\n (== adims 0) (scale m a)\n (and (== mdims 1) (== adims 2))\n (vec (for [i (range (mat/dimension-count a 1))]\n (let [r (mat/get-column a i)]\n (vector-dot m r))))\n (and (== mdims 2) (== adims 2))\n (mapv (fn [r]\n (vec (for [j (range (mat/dimension-count a 1))]\n (vector-dot r (mat/get-column a j))))) m))))\n\n(def testmatrix [[3 4 -2 1 -2]\n [1 -1 2 2 7]\n [4 -3 4 -3 2]\n [-1 1 6 -1 1]])\n\n(defn swap-rows [mat i j]\n (if (== i j) mat\n (let [n (mat/row-count mat)]\n (loop [index 0 nrows (transient [])]\n (if (< index n)\n (recur (inc index) (conj! nrows\n (cond\n (== index i) (mat/get-row mat j)\n (== index j) (mat/get-row mat i)\n :else (mat/get-row mat index))))\n (mat/matrix (persistent! nrows)))))))\n \n (defn multiply-row [row m] (mat/emap #(* %1 m) row))\n(defn add-rows [row1 row2] (mat/emap + row1 row2))\n\n(defn set-row [mat pos row]\n (let [n (mat/row-count mat)]\n (loop [index 0 nrows (transient [])]\n (if (< index n)\n (recur (inc index) (conj! nrows\n (if (== index pos)\n row\n (mat/get-row mat index))))\n (mat/matrix (persistent! nrows))))))\n\n\n(defn ffgaus-step [mat prowpos pcolpos div]\n (let [prow (mat/get-row mat prowpos)\n pivot (mat/mget mat prowpos pcolpos)\n n (mat/row-count mat)]\n (loop [index (inc prowpos) mat mat]\n (if (< index n)\n (let [ aktrow (mat/get-row mat index)\n aktpivot (mat/mget mat index pcolpos)\n nrow (multiply-row (add-rows (multiply-row aktrow pivot)\n (multiply-row prow (* -1 aktpivot)))\n (/ 1 div))]\n (recur (inc index) (set-row mat index nrow)))\n mat))))\n \n \n\n(defn ff-gauss-echelon [mat]\n (let [n (mat/row-count mat) m (mat/column-count mat)]\n (loop [index 0 indexcol 0 mat mat div 1]\n (if (and (< (inc index) n) (< indexcol m))\n (let [pivot (mat/mget mat index indexcol)\n swap (loop [k index pivot pivot]\n (cond (== (inc k) n) false\n (== 0 pivot) (recur (inc k)\n (mat/mget mat (inc k) indexcol))\n :else k))]\n (if swap \n (recur (inc index) (inc indexcol)\n (let [res (ffgaus-step (swap-rows mat index swap)\n index indexcol div)]\n res)\n (let [ndiv (mat/mget mat index indexcol)]\n (if (== 0 ndiv) div ndiv)))\n (recur index (inc indexcol) mat div)))\n mat))))\n\n(defn find-elim-pivot [mat index]\n (let [m (dec (mat/column-count mat))]\n (loop [row index col 0]\n (if (== (mat/mget mat row col) 0)\n (if (== col m)\n (if (== 0 row)\n [0 0]\n (recur (dec row) 0))\n (recur row (inc col)))\n [row col]))))\n \n(defn ff-gauss-reduced-echelon [[mat index]]\n ;;search pivot element for resub\n (let [n (mat/row-count mat) m (mat/column-count mat)\n [prowi pcoli] (find-elim-pivot mat index)]\n [prowi pcoli]))\n\n\n\n(defn check-zero-or-inf-sols [mat]\n ;;if there is one butzero line no solution\n (let [cc (mat/column-count mat)\n rows (mat/rows mat)\n but-zero-lines\n (some #{true} (map (fn [e] (and (every? #(== 0 %) (butlast e))\n (not (== 0 (last e))))) rows))\n zero-lines (filter #{true} (map (fn [e] (every? #(== 0 %) e)) rows))\n det-row-count (- (mat/row-count mat) (count zero-lines))]\n (if but-zero-lines :zero\n (if (== cc (inc det-row-count)) :one\n (if (>= det-row-count cc) :zero :infinitive)))))\n\n\n(defn s+ [a b]\n (if (and (number? a) (number? b))\n (+ a b)\n (c/ce `+ a b)))\n\n(defn s- [a b]\n (if (and (number? a) (number? b))\n (- a b)\n (c/ce `- a b)))\n\n(defn s* [a b]\n (if (and (number? a) (number? b))\n (* a b)\n (c/ce `* a b)))\n\n(defn sd [a b]\n (if (and (number? a) (number? b))\n (/ a b)\n (c/ce `/ a b)))\n\n(defn pivot-index [row]\n (loop [i 0]\n (if (< i (mat/ecount row))\n (if (== (mat/mget row i) 0) (recur (inc i)) i))))\n\n(defn sort-rows [m]\n (let [rows (mat/rows m)]\n (mat/matrix\n (sort-by pivot-index rows))))\n\n(defn remove-zeros [m]\n (->> (mat/rows m) (remove #(every? (fn [x] (== x 0)) %)) mat/matrix))\n\n(defn add-zeros [m]\n (let [rows (vec (mat/rows m))\n cc (mat/column-count m)\n rc (mat/row-count m)]\n (loop [i 0 rows rows]\n (if (< i rc)\n (if-let [pi (pivot-index (nth rows i))]\n (if (> pi i)\n (recur (inc i) (vec (concat\n (subvec rows 0 i)\n (repeat (- pi i) (mat/new-vector cc))\n (subvec rows i))))\n (recur (inc i) rows))\n (recur (inc i) rows))\n (mat/matrix rows)))))\n\n\n(defn solution-vec [m]\n (let [cc (mat/column-count m)\n row (- cc 2) col (- cc 2)\n m (-> m remove-zeros sort-rows add-zeros)\n m (if (< 0 (- cc (mat/row-count m) 1))\n (mat/matrix (concat (mat/rows m)\n (repeat (- cc (mat/row-count m) 1)\n (mat/new-vector cc))))\n m)] \n (loop [row row numbv 0 solv []]\n (if (< row 0)\n solv\n (if (== 0 (mat/mget m row row))\n (recur (dec row) (inc numbv) (conj solv (symbol (str \"_\" numbv))))\n (recur (dec row) numbv\n (conj solv (sd (s- (mat/mget m row (dec cc))\n (loop [col (- cc 2) i 0 res 0]\n (if (<= col row) res\n (recur (dec col) (inc i)\n (s+ res (s* (mat/mget m row col)\n (nth solv i)))))))\n (mat/mget m row row)))))))))\n(defn report-solution [echelon-matrix]\n (let [zero-inf? (check-zero-or-inf-sols echelon-matrix)]\n (cond\n (= zero-inf? :zero) '()\n (= zero-inf? :infinite) '(_0)\n :else (into [] (reverse (solution-vec echelon-matrix))))))\n\n\n(defn gaus-solve [matrix]\n (report-solution (ff-gauss-echelon matrix)))\n\n" }, { "path": "src/main/clojure/numeric/expresso/optimize.clj", "content": "(ns numeric.expresso.optimize\n (:refer-clojure :exclude [== record?])\n (:use [numeric.expresso.construct]\n [clojure.core.logic]\n [numeric.expresso.properties :as props]\n [numeric.expresso.protocols]\n [numeric.expresso.rules])\n (:require [clojure.walk :as walk]\n [numeric.expresso.utils :as utils]\n [clojure.core.memoize :as memo]\n [numeric.expresso.impl.matcher :as m]\n [numeric.expresso.simplify :as simp]))\n\n;;This namespace provides the expresso optimizer. It strives to be very\n;;extensible by relying on rule based translation and being datadriven by\n;;a vector of optimizations which gets applied in sequence. The main function\n;;of this namespace is optimize.\n\n;;It also provides support to *compile* an expression to a (no overhead) clojure\n;;function. See the compile-expr macro and compile-expr* function for reference\n\n\n(declare remove-common-subexpressions)\n\n(defn- map-elems\n \"map the leaves of the expression. retains metadata unles postwalk\"\n [func expr]\n (if-let [op (expr-op expr)]\n (cev op (map (partial map-elems func) (expr-args expr)))\n (func expr)))\n\n(defn- zip\n \"zips the colls together\"\n [& colls]\n (apply (partial map (fn [& a] a)) colls))\n\n\n(defn- subexpressions\n \"returns all subexpressions of expr\"\n [expr]\n (filter expr-op (rest (tree-seq expr-op expr-args expr))))\n\n;;This core.logic relation finds all combinations of two subexpression in subexpressions\n;;which are the same. Note that for now the test is just the match-expressiono function\n;;In future this can be replaced by a more clever function which recognizes more\n;;expressions as being equivalent\n\n(defn- matching-subexpressions\n \"create all pairs of subexpressions in subs which match\"\n [subs]\n (run* [q]\n (fresh [a b rem]\n (rembero a subs rem)\n (membero b rem)\n (condu ((m/match-expressiono a b)))\n (== q [a b]))))\n\n(defn- match?\n \"checks if a and b match\"\n [a b]\n (not (empty? (run 1 [q] (m/match-expressiono a b)))))\n\n;;from all pairs of matching subexpressions the subexpressions which match must be concat-\n;;enated, so that we get a list of equivalent-classes which consists of the set of all\n;;forms occurring in the expression which are equivalent\n\n(defn- concat-aq\n \"concats equivalent subexpressions\"\n [msubs]\n (reduce (fn [[aq r] next]\n (let [a (first aq)\n b (second next)]\n (if (match? a b)\n [(apply (partial conj aq) next) r]\n [aq (conj r next)])))\n [(first msubs) []] (rest msubs)))\n\n(defn- equivalent-subexpressions\n \"creates a list of equivalent classes each containing mutually matching\n subexpressions\"\n [msubs]\n (loop [msubs msubs aquiv []]\n (if (seq msubs)\n (let [[aq r] (concat-aq msubs)\n same (into #{} aq)]\n (recur r (conj aquiv same)))\n aquiv)))\n\n(defn common-subexpressions\n \"returns a list of common-subexpressions in expr\"\n [expr]\n (->> expr\n subexpressions\n matching-subexpressions\n equivalent-subexpressions))\n\n;;to remove the common subexpressions, a let is created with a binding for each\n;;set of equivalent subexpressions each subexpression in the set is then substituted\n;;for the binding.\n(defn remove-common-subexpressions\n \"removes common subexpressions in expr by transforming it to a let\n with one binding pair for each equivalent class of subexpressions in expr\"\n [expr]\n (let [cs (common-subexpressions expr)\n locals (zip (repeatedly #(gensym 'local)) cs)\n expr (reduce (fn [expr [s repl]]\n (reduce #(substitute-expr %1 {%2 s}) expr repl))\n expr locals)]\n (if (empty? cs)\n expr\n (let-expr (vec (mapcat (fn [[l s]] [l (first s)]) locals))\n [(to-sexp expr)]))))\n\n(construct-with [* + / - ** sum]\n(def optimize-rules [(rule (* ?x ?x ?&*) :=> (* (** ?x 2) ?&*))\n (rule (+ ?x ?x ?&*) :=> (+ (* 2 ?x) ?&*)) \n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*))\n (rule (+ (* ?a ?&*1) (* ?a ?&*2) ?&*r)\n :=> (+ (* ?a (+ ?&*1 ?&*2)) ?&*r))\n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*))\n (rule (+ ?x (- ?x) ?&*) :=> (+ ?&*))\n (rule (+ (* ?x ?&*) (- ?x) ?&*2)\n :=> (+ (* ?x (- ?&* 1)) ?&*2))\n (rule (+ (* ?x ?&*) ?x ?&*2) :=> (+ (* ?x (+ ?&* 1)) ?&*2))\n (rule (- (- ?x)) :=> ?x)\n (rule (sum ?k ?i (* ?x ?&*)) :=> (* ?x (sum ?k ?i (* ?&*)))\n :if (guard (not= ?x ?k)))\n (rule (* (- ?x) ?&*) :=> (- (* ?x ?&*)))]))\n\n\n(defn optimize-by-rules\n \"optimizes the expression according to optimize-rules\"\n [expr]\n (->> expr\n (transform-expression (concat simp/universal-rules\n simp/eval-rules simp/to-inverses-rules\n optimize-rules))\n (transform-expression simp/cancel-inverses-rules)))\n \n(defn replace-with-special-operations\n \"replaces general (slow) operators with specialized (fast) ones in exp\"\n [expr]\n (transform-expression\n (concat simp/arity-rules\n [(rule (ex (** ?x 0.5)) :=> (ex (sqrt ?x)))\n (rule (ex (** ?x 1/2)) :=> (ex (sqrt ?x)))\n (rule (ex (+ ?m (* ?a ?b) ~?&*))\n :=> (ex (+ (add-product ?m ?a ?b) ~?&*))\n :if (guard (let [shapes (map shape [?m ?a ?b])]\n (and (not (some #{[]} shapes))\n (not (some lvar? shapes))\n (every? #{(shape ?m)} shapes)))))\n ]) expr))\n\n(defn- add-parens [symb args i j]\n (cev symb (concat (subvec args 0 i) [(cev symb (subvec args i j))]\n (subvec args j (count args)))))\n \n\n(def ^:private matrix-chain-cost*\n (memo/memo\n (fn [shapes i j]\n (if (= i j)\n [0 [(dec i)]]\n (loop [k (long i) minimum Long/MAX_VALUE expr []]\n (if (< k j)\n (let [[costl parensl] (matrix-chain-cost* shapes i k)\n [costr parensr] (matrix-chain-cost* shapes (inc k) j)\n cost (+ costl costr\n (* (nth shapes (dec i))\n (nth shapes k)\n (nth shapes j)))]\n (recur (inc k) (if (< minimum cost) minimum cost)\n (if (< minimum cost) expr (cev 'inner-product\n (concat parensl parensr)))))\n [minimum [expr]]))))))\n\n(defn- matrix-chain-cost [shapes i j]\n (let [res (matrix-chain-cost* shapes i j)]\n (memo/memo-clear! matrix-chain-cost*)\n res))\n\n\n(defn- optimize-matrix-chain-order [args]\n (let [shapes (vec (concat (shape (first args))\n (map (comp second shape) (rest args))))]\n (-> (first (second (matrix-chain-cost shapes 1 (dec (count shapes)))))\n (substitute-expr args))))\n\n(def matrix-chain-rules\n [(rule (ex (inner-product ?x)) :=> ?x)\n (rule (ex (inner-product ?&+)) :==>\n (when (> (count-sm ?&+) 2)\n (let [args (matcher-args ?&+)\n args (partition-by (comp count shape) args)\n args (map #(if (and (not (expr-op (shape (first %))))\n (= (count (shape (first %))) 2))\n (optimize-matrix-chain-order (vec %))\n (seq-matcher %)) args)]\n (cev 'inner-product args)))\n :if (guard (> (count-sm ?&+) 2)))])\n \n(defn optimize-matrix-chain\n \"optimizes the order of matrix multiplications in a chain of inner products of\n matrices\"\n [expr]\n (transform-expression matrix-chain-rules expr))\n\n;;compiling the expression works vial the emit-code protocol function defined\n;;in protocols.clj. Because standart expressions are just ISeq they can be\n;;evaluated almost as they are the only difficulty is that their operators\n;;may not be in scope. Because of this in the normal case the generated code\n;;is (exec-func args*). the emitted code will be the body of the function\n;;with the bindings vector as argument list. the function is then constructed\n;;with a call to eval. This also allows to use compile-expr* like compile-expr\n;;with quoting of the bindings vector, and you can use it in higher order\n;;functions\n\n\n(defn compile-expr*\n \"compiles the expression to a function with the binding symbol vector as\n argument list. Function version of compile-expr\"\n [bindings expr]\n (let [expr (to-expression expr)\n code (emit-code expr)\n c (list `fn bindings code)]\n (eval c)))\n\n(defmacro compile-expr\n \"compiles the expression to a function with the binding symbol vector as\n argument list.\"\n [bindings expr]\n `(compile-expr* ~(list 'quote bindings) ~expr))\n\n;;This is a *very* simple optimizations which just uses the eval-rules from\n;;the simplification namespace. calculates all expressions which are determined\n;;and even folds constants in associative or commutative operators. See\n;;simplify.clj for more\n\n(defn constant-folding\n \"folds constants and constant (sub-) expressions in expr\"\n [expr]\n (transform-expression simp/eval-rules expr))\n\n\n(def optimizations\n [constant-folding\n remove-common-subexpressions\n optimize-by-rules\n optimize-matrix-chain\n replace-with-special-operations])\n\n;;optimize takes an expression and returns an optimized expression which is\n;;semantically identical but runs faster. It is based on a series of\n;;optimizations specified in optimizations of which each take the expression\n;;and optimize certain parts of it. See the documentation for the optimizations\n\n(defn optimize\n \"optimizes the expressions with the optimization passes in optimizations or\n the specified vector of optimizations\"\n ([expr] (optimize expr optimizations))\n ([expr optimizations]\n (loop [opt optimizations expr expr]\n (if (seq opt)\n (recur (rest opt) ((first opt) expr))\n expr))))\n \n\n" }, { "path": "src/main/clojure/numeric/expresso/parse.clj", "content": "(ns numeric.expresso.parse\n (:refer-clojure :exclude [==])\n (:use [numeric.expresso.rules]\n [numeric.expresso.construct])\n (:require [clojure.walk :as walk]\n [instaparse.core :as insta]\n [numeric.expresso.protocols :as protocols]\n [numeric.expresso.utils :as utils]))\n\n\n;; instaparse grammar for infix expression, used by Expresso's parser.\n(def arithmetic\n (insta/parser\n \" expr = <' '>* equals <' '>*\n = add-sub | eq\n eq = add-sub <'='> add-sub\n = mul-div | add | sub\n add = add-sub <'+'> mul-div\n sub = add-sub <'-'> mul-div\n = exp-term | mul | div\n mul = mul-div <'*'> exp-term\n div = mul-div <'/'> exp-term\n = func-term | expon\n expon = exp-term <'**'> term\n = term \n func = (symbol <'('> args <')'> <' '>*) | (symbol <'('> <' '>* <')'> <' '>*)\n args = expr | expr <','> args \n = literal | <' '>* <'('> expr <')'> <' '>*\n = <' '>* literal-without-spaces <' '>*\n = number | symbol | vec | func\n vec = <'['> expr* <']'>\n symbol = math-symbol | lit-symbol\n math-symbol = #'[a-zA-Z]' #'[a-zA-Z0-9]'*\n lit-symbol = <'`'> <' '>* clojure-symbol <'`'>*\n clojure-symbol = #'[a-zA-Z.*+!_?$&=/-]' #'[a-zA-Z.*+!_?$&=0-9:#/-]'*\n number = floating-point-number | int \n = int | (int frac) | (int exp) |\n (int frac exp) | (floating-point-number 'M')\n = digit| (#'[1-9]' digits) |('+' digit) |('+' #'[1-9]' digits)|\n ('-' digit) |('-' #'[1-9]' digits) | (int 'M')\n = '.' digits\n = ex digits\n = digit | (digit digits)\n = #'[0-9]'\n = 'e' | 'e+' | 'e-' | 'E' | 'E+' | 'E-'\"))\n\n(def parse-simplification-rules\n [(rule (ex (* (* ?&*) ?&*r)) :=> (ex (* ?&* ?&*r)))\n (rule (ex (+ (+ ?&*) ?&*r)) :=> (ex (+ ?&* ?&*r)))\n (rule (ex (+ ?x)) :=> ?x)\n (rule (ex (* ?x)) :=> ?x)])\n\n(defn- transform-if-successful [expr]\n (if-let [op (protocols/expr-op expr)]\n (transform-with-rules parse-simplification-rules expr)\n expr))\n\n(defn parse-expression\n \"parses the given string to an expresso expression. Supports all normal\n expressions in infix notation.\"\n [expr]\n (->> (arithmetic expr)\n (insta/transform\n {:number (comp read-string str)\n :expon (partial ce 'numeric.expresso.core/**)\n :div (partial ce `/)\n :mul (partial ce `*)\n :add (partial ce `+)\n :sub (partial ce `-)\n :eq (partial ce '=)\n :expr identity\n :vec vector\n :symbol identity\n :math-symbol (fn [& r] (symbol (apply str r)))\n :clojure-symbol (fn [& r] (symbol (apply str r)))\n :lit-symbol identity\n :args (fn [& r]\n (if (= (count r) 1)\n r (conj (second r) (first r))))\n :func (fn [symb & rest]\n (if (seq rest)\n (cev symb (first rest)) (cev symb [])))\n })\n transform-if-successful))\n" }, { "path": "src/main/clojure/numeric/expresso/properties.clj", "content": "(ns numeric.expresso.properties\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic])\n (:require [numeric.expresso.impl.pimplementation])\n (:import [numeric.expresso.impl.pimplementation\n Expression])\n (:require [clojure.walk :as walk]\n [clojure.core.matrix :as mat]\n [clojure.core.matrix.linear :as lin]\n [numeric.expresso.types :as types]\n [numeric.expresso.impl.matcher :as match]\n [numeric.expresso.protocols :as protocols]))\n\n(declare evaluate-sum emit-sum emit-arithmetic)\n\n(defn- corrected-sub [& s]\n (if (= 1 (count s))\n (mat/negate (first s))\n (apply mat/sub s)))\n\n;;The props multimethod is used to assign the right metadata to the symbols\n;;during construction of expressions. Many protocol implementation are driven\n;;by the functions in the metadata.\n(defmulti props \"gets the metadata associated with the given operator\"\n identity)\n(defmethod props :default [_] {})\n(defmethod props '* [_] {:exec-func mat/emul\n :emit-func (emit-arithmetic '* mat/emul)\n :properties #{:associative\n :commutative\n :n-ary}\n })\n(defmethod props '+ [_] {:exec-func mat/add\n :emit-func (emit-arithmetic '+ mat/add)\n :properties #{:associative :commutative :n-ary}})\n(defmethod props '- [_] {:exec-func corrected-sub\n :emit-func (emit-arithmetic '- corrected-sub)\n :properties [:n-ary [:inverse-of '+]]})\n(defmethod props '/ [_] {:exec-func mat/div\n :emit-func (emit-arithmetic '/ corrected-sub)\n :properties #{:n-ary} :inverse-of '*})\n(defmethod props 'e/ca-op [_] {:properties [:commutative]})\n(defmethod props '** [_] {:exec-func (fn [a b]\n (Math/pow a b))})\n(defmethod props 'emul [_] {:exec-func mat/emul})\n(defmethod props 'div [_] {:exec-func mat/div})\n(defmethod props 'add [_] {:exec-func mat/add\n :properties #{:associative :commutative}})\n(defmethod props 'sub [_] {:exec-func mat/sub})\n(defmethod props 'inner-product [_] {:exec-func mat/inner-product :properties #{:associative}})\n(defmethod props 'scale [_] {:exec-func mat/scale })\n(defmethod props 'mul [_] {:exec-func mat/mul})\n(defmethod props 'add-product [_] {:exec-func mat/add-product})\n(defmethod props 'add-scaled [_] {:exec-func mat/add-scaled})\n(defmethod props 'add-scaled-product [_] {:exec-func mat/add-scaled-product})\n(defmethod props 'scale [_] {:exec-func mat/scale})\n(defmethod props 'normalise [_] {:exec-func mat/normalise})\n(defmethod props 'dot [_] {:exec-func mat/dot})\n(defmethod props 'outer-product [_] {:exec-func mat/outer-product})\n(defmethod props 'cross [_] {:exec-func mat/cross})\n(defmethod props 'distance [_] {:exec-func mat/distance})\n(defmethod props 'det [_] {:exec-func mat/det})\n(defmethod props 'inverse [_] {:exec-func mat/inverse})\n(defmethod props 'negate [_] {:exec-func mat/negate})\n(defmethod props 'trace [_] {:exec-func mat/trace})\n(defmethod props 'length [_] {:exec-func mat/length})\n(defmethod props 'length-squared [_] {:exec-func mat/length-squared})\n(defmethod props 'pow [_] {:exec-func mat/pow})\n(defmethod props 'log [_] {:exec-func mat/log\n })\n(defmethod props 'sum [_] {:eval-func evaluate-sum\n :emit-func emit-sum})\n(defmethod props 'sqrt [_] {:exec-func mat/sqrt\n })\n(defmethod props 'log [_] {:exec-func mat/log\n })\n(defmethod props 'asin [_] {:exec-func mat/asin})\n(defmethod props 'acos [_] {:exec-func mat/acos})\n(defmethod props 'atan [_] {:exec-func mat/atan})\n(defmethod props 'sin [_] {:exec-func mat/sin})\n(defmethod props 'cos [_] {:exec-func mat/cos})\n(defmethod props 'tan [_] {:exec-func mat/tan})\n(defmethod props 'abs [_] {:exec-func mat/abs})\n(defmethod props 'exp [_] {:exec-func mat/exp})\n(defmethod props 'norm [_] {:exec-func lin/norm})\n(defmethod props 'rank [_] {:exec-func lin/rank})\n(defmethod props 'qr [_] {:exec-func lin/qr})\n(defmethod props 'cholesky [_] {:exec-func lin/cholesky})\n(defmethod props 'lu [_] {:exec-func lin/lu})\n(defmethod props 'svd [_] {:exec-func lin/svd})\n(defmethod props 'eigen [_] {:exec-func lin/eigen})\n(defmethod props 'solve [_] {:exec-func lin/solve})\n(defmethod props 'least-squares [_] {:exec-func lin/least-squares})\n\n\n(defmulti matcher \"gets the matching relation for the extractor-expression\"\n first)\n\n(defmethod matcher :default [_]\n (if (contains? (:properties (second _)) :commutative)\n {:match-rel match/match-commutativeo}\n {:match-rel match/expression-matcho}))\n(defmethod matcher 'e/ca-op [_] {:match-rel match/match-commutativeo})\n\n\n;;These predicates are contributed to core.matrix and the core.matrix predicates\n;;will be used when they become available in a core.matrix release\n\n(defn zero-matrix?\n \"checks whether expr represents a zero-matrix\"\n [expr]\n (if (symbol? expr)\n (if (contains? (protocols/properties expr) :mzero) true false)\n (loop [elem (mat/eseq expr)]\n (if (seq elem)\n (if (and (number? (first elem)) (clojure.core/== 0 (first elem)))\n (recur (rest elem))\n false)\n true))))\n\n(defn identity-matrix?\n \"checks whether expr represents an identity-matrix\"\n [expr]\n (try \n (if (symbol? expr) false\n (let [d (mat/dimensionality expr)]\n (cond\n (clojure.core/== d 0) (clojure.core/== expr 1)\n (clojure.core/== d 1) (and (clojure.core/== (count expr) 1)\n (clojure.core/== (first expr) 1))\n (clojure.core/== d 2)\n (let [rc (mat/row-count expr)\n cc (mat/column-count expr)]\n (loop [i 0]\n (if (< i rc)\n (if (nil? (loop [j 0]\n (if (< j cc)\n (let [elem (mat/mget expr i j)]\n (when-not (symbol? elem)\n (cond\n (clojure.core/== elem 0) (if (clojure.core/== i j)\n false\n (recur (inc j)))\n (clojure.core/== elem 1) (if (clojure.core/== i j)\n (recur (inc j))\n false)\n :else false))))))\n (recur (inc i))\n false)\n true))))))\n (catch Exception e false)))\n \n(defn- extract-mzero [pargs expr]\n (project [pargs expr]\n (let [x (first pargs)]\n (if (contains? (protocols/properties expr) :mzero)\n (== x expr)\n (if (zero-matrix? expr)\n (== x expr)\n fail)))))\n\n(defn- extract-midentity [pargs expr]\n (project [pargs expr]\n (let [x (first pargs)]\n (if (contains? (protocols/properties expr) :midentity)\n (== x expr)\n (if (identity-matrix? expr)\n (== x expr)\n fail)))))\n\n(defn- extract-as [pargs expr]\n (project [pargs expr]\n (let [x (first pargs)\n y (second pargs)]\n (fresh []\n (protocols/match x expr)\n (== y expr)))))\n\n(defn- extract-shape [pargs expr]\n (project [pargs expr]\n (let [x (first pargs)\n y (second pargs)]\n (fresh []\n (protocols/match x expr)\n (== y (protocols/shape expr))))))\n\n(defmulti extractor-rel\n \"associates extracting relations with extractor symbols\"\n identity)\n(defmethod extractor-rel :default [_] nil)\n(defmethod extractor-rel 'is? [_] match/extract-is)\n(defmethod extractor-rel 'cons? [_] match/extract-cons)\n(defmethod extractor-rel 'mzero? [_] extract-mzero)\n(defmethod extractor-rel 'midentity? [_] extract-midentity)\n(defmethod extractor-rel 'as? [_] extract-as)\n(defmethod extractor-rel 'shape? [_] extract-shape)\n\n(defn add-information\n \"adds the metadata to op for further manipulation with expresso\"\n [op]\n (let [p (props op)\n m (matcher [op p])]\n (merge {:expression true} p m)))\n\n(defn is-number?\n \"checks if x represents a number\"\n [x]\n (or (number? x) (isa? (protocols/type-of x) types/number)))\n\n(defn is-symbol?\n \"checks if x represents a symbol\"\n [x]\n (symbol? x))\n\n\n(defn- evaluate-sum [sum sm]\n (let [[_ k i expr] sum\n i (protocols/substitute-expr i sm)]\n (if (and (or (= (first i) '<=) (= (first i) '<)) (= k (nth i 2)))\n (let [start (if (= (first i) '<=) (second i) (inc (second i)))\n end (if (= (first i) '<=) (nth i 3) (dec (nth i 3)))]\n (loop [n start res 0]\n (if (<= n end)\n (recur (inc n) (mat/add res\n (-> expr\n (protocols/evaluate (merge sm {k n})))))\n res)))\n (throw (Exception. (str \"Can't evaluate sum of the range \" i))))))\n\n(defn- emit-sum [sum]\n (let [[_ k i expr] sum]\n (if (and (or (= (first i) '<=) (= (first i) '<)) (= k (nth i 2)))\n (let [start (if (= (first i) '<=) (second i) `(inc ~(second i)))\n end (if (= (first i) '<=) (nth i 3) `(dec ~(nth i 3)))]\n `(loop [n# (long ~start) res# 0]\n (if (<= n# ~end)\n (let [~k n#]\n (recur (inc n#) (mat/add res# ~(protocols/emit-code expr))))\n res#)))\n (throw (Exception. (str \"Can't emit code for sum of the range \" i))))))\n\n\n(defn- emit-arithmetic\n \"emits code for clojure.core/op literally when all args of the expression\n are numbers\"\n [op exec-func]\n (fn [expr]\n (let [args (protocols/expr-args expr)]\n (if (every? #{[]} (map protocols/shape args))\n (list* op (map protocols/emit-code args))\n (list* exec-func (map protocols/emit-code args))))))\n" }, { "path": "src/main/clojure/numeric/expresso/protocols.clj", "content": "(ns numeric.expresso.protocols)\n\n;; This namespace defines the basic abstractions used in expresso\n;; If you want to read and understand the code, this is the right place\n;; to start\n\n;;General\n;;Expresso, while using clojure's standart datastructures to represent normal\n;;expressions uses protocols for the underlying manipulations.\n;;This makes it possible to have custom types as first class expressions where\n;;normal ISeqs (with metadate) - expresso's standart expression type - aren't\n;;adequate. A good example of that is a type for a PolynomialExpression which\n;;would be wasteful and slow to encode as lists.\n;;One important thing to keep in mind with the standart expressions based\n;;on clojure's built in types is that metadata doesn't count on equality, so\n;;Two symbols with the same name are equal even if they have different properties\n;;assigned! This is important to keep in mind because it destroys mechanism like\n;;memoization. Also be sure to have different names for differet variables in\n;;the expression you manipulate with expresso.\n;;However, playing well with clojures built in abstractions is *very* important\n;;s-expressions aren't per chance the lisp way to represent expressions, so\n;;every custom Expression type should also be a proper s-exp in the clojure sense\n;;and should implement ISeq.\n;;Most implementations of the protocols - if not noted otherwise - can be found\n;;in numeric.expresso.impl.pimplementation.clj where also the custon types are\n;;defined\n;;Most protocols have implementations for ISeq which depend on multimethod about\n;;their operator, which makes it easy to extend expresso to new operators\n;;*without* having to introduce a new type\n\n\n;;PExpression\n;;The protocol that all expressions implement. expr-op and expr-args are the\n;;first and rest of expressions. Constants are encoded as having no operator\n;;so the test (if-let [op (expr-op expr-or-constant)] expr constant) can be\n;;used to differentiate between expressions and constants.\n;;If expr-op returns non-nil the argument is a valid expression for expresso.\n;;expr-op should also be called first to check whether the argument is an\n;;expression *before* calling expr-args which has no meaning for constants\n\n(defprotocol PExpression\n \"The abstraction for an expresso Expression\"\n (expr-op [expr])\n (expr-args [expr]))\n\n\n;;PProps\n;;Defines one generic method properties, which returns the set of properties\n;;known about expr. Properties are normally stored somewhere in the metadata\n;;or in a field in a custom type, but this is implementation detail and hidden\n;;behind this protocol.\n;;There is no constraint about the element type of the properties set, although\n;;expresso just uses keywords for it, like :mzero and :midentity for zero- and\n;;identity-matrix properties\n\n\n(defprotocol PProps\n \"The abstraction to query properties of an Expression or Atom\"\n (properties [expr]))\n\n;;PVars\n;;similar to properties, vars is the protocol to get the set of variables in the\n;;expressions. Variables are symbols and lvars. Custom types can also define vars\n;;on itself to mark them variables.\n;;One important area where vars is called in expresso are the eval-rules, which\n;;collect the (parts of) expressions which have no dependency on variables and\n;;evaluate them.\n\n(defprotocol PVars\n \"generic method to get the set of variables in the expression\"\n (vars [expr]))\n\n\n;;PValue\n;;In the presence of custom types it is not always the right idea to have rules\n;;about the instances of this types. The value function is used to extract the\n;;semantic value out of the argument. Could be for example stripping out a\n;;wrapper type. For most standart expresso inputs this is the identity function.\n;;An example where this is used is to get the value of a symbol which has the\n;;property of being an identity- or a zero-matrix of known shape.\n\n(defprotocol PValue\n \"generic way to get the value of the argument.\"\n (value [atom]))\n\n;;PMatch\n;;Expresso is based on a rule based translator which runs on-top of core.logic\n;;The rule based translator features semantic matching of rules instead of\n;;syntactical matching. So for commutative-operators expressions match iff\n;;one permutation of the expression arguments match the pattern.\n;;This protocols match method provides the flexibility to extend the matching\n;;process to knew types and operators. See also matcher.clj for the\n;;implementation and properties.clj where the actual matching core.logic\n;;relations are chosen for the operators\n\n(defprotocol PMatch\n \"The abstraction for matching in a rule based context\"\n (match [this that]))\n\n;;PExprToSexp\n;;Does what it's name implies. Although expresso expressions are actual ISeq's\n;;they are not actually seqs build on clojures standart types and could be\n;;harder to manipulate if one expects an actual list representing an s-expression\n;;This protocol is available for situations like these\n\n(defprotocol PExprToSexp\n (to-sexp [expr]))\n\n;;PExprEvaluate\n;;Provides the evaluate method, which evaluates the given expression with the\n;;values for the variables of the expression given in the symbol map sm.\n;;Throws if not all variables are specified. Can be thought of as a better\n;;version of eval to evaluate s-expressions for expresso, because it does\n;;*not* depend on what symbols resolve to but is data driven from the knowledge\n;;that expresso has of the operators.\n\n(defprotocol PExprEvaluate\n (evaluate [expr sm]))\n\n;;PexprExecFunc\n;;gets the execution function to evaluate an expression. This is the standart\n;;mechanism used in evaluate. See properties.clj where the execution functions\n;;are given for the operators of expresso\n(defprotocol PExprExecFunc\n (exec-func [expr]))\n\n;;PSubstitute\n;;Provides the substitute-expr method which substitutes the keys of the given\n;;(symbol) map for its values in the expression. The map can also contain\n;;expressions as keys. Normal clojure equality is used to test for substitution.\n(defprotocol PSubstitute\n (substitute-expr [expr sm]))\n\n;;PType\n;;Provisional protocol for Type inference in expresso. Currently not used for\n;;inferece in expresso. There are situations in which knowledge of the type\n;;could lead to better optimizations. Currently differentiates between\n;;numbers and matrixes (name mismatch - matrix should better be called ndarray\n;;here), which can also be differentiates on theis shape\n\n(defprotocol PType\n (type-of [this])\n (set-type [this type]))\n\n;;PShape\n;;The shape and set-shape methods are used to query and set the shape of the\n;;given expressions. Expresso infers the shape of an expression from its\n;;operator and the shapes of its arguments.\n;;The shape can be an actual shape like core.matrix/shape gives you, or it can\n;;be a logic variable or an expression containig logic variables.\n;;This plus the constraints facility allow expresso to correctly infer the shape\n;;even if the shape of one part is undetermined. With the added constraint for\n;;the value of the undetermined shape, the other shapes in the expression can\n;;be inferred. See add-constraint and construct.clj\n\n(defprotocol PShape\n (shape [this])\n (set-shape [this shape]))\n\n;;PInferShape\n;;Like PShape but its method are for the inferred shape and not for the shape\n;;resulting from the arguments of the expression. In the presence of implicit\n;;broadcasting and simplification these two shapes can clash. The inferred shape\n;;has priority above the shape and will be returned from calls to shape if\n;;available.\n;;An example where inferred shape is needed is this\n;; (ex (+ a b (- a))) is simplified to b.\n;;The shape of the expression is not affected by the simplification, but b now\n;;has to have the inferred shape set to the shape of (ex (+ a b (- a))) because\n;;b could be implicit broadcasted to the shape of a. So the correct shape of\n;;b is not the shape of b like it would be without an inferred shape but it is\n;;the longest shape of a and b, which is the shape of (ex (+ a b (- a)))\n\n(defprotocol PInferShape\n (inferred-shape [this])\n (set-inferred-shape [this shape]))\n\n;;Not all manipulations of expresso are based on the rule based translator.\n;;Where it makes sense to stay away from a rule based approach expresso does so.\n;;In case of rearranging and differentiating the manipulatios are determined\n;;by the operators of the expressions alone and an open rule set would not get\n;;any benefits.\n\n;;PRearrange\n;;The rearrange-step function is used to make a single step when rearraging the\n;;equation consisting of lhs and rhs to x, which is in the pos part of the\n;;current top level\n\n(defprotocol PRearrange\n (rearrange-step [lhs pos rhs]))\n\n;;PDifferentiate\n;;the differentiate-expr function does symbolic differentiation of the expression\n;;in regard to the specified variable. No simplifications on the output are done.\n(defprotocol PDifferentiate\n (differentiate-expr [expr var]))\n\n;;PConstraints\n;;Expresso, because it is built on-top of core.logic has powerful mechanism to\n;;declaratively handle constraints about expressions. Currently Constraits are\n;;mostly used for shape inference, but they are more general than that.\n;;an expression can have a set of constraints, which can be checked - see the\n;;check-constraints method in pimplementation.clj - ad which result can alter\n;;the expression. A constraint is a vector of [relation args*]. The constraints\n;;are stored as a set in an expression and the constraints on the arguments are\n;;also constraints on the parent expression.\n(defprotocol PConstraints\n (constraints [expr])\n (add-constraint [expr constraint]))\n\n;;PEmitCode\n;;This protocol is used by the optimizer of expresso. The function emit-code\n;;emits (fast) clojure code needed when compiling an expression to a non-over-\n;;head clojure function. In the normal case this is (exec-fun args)\n;;See also emit-func\n\n(defprotocol PEmitCode\n (emit-code [expr]))\n\n;;PTransformExpression\n;;Protocol for a transformation of the expression according the the specified\n;;rule vector, to the standart form encoded by the rule. Applies the rules\n;;fully recursive bottom up. See rules.clj for the details\n(defprotocol PTransformExpression\n (transform-expr [expr rules]))\n\n\n;;Multimethod used by the default implementation for ISeq of emit-code to emit\n;;the function for the operator. defaults to the :emit-func key in the operator\n(defmulti emit-func first)\n(defmethod emit-func :default [expr] (:emit-func (meta (first expr))))\n\n;;Multimethod for the actual function used in the default implementation of\n;;rearrange step for ISeq\n(defmulti rearrange-step-function first)\n\n;;Multimethod for the actual function used in the default implementtaion of\n;;differentiate for ISeq\n(defmulti diff-function (comp first first))\n\n" }, { "path": "src/main/clojure/numeric/expresso/rules.clj", "content": "(ns numeric.expresso.rules\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic]\n [numeric.expresso.impl.matcher]\n [numeric.expresso.protocols])\n (:require [numeric.expresso.properties :as props]\n [clojure.walk :as walk]\n [clojure.core.memoize :as memo]\n [numeric.expresso.utils :as utils]\n [clojure.set :as set]\n [numeric.expresso.construct :as c]))\n;;this namespace provides expresso rule-based translator facility. Most notable\n;;are the rule macro, which constructs a rule and apply-rule wich applies a\n;;rule in a core.logic context.\n\n;;A rule consists of a 3-element vector with [pattern transformation guard]\n;;The elements of the vector can contain fresh lvars\n;;the rule macro converts ?-starting symbols to fresh lvars\n;;The transition can be a normal lvar-containing expression like the pattern\n;;or can be a core.logic relation\n;;the guard is optional (succeed is used if no guard is supplied)\n\n\n(declare exp-isa?)\n(defn- replace-?-with-lvar\n \"replaces a symbol with a not gensymed lvar if it starts with a ?\"\n [node]\n (if (and (symbol? node) (.startsWith (name node) \"?\"))\n (lvar node false)\n node))\n\n(defn- ?-to-lvar\n \"walks the code to replace ?-symbols with unifyable lvars\"\n [code]\n (walk/prewalk replace-?-with-lvar code))\n\n\n(defn- check-guardo\n \"succeeds iff the guard relation succeeds\"\n [guard]\n (project [guard] guard))\n\n(defn- apply-transformationo\n \"the transformation can either be an expression or a core.logic relation\n of (trans result)\"\n [trans n-exp]\n (project [trans]\n (if (and (ifn? trans)\n (not (coll? trans))\n (not (keyword? trans))\n (not (symbol? trans)))\n (trans n-exp)\n (== trans n-exp))))\n\n(defn- name-of-lvar [c]\n (let [n (re-find #\"\" (str c))]\n (and (seq n) (symbol (second n)))))\n\n(defn- revert-back-lvars [code]\n (walk/postwalk (fn [c] (if-let [name (name-of-lvar c)]\n name\n c)) code))\n;;utility macros to create inline core.logic relations which act as transition\n;;and guard in a rule. the ...fn macros take normal clojure code as argument and\n;;convert it to a core.logic relation and the ...rel macros take a core.logic\n;;relation.\n\n(defmacro transfn\n \"transfn creates a function to be used as transition in a rule\"\n [args & code]\n (let [args (revert-back-lvars args)\n code (revert-back-lvars code)]\n `(fn ~args\n (fn [res#]\n (project ~args\n (fresh [tmp#]\n (== tmp# (do ~@code))\n (conda\n ((nilo tmp#) fail)\n ((== res# tmp#)))))))))\n\n(defmacro transrel\n \"transrel creates a relation to be used as transition in a rule\"\n [args & code]\n (let [args (revert-back-lvars args)\n code (revert-back-lvars code)]\n `(fn ~(vec (butlast args))\n (fn [~(last args)]\n (project ~(vec (butlast args))\n (fresh []\n ~@code))))))\n\n(defmacro guardfn\n \"guardfn creates a function to be used as guard in a rule\"\n [args & code]\n (let [args (revert-back-lvars args)\n code (revert-back-lvars code)]\n `(fn ~args\n (project ~args\n (== true (do ~@code))))))\n\n(defmacro guardrel\n \"guardrel creates a relations to be used as guard in a rule\"\n [args & code]\n (let [args (revert-back-lvars args)\n code (revert-back-lvars code)]\n `(fn ~(vec args)\n (project ~(vec args)\n (fresh [] ~@code)))))\n\n\n(defn- lvars-in-code [transcode]\n (let [lv (filter #(.startsWith (str %) \"?\") (flatten transcode))]\n (into [] (into #{} lv))))\n\n(defn- str-seq\n \"fully transforms (possible lazy ) s to a string\"\n [s]\n (if (sequential? s)\n (apply str (map str-seq s))\n (str s)))\n \n\n(defn- replace-back [transcode]\n (let [matches (re-seq #\"\" (str-seq transcode))\n symb-matches (map (fn [v] [(symbol (first v)) (symbol (second v))]) matches)\n replacement-map (into {} matches)\n erg (walk/postwalk #(do \n (if-let [r (get replacement-map (str %) nil)]\n (symbol r) %)) transcode)]\n erg))\n\n(defn- reconstruct [lvars]\n (map replace-?-with-lvar lvars))\n\n(defn- make-inline-trans [transcode]\n (let [lvars (lvars-in-code transcode)]\n `((transfn ~lvars ~transcode) ~@lvars)))\n\n(defn trans*\n \"function version of trans\"\n [transcode]\n (let [res (?-to-lvar (make-inline-trans (replace-back transcode)))]\n res))\n\n(defmacro trans\n \"to be used inside a rule to transform the inline-code to a core.logic\n relation which is suitable for the rule based translator as translation\n relation. All values of the ?-symbols of the pattern are defined inside\n trans.\"\n [transcode]\n (trans* transcode))\n\n\n(defn make-inline-guard [guardcode]\n (let [lvars (lvars-in-code guardcode)]\n `((guardfn ~lvars ~guardcode) ~@lvars)))\n\n(defn guard* [guardcode]\n (let [res (?-to-lvar (make-inline-guard (replace-back guardcode)))]\n res))\n\n(defmacro guard\n \"to be used inside a rule to transform the inline (boolean returning) code\n to a core.logic relation which is suitable for the rule based translator\n as guard relation. All values of the ?-symbols of the pattern are defined\n inside guard\"\n [guardcode]\n (guard* guardcode))\n\n\n(defn rule*\n \"function version of rule\"\n [v]\n (let [expanded (?-to-lvar v)\n [pat to trans & rest] v\n trans (if (= to :==>) (make-inline-trans trans) trans)\n guard (if (and (seq rest) (= :if (first rest))) (second rest) succeed)]\n (with-meta [(?-to-lvar pat) (?-to-lvar trans) (?-to-lvar guard)] {:syntactic (and (seq rest) (= (last rest) :syntactic))})))\n \n\n(defmacro rule\n \"constructs a rule. Syntax is (rule pat :=> trans) pat is a normal expression\n which can contain symbols starting with a ? which will be transformed to\n logic variables which are unified while matching the an expression to the\n pattern. trans can also be an expression containing lvars or it can be an\n arbitrary core.logic relation which takes the transformed rule as its output\n argument. :==> can be used to automatically translate a normal inline clojure\n function to the needed core.logic relation.\n It supports an optional guard argument. Syntax is then (rule pat :=> trans :if\n guard) guard is a core.logic relation which is called after matching the pat\n with the expression and succeeds if the rule is applicable or fails if not.\"\n [& v]\n (rule* v))\n\n\n(defn define-extractor\n \"defines and installs an extractor with the given name and relation.\n The relation will be called during matching and unifies the arguments\n of the extractor with the expression it is being matched with\"\n [name rel]\n (.addMethod props/extractor-rel name (fn [_] rel)))\n\n\n(defn apply-semantic-rule\n \"applies rule to expression. The first succesful application of the rule gets\n performed\"\n [rule exp]\n (first (-run {:occurs-check false :n 1 :reify-vars (fn [v s] s)} [q]\n (fresh [pat trans guard tmp]\n (== rule [pat trans guard])\n (match-expressiono pat exp)\n (check-guardo guard)\n (apply-transformationo trans tmp)\n (replace-symbolso tmp q)))))\n\n(defn apply-syntactic-rule\n \"applies simple syntactical rule to expression.\"\n [rule exp]\n (first (run 1 [q]\n (fresh [pat trans guard]\n (== rule [pat trans guard])\n (== pat exp)\n (check-guardo guard)\n (apply-transformationo trans q)))))\n(defn apply-rule\n \"applies the specified rule to the epxression returning a modified one if the\n rule was applicable of nil if the rule was not applicable\"\n [rule exp]\n (let [ex-op (expr-op exp)\n rule-op (expr-op (first rule))]\n (if (or (c/extractor? (first rule))\n (not (or (and (nil? rule-op)\n (not (sequential? (first rule)))\n (not (lvar? (first rule))))\n (and ex-op rule-op (not (exp-isa? ex-op rule-op))))))\n (if (:syntactic (meta rule))\n (apply-syntactic-rule rule exp)\n (apply-semantic-rule rule exp)))))\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n;;various functions to build rule application strategies outside and inside of\n;;a core.logic context\n\n\n(defn apply-ruleo\n \"core.logic relation of apply-rule - not relational, you can't generate all possible rules which transform an expression to the new-expression\"\n [rule exp n-exp]\n (project [rule exp]\n (if-let [res (apply-rule rule exp)]\n (== res n-exp)\n fail)))\n\n(declare apply-rules)\n\n(defn apply-ruleso\n \"non-relational core.logic equivalent of apply-rules\"\n[rules expr nexpr]\n (matche [rules]\n ([[?r . ?rs]] (conde\n ((apply-ruleo ?r expr nexpr))\n ((apply-ruleso ?rs expr nexpr))))))\n\n(defn apply-rules-debug\n \"like apply-rules but gives realtime information about the rules which gets tried and applied\"\n [rules expr]\n (loop [rules rules expr expr]\n (if (seq rules)\n (do (prn \"try apply \" (butlast (first rules)) \"with \" expr)\n (if-let [erg (apply-rule (first rules) expr)]\n (do (prn \"applied rule \" (butlast (first rules)) \" with result \" erg)\n erg)\n (recur (rest rules) expr)))\n expr)))\n\n(declare apply-rules transform-with-rules transform-expression*\n transform-expressiono)\n(defn- apply-to-end\n [rules expr]\n (let [nexpr (apply-rules rules expr)]\n (if (= expr nexpr)\n nexpr\n (transform-expression* nexpr rules))))\n\n(defn- apply-to-endo [rules expr new-expr]\n (fresh [nexpr]\n (conda\n ((apply-ruleso rules expr nexpr)\n (transform-expressiono rules nexpr new-expr))\n ((== new-expr expr)))))\n\n(defn apply-all-rules\n \"tries to apply all rules in rules on expression\"\n [rules expr]\n (loop [rules rules expr expr]\n (if (seq rules)\n (recur (rest rules) (if-let [nexpr (apply-rule (first rules) expr)]\n nexpr expr))\n expr)))\n\n(defn- exp-isa?\n \"isa? semantics in expression. For unqualified symbols check e/symbol\"\n [ex-op rule-op]\n (or (isa? ex-op rule-op) (isa? (symbol (str \"e/\" ex-op)) rule-op)))\n\n(defn apply-rules\n \"returns the result of the first succesful application of a rule in rules \"\n [rules expr]\n (let [rules (into [] rules)]\n (loop [rules rules expr expr]\n (if (seq rules)\n (if-let [erg (apply-rule (first rules) expr)]\n erg\n (recur (rest rules) expr))\n expr))))\n\n(def ^:dynamic *rules*)\n\n(defn transform-with-rules\n \"transforms the expr according to the rules in the rules vector until no rule\n can be applied any more. Uses clojure.walk/prewalk to walk the expression tree\n in the default case. A custom walkfn and applyfn can be specified defaults to\n clojure.walk/postwalk and apply-rules\"\n ([rules expr walkfn applyfn]\n (let [tmp (walkfn\n (fn [a] (let [res (applyfn rules a)] res)) expr)]\n (if (= tmp expr) tmp (recur rules tmp walkfn applyfn))))\n ([rules expr] (transform-with-rules rules expr walk/prewalk apply-rules)))\n\n(defn transform-with-rules-wo-recursion\n \"transforms the expr according to the rules in the rules vector until no rule\n can be applied any more. Uses clojure.walk/prewalk to walk the expression tree\n in the default case. A custom walkfn and applyfn can be specified defaults to\n clojure.walk/postwalk and apply-rules\"\n ([rules expr walkfn applyfn]\n (let [tmp (walkfn\n (fn [a] (let [res (applyfn rules a)] res)) expr)]\n tmp))\n ([rules expr] (transform-with-rules rules expr walk/prewalk apply-rules)))\n\n(defn- simplified? [expr rules]\n (and (instance? clojure.lang.IObj expr)\n (contains? (:simplified-by (meta expr)) (:id (meta rules)))))\n\n(defn- annotate-simplified [expr *rules*]\n (if (instance? clojure.lang.IObj expr)\n (with-meta expr (assoc (meta expr)\n :simplified-by #{(:id (meta *rules*))}))\n expr))\n\n(defn- add-simp-annotations [res expr]\n (if (instance? clojure.lang.IObj res)\n (with-meta res (update-in (meta res)\n [:simplified-by]\n #(set/union % (:simplified-by (meta expr)))))))\n\n\n(defn- merge-transformed-meta [meta-exp transformed] \n (if (instance? clojure.lang.IObj transformed)\n (with-meta transformed (merge meta-exp (meta transformed)))\n transformed))\n\n(defn- transform-expression*\n ([expr rules]\n (transform-expr expr rules)))\n\n;;Transform-expression is the optimized transform-all function to transform\n;;an expression according to the rules in the rule vector. The outcoming\n;;expression is guaranteed to be in a standart form defined by the rule vector\n;;applies the rules in a fully recursive bottom-up approach.\n;;uses tagging to avoid repetive transformations and also apply-rules semantics\n;;to avoid applying a rule where it is clear to fail.\n;;uses a protocol dispatch so that custom expression types can specify how\n;;rules will be applied. For example the LetExpression transforms itself by\n;;first transforming the bindings and then the body.\n\n(defn transform-expression\n \"transforms the expression according to the rules in the rules vector in a\n bottom up manner until no rule can be applied to any subexpression anymore\"\n [rules expr]\n (transform-expression* expr\n (if (:id (meta rules))\n rules\n (with-meta rules (assoc (meta rules) :id (gensym \"id\"))))))\n\n;;transform-expression uses tagging to mark expression simplified according to\n;;the :id key in the metadata of the rule. If no is specified a new will be\n;;gensymed. if the expression is simplified the id of the actual rules will be\n;;added to the simplified-by key in the expression metadata, which takes care\n;;that the expression wont't be simplified again by transform-expression.\n;;It is also possible that the expression was simplified by other rules and that\n;;the current transformation hasn't changed it. In this case the old simplified\n;;by key can be retained and the union of the ids will be the new simplified-by\n;;set. It also merges the metadata of the transformed expression with the\n;;previous expressions in that way that the transformed meta has has priority.\n;;This is important for the inferred shape which is stored in another metadata\n;;key. \n(extend-protocol PTransformExpression\n Object\n (transform-expr [expr rules]\n (if (simplified? expr rules)\n expr\n (let [res\n (if-let [op (expr-op expr)]\n (let [transformed (doall (map #(transform-expression* % rules)\n (expr-args expr)))\n n-expr (merge-transformed-meta\n (meta expr) (c/cev (first expr) transformed))\n res (apply-to-end rules n-expr)]\n (if (= expr res)\n (add-simp-annotations\n (annotate-simplified res rules) expr)\n (annotate-simplified res rules)))\n (annotate-simplified (apply-to-end rules expr) rules))]\n res)))\n numeric.expresso.impl.pimplementation.LetExpression\n (transform-expr [expr rules]\n (let [bindings (.-bindings expr) code (.-code expr)]\n (c/let-expr (mapv #(transform-expression rules %) bindings)\n (map #(transform-expression rules %) code)))))\n \n\n(defn transform-expressiono\n \"core.logic equivalent of transform-expression\"\n [rules expr nexpr]\n (project [rules expr]\n (fresh [res]\n (conda\n ((nilo (expr-op expr)) (apply-to-endo rules expr nexpr))\n ((fresh [transformed]\n (utils/mapo #(transform-expressiono rules %1 %2)\n (expr-args expr)\n transformed)\n (project [transformed]\n (apply-to-endo\n rules (list* (first expr)\n transformed) nexpr))))))))\n\n(defn transform-one-level\n \"transforms the top level of expr according to rules\"\n [rules expr]\n (transform-with-rules rules expr (fn [f expr] (f expr)) apply-rules))\n\n;;See if it is possible to reinstantiate rules so that they can be applied all\n;;in the core.logic context\n" }, { "path": "src/main/clojure/numeric/expresso/simplify.clj", "content": "(ns numeric.expresso.simplify\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic :exclude [log] :as l]\n [numeric.expresso.construct]\n [numeric.expresso.impl.polynomial]\n [numeric.expresso.properties :as props]\n [numeric.expresso.protocols]\n [numeric.expresso.impl.pimplementation]\n [numeric.expresso.rules])\n (:require [clojure.walk :as walk]\n [numeric.expresso.utils :as utils]\n [clojure.set :as set]\n [numeric.expresso.impl.symbolic :as symb]\n [clojure.core.matrix :as matrix]\n [numeric.expresso.construct :as c]))\n\n;;in this namespace are most of expresso's simplification rules defined\n;;It also serves as demonstration of the power of the rule based approach btw.\n\n\n;;utility functions for the eval-rules which eval a whole expression if it\n;;contains no undetermined part or evaluates part of it\n\n(defn- calc-reso\n \"core.logic relation which calcualates the expression. Not relational\"\n [expr]\n (fn [res]\n (project [expr]\n (== (evaluate expr nil) res))))\n\n(defn- no-symbolso\n \"succeeds if there are no symbols in the given expression\"\n [expr]\n (project [expr]\n (fresh []\n (== true (and (expr-op expr) (no-symbol expr))))))\n\n(defn- contains-no-var? [expr]\n (if (and (not (symbol? expr)) (no-symbol expr)) true false))\n\n(defn- collapse-arguments-commutative\n \"folds constants in commutative functions\"\n [xs args]\n (let [gb (group-by contains-no-var? args)\n fix (concat (gb nil) (gb true))\n var (gb false)]\n (if (or (empty? fix) (< (count fix) 2))\n (list* xs args)\n (list* xs (evaluate (list* xs fix) {}) var))))\n\n(defn- collapse-arguments-associative\n \"folds constants in associative functions\"\n [xs args]\n (let [parts (partition-by contains-no-var? args)\n eval-parts (fn [part]\n (if (and (and (coll? part) (> (count part) 1))\n (or (= nil (contains-no-var? part)) (contains-no-var? part)))\n [(evaluate (list* xs part) nil)]\n part))\n mc (mapcat eval-parts parts)]\n (list* xs mc)))\n\n(defn- compute-subexpression\n \"computes subexpressions of expr\"\n [expr]\n (if (coll? expr)\n (let [[xs & args] expr]\n (cond #_(isa? xs 'e/ca-op)\n (contains? (:properties (meta xs)) :commutative)\n (collapse-arguments-commutative xs args)\n (contains? (:properties (meta xs)) :associative)\n (collapse-arguments-associative xs args)\n (isa? xs 'e/ao-op) (collapse-arguments-associative xs args)\n :else expr))\n expr))\n \n(defn- compute-subexpressiono\n \"core.logic version of compute-subexpression\"\n [expr]\n (fn [res]\n (project [expr]\n (let [tmp (compute-subexpression expr)]\n (if (= tmp expr)\n fail\n (== res tmp))))))\n\n\n(defn- symbolo [x] (project [x] (== true (symbol? x))))\n\n\n(defn- with-shape\n \"sets the inferred shape of the value. expands to zero- and identity-matrices\n where appropriate\"\n [val shape]\n (cond\n (utils/num= val 0) (if (or (lvar? shape) (sequential? shape))\n (value (zero-matrix :shape shape)) 0)\n (utils/num= val 1) (if (or (lvar? shape) (sequential? shape))\n (value (identity-matrix :shape shape)) 1)\n :else (set-inferred-shape val shape)))\n \n\n(construct-with [+ - * / ** ln sin cos sqrt exp log mzero? midentity? inner-product inverse\n shape?]\n;;to read the rule examples\n;; :==> means that the transition is an in-line clojure function\n;; ?&* matches zero or more elements of the expression\n;; ?&+ matches one or more elements of the expression \n;; shape? mzero? and midentity? are extractors.\n;; (shape? pattern ?s) matches the pattern and unifies the shape of the pattern\n;; with ?s \n;; (mzero? ?x) succeeds if ?x is some zero-matrix so 0, 0.0, [[0.0]], etc.\n;; (midentity? ?x) is like mzero but succeeds for identity-matrices\n \n(def arity-rules\n [(rule (shape? (+) ?s) :==> (with-shape 0 ?s))\n (rule (shape? (*) ?s) :==> (with-shape 1 ?s))\n (rule (shape? (+ ?x) ?s) :==> (with-shape ?x ?s))\n (rule (shape? (* ?x) ?s) :==> (with-shape ?x ?s))])\n\n(def universal-rules\n (concat arity-rules\n [(rule (+ (mzero? ?x) ?&*) :=> (+ ?&*))\n (rule (shape? (* (mzero? ?x) ?&*) ?s) :==> (with-shape 0 ?s))\n (rule (* (midentity? ?x) ?&*) :=> (* ?&*))\n (rule (* ?x (- ?x) ?&*) :=> (* -1 (** ?x 2) ?&*))\n (rule (** ?x 1) :=> ?x)\n (rule (** ?x 1.0) :=> ?x)\n (rule (** ?x 0.0) :=> 1)\n (rule (** ?x 0) :=> 1\n :if (guard (not= ?x 0)))\n (rule (** (** ?x ?n1) ?n2) :=> (** ?x (* ?n1 ?n2)))\n (rule (* (* ?&*) ?&*r) :=> (* ?&* ?&*r))\n (rule (+ (+ ?&*) ?&*r) :=> (+ ?&* ?&*r))\n (rule (inner-product ?&*1 (inner-product ?&*2) ?&*3)\n :=> (inner-product ?&*1 ?&*2 ?&*3))\n (rule (shape? (- (mzero? ?y) ?x) ?s) :==> (with-shape (- ?x) ?s))\n (rule (- ?x 0) :=> ?x)\n (rule (+ (* ?x ?y) (* ?z ?y) ?&*) :=> (+ (* (+ ?x ?z) ?y) ?&*)\n :if (guard (and (number? ?x) (number? ?z))))\n ]))\n\n(def eval-rules\n [(rule ?x :=> (calc-reso ?x) :if (no-symbolso ?x))\n (rule ?x :=> (compute-subexpressiono ?x))])\n\n\n(def simplify-rules\n [(rule (* ?x ?x ?&*) :=> (* (** ?x 2) ?&*))\n (rule (inverse (inverse ?x)) :=> ?x)\n (rule (shape? (inner-product ?&*1 (mzero? ?x) ?&*2) ?s)\n :==> (with-shape 0 ?s))\n (rule (shape? (inner-product ?&*1 (midentity? ?x) ?&*2) ?s)\n :==> (with-shape (inner-product ?&*1 ?&*2) ?s))\n (rule (shape? (inner-product ?&*1 ?x (inverse ?x) ?&*2) ?s)\n :==> (with-shape (inner-product ?&*1 ?&*2) ?s))\n (rule (shape? (inner-product ?&*1 (inverse ?x) ?x ?&*2) ?s)\n :==> (with-shape (inner-product ?&*1 ?&*2) ?s))\n (rule (shape? (* ?x (/ ?x) ?&*) ?s) :==> (with-shape (* ?&*) ?s))\n (rule (shape? (+ ?x (- ?x) ?&*) ?s) :==> (with-shape (+ ?&*) ?s))\n (rule (+ ?x ?x ?&*) :=> (+ (* 2 ?x) ?&*))\n (rule (+ (* ?x ?&*) (- ?x) ?&*2) :=> (+ (* ?x (- ?&* 1)) ?&*2))\n (rule (+ (* ?x ?&*) (* ?x ?&*2) ?&*3)\n :=> (+ (* ?x (+ (* ?&*) (* ?&*2))) ?&*3))\n (rule (+ (* ?x ?&*) ?x ?&*2) :=> (+ (* ?x (+ (* ?&*) 1)) ?&*2))\n (rule (- (- ?x)) :=> ?x)\n (rule (* -1 (- ?x) ?&*) :=> (* ?x ?&*))\n (rule (* ?x (** ?x ?n) ?&*) :=> (* (** ?x (+ ?n 1)) ?&*))\n (rule (** (** ?x (/ ?y)) ?y) :=> ?x)\n (rule (** (** ?x ?n) ?m) :=> ?x :if (guard (and (number? ?n) (number? ?m)\n (= (/ ?m) ?n))))\n (rule (** (sqrt ?x) 2) :=> ?x)\n (rule (** (- ?x) 2) :=> (** ?x 2))])\n\n;;the normal behaviour of (- args*) and (/ args*) is not really good for rule\n;;based translation. It is not commutative and the arguments have different\n;;meaning depending on what positions they are in the argument list.\n;;these rules are converting (- a b c) to (+ a (- b) (- c)) so that the resulting\n;;expression is easier to manipulate because only 1-ary - is there which means\n;;negation and the + expression is commutative\n\n(def to-inverses-rules\n [(rule (- ?x ?&+) :==>(+ ?x (map-sm #(- %) ?&+)))\n (rule (- (+ ?&+)) :==> (+ (map-sm #(- %) ?&+)))\n (rule (- (* ?&+)) :=> (* -1 ?&+))\n (rule (/ ?x ?&+) :==> (* ?x (map-sm #(/ %) ?&+)))])\n\n(def cancel-inverses-rules\n (concat arity-rules\n [(rule (+ (- ?x ?&+) (- ?y) ?&*) :=> (+ (- ?x ?&+ ?y) ?&*))\n (rule (+ ?x (- ?y) ?&*) :=> (+ (- ?x ?y) ?&*))\n (rule (* (/ ?x ?&+) (/ ?y) ?&*) :=> (* (/ ?x ?&+ ?y) ?&*))\n (rule (* ?x (/ ?y) ?&*) :=> (* (/ ?x ?y) ?&*))]))\n\n(declare multinomial)\n\n;;this rules are a good example for the convenience of being able to have\n;;arbitrary clojure code as the transition part of the rule\n(def multiply-out-rules\n [(rule (* (+ ?&+1) (+ ?&+2) ?&*) :==>\n (let [args1 (matcher-args ?&+1)\n args2 (matcher-args ?&+2)]\n (* ?&* (+ (seq-matcher (for [a args1 b args2] (* a b)))))))\n (rule (* (+ ?&+) ?x ?&*) :==>\n (* (+ (seq-matcher (for [a (matcher-args ?&+)] (* a ?x)))) ?&*))\n (rule (** (* ?&+) ?n) :==> (* (map-sm #(** % ?n) ?&+))\n :if (guard (integer? ?n)))\n (rule (** (** ?x ?n1) ?n2) :==> (** ?x (clojure.core/* ?n1 ?n2))\n :if (guard (integer? ?n)))\n (rule (** (+ ?&+) ?n) :==> (multinomial ?n (matcher-args ?&+))\n :if (guard (integer? ?n)))\n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*)\n :if (guard (not= 0 ?x)))\n (rule (** (/ ?a ?b) ?x) :=> (/ (** ?a ?x) (** ?b ?x)))\n (rule (** (/ ?a) ?x) :=> (/ (** ?a ?x)))\n (rule (sqrt (/ ?a ?b)) :=> (/ (sqrt ?a) (sqrt ?b)))\n]\n )\n\n(def partly-multiply-out-rules\n [(rule (* (+ ?&+1) (+ ?&+2) ?&*) :==>\n (let [args1 (matcher-args ?&+1)\n args2 (matcher-args ?&+2)]\n (* ?&* (+ (seq-matcher (for [a args1 b args2] (* a b)))))))\n (rule (* (+ ?&+) ?x ?&*) :==>\n (* (+ (seq-matcher (for [a (matcher-args ?&+)] (* a ?x)))) ?&*))\n (rule (** (* ?&+) ?n) :==> (* (map-sm #(** % ?n) ?&+))\n :if (guard (integer? ?n)))\n (rule (** (** ?x ?n1) ?n2) :==> (** ?x (clojure.core/* ?n1 ?n2))\n :if (guard (integer? ?n)))\n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*)\n :if (guard (not= 0 ?x)))\n (rule (** (/ ?a ?b) ?x) :=> (/ (** ?a ?x) (** ?b ?x)))\n (rule (** (/ ?a) ?x) :=> (/ (** ?a ?x)))\n (rule (sqrt (/ ?a ?b)) :=> (/ (sqrt ?a) (sqrt ?b)))\n]\n )\n\n(def log-solve-rules\n (with-meta\n (concat universal-rules\n eval-rules\n to-inverses-rules\n multiply-out-rules\n [(rule (+ (log ?x) (log ?y)) :=> (log (* ?x ?y)))\n (rule (- (log ?x) (log ?y)) :=> (log (/ ?x ?y)))\n (rule (log (exp ?x)) :=> ?x)\n (rule (exp (log ?x)) :=> ?x)\n (rule (exp (- ?x)) :=> (/ (exp ?x)))\n (rule (exp (+ ?&*)) :==> (* (map-sm #(exp %) ?&*)))\n (rule (exp (* (log ?x) ?&*)) :=> (** ?x (* ?&*)))])\n {:id 'log-solve-rules}))\n\n(def square-solve-rules\n (with-meta\n (concat universal-rules\n eval-rules\n to-inverses-rules\n [(rule (** (sqrt ?x) 2) :=> ?x)\n (rule (** ?x 0.5) :=> (sqrt ?x))\n (rule (** ?x (/ 2)) :=> (sqrt ?x))\n (rule (** ?x 1/2) :=> (sqrt ?x))\n (rule (** (* ?&+) ?n) :==> (* (map-sm #(** % ?n) ?&+))\n :if (guard (integer? ?n)))\n (rule (** (** ?x ?n1) ?n2) :==> (** ?x (clojure.core/* ?n1 ?n2))\n :if (guard (integer? ?n)))\n (rule (** (+ ?&+) ?n) :==> (multinomial ?n (matcher-args ?&+))\n :if (guard (integer? ?n)))\n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*)\n :if (guard (not= 0 ?x)))\n (rule (** (- ?x) 2) :=> (** ?x 2))\n (rule (* ?x ?x ?&*) :=> (* (** ?x 2) ?&*))\n (rule (/ (* ?&*)) :==> (* (map-sm #(/ %) ?&*)))\n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*))\n (rule (+ ?x (- ?x) ?&*) :=> (+ ?&*))\n (rule (+ ?x ?x ?&*) :=> (+ (* 2 ?x) ?&*))\n (rule (+ (* ?x ?&*) (- ?x) ?&*2) :=> (+ (* ?x (- ?&* 1)) ?&*2))\n (rule (+ (* ?x ?&*) (* ?x ?&*2) ?&*3)\n :=> (+ (* ?x (+ (* ?&*) (* ?&*2))) ?&*3))\n (rule (+ (* ?x ?&*) ?x ?&*2) :=> (+ (* ?x (+ (* ?&*) 1)) ?&*2))\n (rule (- (- ?x)) :=> ?x)\n (rule (* -1 (- ?x) ?&*) :=> (* ?x ?&*))\n (rule (* ?x (** ?x ?n) ?&*) :=> (* (** ?x (+ ?n 1)) ?&*))\n (rule (* (- ?x) ?&*) :=> (- (* ?x ?&*)))\n (rule (/ (* ?&*)) :==> (* (map-sm #(/ %) ?&*)))\n (rule (* (sqrt ?x) (sqrt ?y) ?&*) :=> (* (sqrt (* ?x ?y)) ?&*))\n (rule (** (* ?&*) ?x) :==> (* (map-sm #(** % ?x) ?&*)))\n (rule (** (/ ?x) ?a) :=> (/ (** ?x ?a)))\n ])\n {:id 'square-solve-rules}))\n\n)\n(defn- binom [n k]\n (let [rprod (fn [a b] (reduce * (range a (inc b))))]\n (/ (rprod (- n k -1) n) (rprod 1 k))))\n\n(defn- factorial [n]\n (loop [n (long n) acc (long 1)]\n (if (<= n 1)\n acc\n (recur (- n 1) (* acc n)))))\n\n(defn- multinomial-indices [m n]\n (if (= n 0)\n (list (repeat m 0))\n (if (= m 1)\n (list (list n))\n (for [i (range (inc n))\n j (multinomial-indices (- m 1) (- n i)) ]\n (list* i j)))))\n\n(defn- multinomial-coeff [n indices]\n (quot (factorial n) (reduce * (map factorial indices))))\n\n(defn- to-factors [args index]\n (loop [i 0 index index ret []]\n (if (= i (count args))\n ret\n (recur (inc i) (rest index)\n (cond\n (= (first index) 0) ret\n (= (first index) 1) (conj ret (nth args i))\n :else (conj ret (ex' (** ~(nth args i) ~(first index)))))))))\n\n(defn- multinomial\n \"multiplies out according to multinomial theorem\"\n [n args]\n (let [args (vec args)\n m (count args)\n indices (multinomial-indices m n)]\n (ce `+ (seq-matcher (for [index indices]\n (let [factors (seq-matcher (to-factors args index))\n coeff (multinomial-coeff n index)]\n (if (= 1 coeff)\n factors\n (ex' (* coeff factors)))))))))\n\n(def normalize-rules\n (with-meta\n (concat eval-rules universal-rules to-inverses-rules\n partly-multiply-out-rules)\n {:id :simp-expr-rules1}))\n\n(def simplify-rules\n (with-meta\n (concat universal-rules\n eval-rules simplify-rules)\n {:id :simp-expr-rules2}))\n\n(defn simp-expr\n \"simplifies the given expression according to simp-rules\"\n ([expr]\n (simp-expr expr simplify-rules))\n ([expr simp-rules]\n (->> expr \n (transform-expression normalize-rules)\n (transform-expression simp-rules))))\n\n\n\n\n(defn- infer-shape-zero-mat [sf x sl]\n (let [series (concat (matcher-args sf) [x] (matcher-args sl))]\n (if (= (count series) 1)\n x\n (let [s (filter identity [(first (shape (first series)))\n (last (shape (last series)))])]\n (if (some symbol? series)\n (zero-matrix s)\n (matrix/broadcast 0 s))))))\n\n(defn- identity-right-shape [a]\n (let [s (shape a)]\n (cond\n (empty? s) 1\n (symbol? a) (identity-matrix (first s))\n :else (matrix/identity-matrix (first s)))))\n\n\n\n\n(defn multiply-out\n \"fully multiplies the given expression out\"\n [expr]\n (transform-expression (concat universal-rules\n to-inverses-rules multiply-out-rules) expr))\n\n(defn evaluate-constants\n \"evaluates constants and constant subexpressions in expr\"\n [expr]\n (transform-expression eval-rules expr))\n\n(defn normalise\n \"normalises the expression for further manipulation with expresso\n rules.\"\n [expr]\n (transform-expression (concat universal-rules to-inverses-rules) expr))" }, { "path": "src/main/clojure/numeric/expresso/solve.clj", "content": "(ns numeric.expresso.solve\n (:refer-clojure :exclude [==])\n (:use [numeric.expresso.construct]\n [numeric.expresso.impl.polynomial]\n [numeric.expresso.protocols]\n [numeric.expresso.properties]\n [numeric.expresso.impl.pimplementation]\n [numeric.expresso.rules]\n [numeric.expresso.simplify])\n (:require [clojure.walk :as walk]\n [numeric.expresso.utils :as utils]\n [clojure.set :as set]\n [numeric.expresso.impl.symbolic :as symb]\n [clojure.core.matrix :as matrix]\n [numeric.expresso.construct :as c]))\n\n(declare contains-expr? positions-of-x surrounded-by check-solution)\n\n;;this is the namespace which implements the solving facility of expresso\n;;For code reading, I suggest starting at the solve or the solve-system\n;;functions\n\n\n;;rearrange-to-position is a useful helper function for solving strategies\n;;combine-solution is just mapcat.\n;;the position is a vector of places which subexpression contains the variable\n;;the positions are one lower than usual, because the expression operators\n;;are not counted. It uses the rearrange-step function to generate the\n;;list of possible partly rearranged equations at each step\n\n(defn rearrange-to-position\n \"rearranges the given equation until the part of the equation in pos is the\n left hand side of equation\"\n [equation pos]\n (loop [sols [(vec (rest (if (= (first pos) 1)\n (utils/swap-sides equation) equation)))]\n pos (subvec pos 1)]\n (if (seq pos)\n (recur (utils/combine-solutions\n (fn [[lhs rhs]] (rearrange-step lhs (first pos) rhs)) sols)\n (rest pos))\n (map (fn [[lhs rhs]] (ce `= lhs rhs)) sols))))\n\n;;rearrage fully rearrange the equation for the variable v provided it only\n;;occurs in the equation once\n\n(defn rearrange\n \"fully rearranges the equation to v provided there is only one occurrence of v\n in the equation\"\n [v equation]\n (when (utils/only-one-occurrence v equation)\n (if-let [pos (first (utils/positions-of v equation))]\n (rearrange-to-position equation pos)\n [equation])))\n\n;;report-res is used for the solver to convert the solutions to a suitable\n;;output for users. Returns #{} for no solutions and _0 alwaly solved\n;;returns nil if the expression couldn't be solved\n;;also normalizes the input by nil-ing NaN results and rounding to the nearest\n;;integer if appropriate\n\n\n(defn- report-res\n \"normalises the result of eq in regard to v\"\n [v eq]\n (cond\n (not (and (seq? eq) (= (expr-op eq) '=))) (report-res v (ce '= v eq))\n (empty? eq) #{}\n (= (utils/eq-lhs eq) v) (let [rhs (utils/eq-rhs eq)]\n (if (number? rhs)\n (when-not (Double/isNaN rhs)\n (if (utils/num= (utils/round rhs) rhs)\n (utils/round rhs) rhs)) rhs))\n :else (let [lhs (utils/eq-lhs eq) rhs (utils/eq-rhs eq)]\n (when (no-symbol eq)\n (if (utils/num= (evaluate lhs {}) (evaluate rhs {})) '_0 '())))))\n\n\n\n(declare solve* solve-by-simplification-rules solve-by-homogenization\n solve-by-strategy)\n\n;;following are basic solving strategies. The dispatch to the solving strategies\n;;is made by solve-by-rules\n\n;;solve factors is the easiest solving strategy. All it has to do is to solve\n;;each factor of the equation and then to combine the solutions\n(defn solve-factors\n \"solves all factors in regard to v and combines the solutions\"[v factors]\n (->> (utils/combine-solutions #(solve* v (ce `= % 0)) factors)\n (map #(ce `= v %))))\n\n;;This is the abc formula used to solve quadratic polynomials. Poly here is\n;;an instance of PolynomialExpression. See polynomial.clj for details\n\n(defn solve-quadratic\n \"solves the quadratic poly with the abc formula\"\n [v poly]\n (let [a (to-expression (to-sexp (coef poly 2)))\n b (to-expression (to-sexp (coef poly 1)))\n c (to-expression (to-sexp (coef poly 0)))]\n (mapv simp-expr\n [(ce `= v (ex' (/ (+ (- b) (sqrt (- (** b 2) (* 4 a c)))) (* 2 a))))\n (ce `= v (ex' (/ (- (- b) (sqrt (- (** b 2) (* 4 a c)))) (* 2 a))))])))\n\n(defn- try-factorise [x poly]\n (let [first-not-null\n (loop [i 0] (if (and (<= i (degree poly))\n (utils/num= (coef poly i) 0))\n (recur (inc i)) i))\n common-factor (poly-in 'x (ex (** ~x ~first-not-null)))\n [quot rem] (poly-division poly common-factor)]\n (when (utils/num= 0 rem)\n (solve-factors x [common-factor quot]))))\n\n;;if the lhs of polyeq (rhs=0 here) can be transformed to a polynomial\n;;solve the resulting polynomial depending on the degree of the polynomial\n;;also fries to factor a polynomial by guessing with ratio-root test\n\n(defn solve-polynomial\n \"solves the polynnomial equation in regard to x. tries some effort in\n factorization if the degree of the poly is higher than 2\"\n [x polyeq]\n (when-let [poly (poly-in x (transform-expression\n eval-rules (utils/eq-lhs polyeq)))]\n (let [vs (vars poly)\n deg (degree poly)]\n (when (vs x)\n (cond\n (or (= deg 0) (= deg 1)) (solve-by-simplification-rules\n x (ce '= (to-expression (to-sexp poly)) 0))\n (= deg 2) (solve-quadratic x poly)\n :else (or (let [factors (ratio-root poly)]\n (and (every? #(<= (degree %) 2) factors)\n (solve-factors x factors)))\n (try-factorise x poly)))))))\n\n(defn- simplify-eq [eq] (ce `= (simp-expr (nth eq 1)) (nth eq 2)))\n\n(defn- simplify-rhs [eq] (ce `= (nth eq 1) (simp-expr (nth eq 2))))\n\n(defn- check-if-can-be-rearranged [v eq]\n (when (utils/only-one-occurrence v eq) eq))\n\n;;Basic solving strategy. Simplifies the expression and checks if the number\n;;of occurrences of the variable are reduced to one. It it is so then the\n;;equation can be rearranged and the rhs simplified to get the solution\n\n(defn solve-by-simplification-rules\n \"tries to solve the expr in regard to v by applying simplification rules and\n rearranging the expression to the remaining occurrence of v\"\n [v expr]\n (some->> expr\n simplify-eq\n (check-if-can-be-rearranged v)\n (rearrange v)\n (map simplify-rhs)))\n \n;;the expresso solve is extensible - the actual solving mechanism are nothing\n;;but rules which get applied for solving. Here the rules pattern is a vector\n;;of [variable expression] \n(def ^:dynamic solve-rules\n [(rule [?v (ex (= (* ?&*) (mzero? ?x)))]\n :==> (solve-factors ?v (matcher-args ?&*)))\n (rule [?v ?x] :==> (solve-polynomial ?v ?x))\n (rule [?v ?x] :==> (solve-by-simplification-rules ?v ?x))\n (rule [?v ?x] :==> (solve-by-homogenization ?v ?x))\n (rule [?v ?x] :==> (solve-by-strategy ?v ?x))])\n\n(defn apply-solve-rules\n \"solves the expr in regard to v by applying the rules in solve-rules\"\n [v expr]\n (let [res (apply-rules solve-rules [v expr])]\n (when (not= res [v expr])\n res)))\n\n;;reports all the solutions in sols by calling report-res and filtering\n;;out empty solutions and normalizing to _0 if one solution is arbitraty\n\n(defn- report-solution\n \"report the solutions in regard to v. Does some normalisation like returning\n #{} or _0\"\n [v sols]\n (when sols\n (->> sols\n (mapv #(report-res v %))\n (filter identity)\n (remove #{'()})\n (into #{})\n (#(if (some #{'_0} %)\n '_0\n %)))))\n \n\n(defn- transform-one-level-lhs [rules eq]\n (ce `= (transform-one-level rules (nth eq 1)) (nth eq 2)))\n\n(def ^:dynamic *solve-attempts*)\n(def ^:dynamic *symbolv*)\n\n;;The top level solve method. Also includes a security mechanism to avoid\n;;infinite loops when solving strategies recursively call solve.\n;;*solve-attempts* stores the expressions with witch solve* is called and\n;;solve* checks if the equation if wants to solve was tried before and gives up\n;;in this case\n\n(defn solve\n \"solves the equation in regard to the variable v. An optional custom set of\n solve rules can be specified\"\n ([v equation]\n (solve v equation solve-rules))\n ([v equation custom-solve-rules]\n (binding [*solve-attempts* (atom #{})\n *symbolv* (gensym \"var\")\n solve-rules custom-solve-rules]\n (solve* v equation))))\n\n(defn- check-if-was-solved [v equation]\n (if (not (and (bound? #'*symbolv*) (bound? #'*solve-attempts*)))\n equation\n (let [eq (substitute-expr equation {v *symbolv*})]\n (when-not (some #{eq} @*solve-attempts*)\n (swap! *solve-attempts* #(set/union % #{eq}))\n equation))))\n\n(defn- lhs-rhs=0 [equation]\n (ce `= (ce `- (nth equation 1) (nth equation 2)) 0))\n\n;;to solve the equation first check-if it is solved already and short-track in\n;;this case.\n;;otherwise make the rhs to zero, normalize it and apply-the solving rules which\n;;dispatch to the appropriate solving strategies and reports the solutions\n(defn- solve* [v equation]\n (if (utils/solved? v equation)\n (report-solution v [(simplify-rhs equation)])\n (some->> equation\n (check-if-was-solved v)\n lhs-rhs=0\n (transform-one-level-lhs universal-rules)\n (apply-solve-rules v)\n (report-solution v)))) \n\n;;code for solving a linear system. These helper functions are used to construct\n;;a matrix of a system of simultaneous equations\n\n(defn- poly-const [poly]\n (cond (number? poly) poly\n (number? (coef poly 0)) (coef poly 0)\n :else (poly-const (coef poly 0))))\n\n(defn- lhs-to-poly [eq]\n (let [lhs (nth eq 1) rhs (nth eq 2)\n polylhs (to-poly-normal-form (ex (- ~lhs ~rhs)))]\n (when polylhs\n (let [const (poly-const polylhs)\n nlhs (to-poly-normal-form (ex (- ~polylhs ~const)))]\n (ex (= ~nlhs ~(* -1 const)))))))\n\n(defn- search-coef [lhs v]\n (cond (number? lhs) 0\n (var= (main-var lhs) v) (when (<= (degree lhs) 1) (coef lhs 1))\n (not (var> (main-var lhs) v)) (search-coef (coef lhs 0) v)\n :else 0))\n\n(defn- to-vec [pos-coeffs]\n (->> pos-coeffs (sort-by first) (mapv second)))\n\n(defn- collect-params [eq vars]\n (let [lhs (nth eq 1)\n rhs (nth eq 2)]\n (ce `= (to-vec (for [[p v] vars]\n [p (search-coef lhs v)])) rhs)))\n\n(defn- build-matrix [eqs]\n (mapv #(conj (vec (nth %1 1)) (nth %1 2)) eqs))\n\n(defn- simp-sols [sols]\n (cond (= '() sols) sols\n (some expr-op sols) (mapv simp-expr sols)\n :else sols))\n\n(defn- add-needed-vars* [vs eqs]\n (let [eqv (map (fn [a] [a (vars a)]) eqs)\n needed-vars (filter identity\n (map (fn [a]\n (if (some vs (second a))\n (set/difference (second a) vs))) eqv))]\n (into #{} (concat vs (apply set/union needed-vars)))))\n\n(defn- add-needed-vars [vs eqs]\n (loop [vs vs]\n (let [nvs (add-needed-vars* vs eqs)]\n (if (= nvs vs)\n nvs\n (recur nvs)))))\n\n(defn- to-map [vars v]\n (if (empty? v)\n {}\n (into {} (map (fn [[pos var]] [var (nth v pos)]) vars))))\n\n(defn- remove-unneeded-equations [vs eqv]\n (map first (filter #(some vs (second %)) (map (fn [x] [x (vars x)]) eqv))))\n\n(defn- check-if-linear [matrix]\n (when (and \n (> (matrix/ecount matrix) 0)\n (matrix/numerical? matrix)) \n matrix))\n\n(defn- check-if-poly [v]\n (when-not (some nil? v)\n v))\n\n;;solve-linear-system can solve a system of linear equations if a matrix can\n;;be built to represent the set of equations and the matrix contains only\n;;numbers. If this is the case, the matrix is solved using the fraction-free\n;;gaussian elimination algorithm. Notice the use of some->> which makes the\n;;solving strategy fail early if it detects it can't solve the system and\n;;a more general solving strategy has to be used instead.\n\n(defn solve-linear-system\n \"solves a system of equations for the variables in the variable vector\"\n [vars eqv]\n (let [v (into #{} vars)\n vs (add-needed-vars v eqv)\n vars (into {} (concat (map vector (range) vars)\n (map vector (range (count v) (+ (count vars) (count vs)))\n (set/difference vs v))))]\n (some->> eqv\n (map lhs-to-poly)\n check-if-poly\n (remove-unneeded-equations vs)\n (map #(collect-params % vars))\n build-matrix\n check-if-linear\n symb/ff-gauss-echelon\n symb/report-solution\n simp-sols\n (to-map vars)\n (utils/submap v)\n vector\n set)))\n\n(declare solve-general-system*)\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n;;utilities for solve-general-system start reading solve-general-system\n(defn- not-in-existing-sols [sol-map var-set]\n (into #{} (remove sol-map var-set)))\n\n(defn- solve-for-dependencies [existing-sols depends-on other-eqs vs]\n (reduce (fn [[sols rem-eqs] r]\n (let [[ss rem-eqs] (solve-general-system* r rem-eqs sols depends-on)]\n [(for [l sols s ss]\n (merge l s)) rem-eqs]))\n [existing-sols other-eqs] depends-on))\n\n(defn- solve-with-dependencies [other-sols v equation-containing-v]\n (utils/combine-solutions\n (fn [os]\n (let [equation-without-deps (substitute-expr\n (first equation-containing-v)\n os)\n sol (solve v equation-without-deps)]\n (if (= sol '_0)\n [os]\n (for [s sol]\n (assoc os v s))))) other-sols))\n\n(defn- equation-with-minimal-dependencies [eqs v]\n (let [eqv (map (fn [a] [a (vars a)]) eqs)\n containing-v (filter #(contains? (second %) v) eqv)\n minimal-deps (sort-by (comp count second) containing-v)]\n minimal-deps))\n\n;;solves the general-system via substitution for a variable v.\n;;first, the equation which contains v is searched for in the set.\n;;If it was found, then recursively all its dependencies (the other variables\n;;the equation contains) have to be solved with the remaining equations.\n;;The solutions for the other variables then have to be combined so that\n;;there is one solution map for each possible 'combination' of solutions.\n;;with this solutions of the dependencies the equation can be solved for\n;;the variable v.\n\n(defn- solve-general-system*\n ([v eqs vs] (solve-general-system* v eqs [{}] vs))\n ([v eqs existing-sols vs]\n (if (v (first existing-sols))\n [existing-sols eqs]\n ;;v is variable and eqs set of equations\n ;;don't be hard on choice of equation-containing-v here\n ;;try first with equation introducing minimal dependencies\n ;;if this doesn't add solutions then try next best guess\n (loop [equations-containing-v (equation-with-minimal-dependencies eqs v)]\n (if (seq equations-containing-v)\n (let [equation-containing-v (first equations-containing-v)\n depends-on (not-in-existing-sols\n (first existing-sols)\n (set/difference (second equation-containing-v)\n #{v}))\n other-eqs (set/difference eqs #{(first equation-containing-v)})\n [deps rem-eqs] (solve-for-dependencies\n existing-sols depends-on other-eqs vs)\n ret (set (solve-with-dependencies deps v equation-containing-v))]\n (if (and (not (empty? depends-on)) (= deps existing-sols)\n (and (not (empty? ret)) (empty? (set/difference (vars (v (first ret)))\n vs)))) ;;todo schreib hier dass entweder abhängig von nichts oder wenn dass abhängigkeiten von anderen variablen für die gelöst wird da nicht nur sind\n (recur (rest equations-containing-v))\n [ret\n rem-eqs]))\n [existing-sols eqs])))))\n\n(defn- remove-dependency [solm expr symb]\n (-> (substitute-expr expr {symb (get solm symb)})\n simp-expr))\n\n(defn- remove-dependencies [symbv m]\n (let [symbs (into #{} symbv)]\n (into {}\n (reduce (fn [kv-pairs [k v]]\n (if (contains? symbs k)\n (let [depends-on\n (set/difference (set/intersection (vars v) symbs)\n #{k})]\n (conj kv-pairs\n [k (reduce (partial remove-dependency m)\n v depends-on)]))\n (conj kv-pairs [k v]))) [] m))))\n\n;;solve-general-system solves a system of equations according to the symbols\n;;in symbolv. Output is a set of maps in the form {v res ....}.\n;;The algorithm is the following\n;;for each variable in symbv, solve the system for it using solve-general-system*\n;;solve-general-system returns a solution set in the format like outlined\n;;above. Because it may have solved for other variables first in order to solve\n;;for the desired value the returned maps can contain also the solutions to\n;;symbols for which solve-general-system hasn't jet solved. Therefore there\n;;is the check in the reduce operation, if the current solution already has\n;;solved for the symbol. If not it solves for the symbol and combines the\n;;existing solutions and the new-solutions with merging.\n;;after that it removes the dependencies of the symbols in symbv from the\n;;solutions in the solution maps. For example if #{{'x 'y 'y 1}} is the solution\n;;remove dependency will remove the dependency on 'y on the solution of 'x and\n;;return #{{'x 1 'y 1}}\n\n;;TODO it currently fails on some solvable systems because it doesn't check\n;;whether it has searched for the system before and doesn't inline equations\n;;which don't introduce new symbols to the equation\n(defn solve-general-system\n \"solves the system of equations for the symbols in symbv by general\n substitution\"\n [symbv eqs]\n (let [eqs (into #{} eqs)\n vs (into #{} symbv)]\n (->> (map #(utils/submap (into #{} symbv) %1)\n (first\n (reduce (fn [[ls rem-eqs] r]\n (if (r (first ls))\n [ls rem-eqs]\n (let [[ss rem-eqs] (solve-general-system* r rem-eqs ls vs)]\n [(for[l ls s ss]\n (merge l s)) rem-eqs]))) [[{}] eqs] symbv)))\n (map #(remove-dependencies symbv %))\n (into #{}))))\n\n;;solve-system wil also be ported to a rule-based dispatch like solve, but for\n;;now it only has two methods, namely solve-linear-system and\n;;solve-general-system. Notice here the convention of returning nil to indicate\n;;failure.\n\n(defn solve-system\n \"solves the system of equations in regard to the symbols in symbv\"\n [symbv eqs]\n (if-let [erg (solve-linear-system symbv eqs)]\n erg (solve-general-system symbv eqs)))\n\n\n(defn- split-in-pos-args [args pos]\n (let [args (vec args)]\n [(subvec args 0 pos) (nth args pos) (subvec args (inc pos))]))\n\n\n;;Now comes the actual implementations of the rearranging process with the\n;;supplied methods to the multimethod rearrange-step-function which is\n;;called by the default expression implementation of the rearrange-step protocol\n;;function. The arguments of the function are the operator, its arguments\n;; (which together constitute the actual lhs of the equation)\n;;the position in the args which contains the term to rearrange to and the\n;;current rhs of the equation\n\n(defmethod rearrange-step-function '+ [[op args pos rhs]]\n (let [[left x right] (split-in-pos-args args pos)]\n [[x (cev '- (concat [rhs] left right))]]))\n\n(defmethod rearrange-step-function '- [[op args pos rhs]]\n (if (= (count args) 1)\n [[(first args) (ce '- rhs)]]\n (let [[left x right] (split-in-pos-args args pos)]\n [[x (if (= pos 0)\n (cev '+ (concat [rhs] right))\n (cev '- (concat left right [rhs])))]])))\n\n(defmethod rearrange-step-function '* [[op args pos rhs]]\n (let [[left x right] (split-in-pos-args args pos)]\n [[x (cev '/ (concat [rhs] left right))]]))\n\n(defmethod rearrange-step-function '/ [[op args pos rhs]]\n (if (= (count args) 1)\n [[(first args) (ce '/ rhs)]]\n (let [[left x right] (split-in-pos-args args pos)]\n [[x (if (= pos 0)\n (cev '* (concat [rhs] right))\n (cev '/ (concat left right [rhs])))]])))\n\n\n(defn unary-rearrange-step [op invop args rhs]\n [[(first args) (ce invop rhs)]])\n\n(defmethod rearrange-step-function 'sin [[op args pos rhs]]\n (unary-rearrange-step 'sin 'asin args rhs))\n\n(defmethod rearrange-step-function 'asin [[op args pos rhs]]\n (unary-rearrange-step 'asin 'sin args rhs))\n\n(defmethod rearrange-step-function 'cos [[op args pos rhs]]\n (unary-rearrange-step 'cos 'acos args rhs))\n\n(defmethod rearrange-step-function 'acos [[op args pos rhs]]\n (unary-rearrange-step 'acos 'cos args rhs))\n\n(defmethod rearrange-step-function 'tan [[op args pos rhs]]\n (unary-rearrange-step 'tan 'atan args rhs))\n\n(defmethod rearrange-step-function 'atan [[op args pos rhs]]\n (unary-rearrange-step 'atan 'tan args rhs))\n\n(defmethod rearrange-step-function 'exp [[op args pos rhs]]\n (unary-rearrange-step 'exp 'log args rhs))\n\n(defmethod rearrange-step-function 'log [[op args pos rhs]]\n (unary-rearrange-step 'log 'exp args rhs))\n\n(defmethod rearrange-step-function '** [[op args pos rhs]]\n (if (= pos 0)\n (let [nrhs (ce '** rhs (ce '/ (second args)))]\n (if (and (number? (second args)) (even? (second args)))\n [[(first args) nrhs]\n [(first args) (ce '- nrhs)]]\n [[(first args) nrhs]]))\n [[(second args) (ce '/ (ce 'log rhs) (ce 'log (first args)))]]))\n\n(defmethod rearrange-step-function 'inner-product [[op args pos rhs]]\n (let [[left x right] (split-in-pos-args args pos)]\n [[x (cev 'inner-product (concat (reverse (map #(ce 'inverse %) left))\n [rhs]\n (reverse (map #(ce 'inverse %) right))))]]))\n\n(defmethod rearrange-step-function 'sqrt [[op args pos rhs]]\n [[(first args) (ce '** rhs 2)]])\n\n(defmethod rearrange-step-function 'abs [[op args pos rhs]]\n [[(first args) rhs]\n [(first args) (ce '- rhs)]])\n\n\n;;now comes the part where more sophisticated solving strategies are defined\n;;go ahead to solve-by-homogenization and solve-by-strategy\n\n\n(construct-with [+ * ** exp log / - sin cos]\n\n(def sem-rewrite-rules\n [(rule [(** ?a (* ?x ?&+)) (** ?a ?x)]\n :=> (** (** ?a ?x) (* ?&+)))\n (rule [(** ?a (- ?x)) (** ?a ?x)]\n :=> (/ (** ?a ?x)))\n (rule [(** ?a (+ ?x ?&*)) (** ?a ?x)]\n :=> (* (** ?a ?x) (** ?a (+ ?&*))))\n (rule [(** ?a ?x) (exp ?x)]\n :=> (exp (* ?x (log ?a))))\n (rule [(** ?a (* ?x ?&*)) (exp ?x)]\n :=> (exp (* (log ?a) ?&*)))\n (rule [(exp (+ ?x ?&*)) (exp ?x)]\n :=> (* (exp ?x) (exp (+ ?&*))))\n (rule [(exp (* ?x ?&+)) (exp ?x)]\n :=> (** (exp ?x) (* ?&+)))\n (rule [(exp (- ?x)) (exp ?x)]\n :=> (/ (exp ?x)))\n (rule [(** ?x ?b) (** ?x ?c)]\n :==> (** (** ?x ?c) (clojure.core// ?b ?c))\n :if (guard (and (number? ?b) (number? ?c) (> ?b ?c))))\n (rule [(** (sin ?x) 2) (cos ?x)]\n :=> (- 1 (** (cos ?x) 2)))\n (rule [(** (cos ?x) 2) (sin ?x)]\n :=> (- 1 (** (sin ?x) 2)))]))\n\n;;rewrite-in-terms-of rewrites the expression according to the sem-rewrite-rules.\n;;each rule matches a vector of two elements like this:\n;;[actual-expression subs-to-rewrite-to] and return the modified expression.\n;;an example if the sem-rewrite rule of transforming (exp (* 2 ?x)) to\n;; (** (exp ?x) 2) when rewriting for (exp ?x):\n;; (rule [(exp (* ?x ?&+)) (exp ?x)] :=> (** (exp ?x) (* ?&+)))\n\n(defn rewrite-in-terms-of\n \"rewrites expr to an expression containing as much as possible occurrences\n of x\"\n [expr x]\n (transform-expression\n (with-meta\n (concat arity-rules\n [(rule ?x :==> (let [res (apply-rules sem-rewrite-rules [?x x])]\n (when-not (= res [?x x]) res)))])\n {:id :rewrite-in-terms-of-rules})\n expr))\n;;semantic substitution of an expression works with rewrite-rules which transform\n;;the expression to expressions in terms of the substituend. In this rewritten\n;;expression the actual substitution is then done.\n\n(defn sem-substitute\n \"semantically substitutes old for new in expr. First transforms expr in terms\n of old before substitution\"\n [expr old new]\n (-> expr\n (rewrite-in-terms-of old)\n (substitute-expr {old new})))\n\n;;prefilter the expr for offendersm basically +*-/ can be solved normally so\n;;they are not included in the offenders. The same counts for numbers. The rest\n;;is included in the offenders list.\n(defn- offenders [x expr]\n (apply-rules\n [(rule (ex (+ ?&*)) :==> (mapcat #(offenders x %) (matcher-args ?&*)))\n (rule (ex (* ?&*)) :==> (mapcat #(offenders x %) (matcher-args ?&*)))\n (rule (ex (- ?&*)) :==> (mapcat #(offenders x %) (matcher-args ?&*)))\n (rule (ex (/ ?a ?b)) :==> (offenders x ?a) :if\n (guard (is-number? ?b)))\n (rule (ex (** ?a ?b)) :==> (offenders x ?a) :if\n (guard (and (number? ?b) (< ?b 3))))\n (rule ?x :=> [] :if (guard (is-number? ?x)))\n (rule ?x :=> [?x])]\n expr))\n\n(defn- **-heuristic [x eq offenders]\n (and (every? #(= (expr-op %) '**) offenders)\n (every? #{(second (first offenders))} (map second offenders))\n (ce '** (second (first offenders)) x)))\n\n(defn- exp-heuristic [x eq offenders]\n (and (every? #(= (expr-op %) 'exp) offenders)\n (ce 'exp x)))\n\n(defn- sin-heuristic [x eq offenders]\n (and (every? #(= (expr-op %) 'sin) offenders)\n (every? #{(second (first offenders))} (map second offenders))\n (ce 'sin (second (first offenders)))))\n\n(defn- trig-heuristic [x eq offenders]\n (and (every? #(or (= (expr-op %) 'cos)\n (= (expr-op %) 'sin)\n (and\n (= (expr-op %) '**)\n (utils/num= (nth % 2) 2)\n (or (= (expr-op (nth % 1)) 'sin)\n (= (expr-op (nth % 1)) 'cos)))) offenders))\n (if (contains-expr? eq (rule (ex (** (sin ?x) 2)) :=> true))\n (ex (cos x))\n (if (contains-expr? eq (rule (ex (** (cos ?x) 2)) :=> true))\n (ex (sin x))\n (some (fn [x] (if (= (expr-op x) 'sin) 'sin\n (if (= (expr-op x) 'cos) 'cos))) offenders))))\n\n(defn- poly-heuristic [x eq offenders ]\n (let [r (rule (ex (** ?x ?y)) :=> (ex (** ?x ?y)) :if (guard (number? ?y)))\n pos (utils/positions-of x eq)\n off (map #(surrounded-by eq % r) pos)\n off (map #(poly-in x (first %)) off)]\n (and (not (empty? off)) (every? identity off)\n (let [m (apply max (map degree off))]\n (when (> m 2)\n (ce '** x (if (> (- m 2) 1) (- m 2) (- m 1))))))))\n\n(def substitution-candidate-heuristics\n [**-heuristic\n exp-heuristic\n sin-heuristic\n trig-heuristic\n poly-heuristic])\n\n;;makes a list of substitution candidates which could transform the expression\n;;after semantic substitution to a known form which can be solved.\n;;like many of expressos functions, it is datadriven from the functions in the\n;;substitution-candidate-heuristics which get the variable, the expression and\n;;a prefilterd list of offenders (terms which stand in the way of solving\n;;normally (like exp and (** ?x 4) ,....) and return a substitution candidate\n\n(defn- substitution-candidates [x equation offenders]\n (filter identity (map #(%1 x equation offenders)\n substitution-candidate-heuristics)))\n\n;;solve the equation lhs=0 for the variable x with the given substitution by\n;;semantic substitution and combining the solutions of the subsituted expression\n;;with the solutions of the equation (= subs > lhs (offenders x ) (substitution-candidates x equation) last)]\n (solve-by-substitution x lhs subs)))\n\n;;now multiple strategy solving functions are specified, like solve-fractions,\n;;solve-logarithms and so on. They are dispatched by solve-by-strategy.\n;;See the function documentation for details\n\n(defn- multiply-equation [eq factor]\n (ce '= (ce '* (nth eq 1) factor) (ce '* (nth eq 2) factor)))\n\n\n(defn surrounded-by\n \"returns [res-of-rule-application position] when the rule is succesfully\n applied at a prefix of pos\"\n [equation pos rule]\n (loop [n (count pos)]\n (if (> n 0)\n (if-let [res (apply-rule rule (utils/get-in-expression equation\n (subvec pos 0 n)))]\n [res (subvec pos 0 n)]\n (recur (dec n))))))\n\n\n;;solve-logarithms and solve-square-roots have very similar algorithms.\n;;both get all positions of terms which are enclosed by their offending\n;;term. For each position, they rearrange the term to the position, that means\n;;until the expression has the form (in case of square-root)\n;;(ex (= (sqrt term-of-x) rhs)). It then eliminates this occurrence of the\n;;offending term by square or exp operations. It recursively elimininates the\n;;other occurrences as well and solves the resulting equation which does\n;;not contain x-ses enclosed by the offending term any more.\n;;each function has own rules to be used in the elimination step to make sure\n;;the elimination is done most effectively.\n\n(defn solve-logarithms\n \"eliminates all logarithms in eq and solves the resulting equation for x\"\n [x eq]\n (loop [equation (transform-expression log-solve-rules eq)]\n (let [positions (utils/positions-of x equation)\n r (rule (ex (log ?x)) :=> ?x)\n log (some #(surrounded-by equation % r) positions)]\n (if-let [[x pos] log]\n (let [rearr (first (rearrange-to-position equation pos))]\n (recur (transform-expression\n log-solve-rules\n (ce '= (ce 'exp (nth rearr 1)) (ce 'exp (nth rearr 2))))))\n (set (filter #(check-solution x eq %) (solve* x equation)))))))\n\n(defn solve-square-roots\n \"eliminates all square roots and solves the resulting equation for x\"\n [x equation]\n (let [positions (utils/positions-of x equation)\n r (rule (ex (sqrt ?x)) :=> true)]\n (loop [sqrts (filter identity (map #(surrounded-by equation % r) positions))\n equation equation i 0]\n (if (and (empty? sqrts) (< i 10))\n (solve* x equation)\n (let [[_ pos] (first sqrts)\n rearr (first (rearrange-to-position equation pos))\n new-equation (transform-expression\n (with-meta square-solve-rules {:id 'morssqrt})\n (ce '= (ce '** (nth rearr 1) 2)\n\t\t\t\t (ce '** (nth rearr 2) 2)))]\n (recur (filter identity (map #(surrounded-by new-equation % r)\n (utils/positions-of x new-equation)))\n new-equation (inc i)))))))\n\n(defn- square-number [a]\n (let [sq (Math/sqrt ^long a)]\n (utils/num= sq (Math/floor sq))))\n\n(def fraction-rules\n (construct-with [+ - * / **]\n (concat universal-rules\n to-inverses-rules\n eval-rules\n [(rule (/ (* ?&*)) :==> (* (map-sm #(/ %) ?&*)))\n (rule (/ (+ (** ?x 2) ?a))\n :==> (let [sqrt (long (Math/sqrt ^long (clojure.core/- ?a)))]\n (* (/ (+ ?x sqrt)) (/ (- ?x sqrt))))\n :if (guard (and (integer? ?a) (< ?a 0)\n (square-number (clojure.core/- ?a)))))])))\n\n\n(def cancel-fraction-rules\n (construct-with [+ - * / **]\n (concat universal-rules\n to-inverses-rules\n eval-rules\n [(rule (* (+ ?&*1) ?&*2) :==> (+ (map-sm #(* ?&*2 %) ?&*1)))\n (rule (* ?x (/ ?x) ?&*) :=> (* ?&*))])))\n\n(declare multiply-equation)\n\n;;solve-fractions removes all fractions from the equation and then solves the\n;;resulting polynomial. It gets all the positions where a x-containing term\n;;is enclosed in a fraction in the equation (after preprocessing with\n;;fraction rules to ensure for example the denominator has the form (/ term-of-x)\n;;Then all the denomiator are collected, their common-factor is calculated\n;;(simple-identities like (- (** x 2) 9) are factored out by the rules)\n;;and then the equation is multiplied by the factor and transformed with the\n;;cancel-fraction-rules, which take care that the factor descends far enough\n;;into the equation to cancel out all fractions.\n;;Befor the canceling step all the factors are substituted in the expression, so\n;;that the cancel-fraction-rules do not influence them, and resubstituted\n;;afterwards. If the positions of the unknown are succesfully eliminated by\n;;the procedure, it solves the resulting (polynomial) eqaution.\n\n(defn solve-fractions\n \"eliminates all fractions and solves the resulting equation for x\"\n [x equation]\n (loop [equation (transform-expression fraction-rules equation)]\n (let [positions (utils/positions-of x equation)\n r (rule (ex (/ ?x)) :=> ?x)\n frac (filter identity (map #(surrounded-by equation % r) positions))\n varmap (into {} (map (fn [[exp pos]] [exp (gensym \"var\")]) frac))\n symbal (doall (map (fn [frac] [(get varmap (first frac)) frac])\n (into #{} frac)))\n rsymbm (into {} (map (fn [[k v]] [k (first v)]) symbal))\n symbm (into {} (map (fn [[x y]] [(concat (second y) [0]) x]) symbal))\n factor (cev '* (into #{} (map first symbal)))\n without-fractions\n (as-> equation x\n (utils/substitute-in-positions x symbm)\n (multiply-equation x factor)\n (transform-expression cancel-fraction-rules x)\n (substitute-expr x rsymbm))]\n (when-not (some #(surrounded-by without-fractions % r)\n (utils/positions-of x without-fractions))\n (into #{} (filter #(check-solution x equation %)\n (solve* x without-fractions)))))))\n\n;;if the x-ses are enclosed in abs functions, this method creates all the\n;;possible equations with abs removed, by replacing each abs by two equations\n;;where the abs term is replaced by a plus or minus term respectively.\n;;These resulting equations are then solved and their results checked\n;;(because not all combinations return valid results). The checking currently\n;;is of limited use when the abs-terms have variables in it. In this case\n;;the solving method can create false positives. To eliminate this one would have\n;;to be able to make analysis on which part of the number spectrum are the terms\n;;negative, positive, or zero and create the expression based on that knowledge\n;;This is currently out of scope.\n\n\n(defn solve-abs\n \"removes the abs terms in the equation, solves the resulting equations for x\n and checks the results\"\n [x equation]\n (let [positions (utils/positions-of x equation)\n r (rule (ex (abs ?x)) :=> true)\n sb (some #(surrounded-by equation % r) positions)]\n (loop [equations [equation]]\n (if (some (fn [eq] (some #(surrounded-by eq % r)\n (utils/positions-of x eq)))\n equations)\n (recur\n (mapcat (fn [eq]\n (if-let [[_ pos] (some #(surrounded-by eq % r)\n (utils/positions-of x eq))]\n (let [abs (utils/get-in-expression eq pos)]\n [(substitute-expr eq {abs (nth abs 1)})\n (substitute-expr eq {abs (ce '- (nth abs 1))})])\n [eq])) equations))\n (set (filter #(check-solution x equation %) (mapcat #(solve* x %)\n equations)))))))\n\n;;solve-common-prefix is a very useful strategy when there are multiple\n;;occurrences of the variable, but all the occurrences are in one part of the\n;;equation (their positions have a common prefix). This is the case in\n;;(ex (= (** 100 (+ (** x 2) (* 3 x) 4)) 5)) for example, where all occurences\n;;of x are in the (** 100 ....) term.\n;;If this is detected, the root of all positions of x is substituted in the\n;;expression and then solved. In the example this would be:\n;;solve (ex (= (** 100 v) 5)) and then solve (ex (= (+ (** x 2) (* 3 x) 4) ~erg))\n\n(defn- solve-common-prefix [positions equation]\n (if (> (count positions) 1)\n (let [cp (utils/common-prefix positions)]\n (if (> (count cp) 2)\n (let [s (utils/get-in-expression equation cp)]\n (fn [x eq]\n (solve-by-substitution x (nth eq 1) s)))))))\n\n(def strategy-choose-heuristics\n [solve-common-prefix\n (fn [positions equation]\n (let [r (rule (ex (sqrt ?x)) :=> true)]\n (if (some #(surrounded-by equation % r) positions)\n solve-square-roots)))\n (fn [positions equation]\n (let [r (rule (ex (abs ?x)) :=> true)]\n (if (some #(surrounded-by equation % r) positions)\n solve-abs)))\n (fn [positions equation]\n (let [r1 (rule (ex (/ ?x)) :=> ?x)\n r2 (rule (ex (/ ?x ?y)) :=> true)]\n (if (or (some #(surrounded-by equation % r1) positions)\n (some #(surrounded-by equation % r2) positions))\n solve-fractions)))\n (fn [positions equation]\n (let [r (rule (ex (log ?x)) :=> ?x)]\n (if (some #(surrounded-by equation % r) positions)\n solve-logarithms)))\n ])\n\n\n(defn- position-strategy [positions equation]\n (some identity (map #(%1 positions equation) strategy-choose-heuristics)))\n\n;;solve-by-strategy dispatches to solvers depending where x is in the\n;;equation. These heuristics are again stored in a vector for extensibility.\n;;The central helper function here is surrounded-by, which gets the positions\n;;of x in the equation and works them up. At each stage it applies the given\n;;rule and if it succeeds, returns the result+position. This way the\n;;heuristics can determine whether the occurrences of x are inside a square root\n;;for example. solve-by-strategy then dispatches to the right strategy which\n;;inturn eliminates all occurences of its offending term and solves the resulting\n;;equation. In case of square roots as surrounding terms, the square roots are\n;;recursively eliminated and the resulting equation (which is in the normal case\n;;a polynomial) is solved\n\n(defn solve-by-strategy\n \"solves equation with a strategy choosen by the positions of x and the terms\n surrounding them in regard to x\"\n [x equation]\n (let [positions (utils/positions-of x equation)\n strategy (position-strategy positions equation)]\n (if strategy\n (strategy x equation))))\n\n\n(defn check-solution\n \"checks if solution is a solution to equation for x.\n Does not work for solutions containing variables.\"\n [x equation solution]\n (try\n (if-not (empty? (vars solution))\n true\n (when-let [x (solve* (gensym \"var\")\n (substitute-expr equation {x solution}))]\n (not (= x #{}))))\n (catch Exception e nil)))\n\n\n(defn- contains-expr?\n \"checks is r is applicable on some subexpression of expr\"\n [expr r]\n (or (and (not= expr (apply-rules [r] expr))\n (apply-rules [r] expr))\n (some #{true}\n (flatten (transform-expression [r] expr)))))\n" }, { "path": "src/main/clojure/numeric/expresso/types.clj", "content": "(ns numeric.expresso.types\n (:refer-clojure :exclude [== long double record?])\n (:use [clojure.test]\n [clojure.core.logic.protocols]\n [clojure.core.logic :exclude [is]])\n (:require \n [clojure.set :as set]\n [clojure.core.matrix :as mat]\n [clojure.walk :as walk]))\n\n(def matrix ::matrix)\n(def number ::number)\n(def integer ::integer)\n(def long ::long)\n(def double ::double)\n\n\n\n(derive integer number)\n(derive long number)\n(derive double number)" }, { "path": "src/main/clojure/numeric/expresso/utils.clj", "content": "(ns numeric.expresso.utils\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic.protocols]\n [clojure.core.logic :exclude [is] :as l]\n [numeric.expresso.protocols]\n [numeric.expresso.impl.pimplementation]\n clojure.test)\n (:require [clojure.core.logic.fd :as fd :exclude [record?]])\n (:require [clojure.walk :as walk])\n (:require [clojure.core.logic.unifier :as u :exclude [record?]]))\n\n(def debug-mode true)\n\n(defmacro debug\n \"debugging macro fore core.logic\"\n [vars & message]\n `(project ~vars\n (do (when debug-mode\n (prn ~@message)) (== 1 1))))\n\n(defn mapo\n \"core.logic version of map\"\n [fo vs rs]\n (conda\n [(emptyo vs) (emptyo rs)]\n [(fresh [v r restvs restrs]\n (conso v restvs vs)\n (conso r restrs rs)\n (fo v r)\n (mapo fo restvs restrs))]))\n\n(defn lifto-with-inverse\n \"Lifts a unary function and its inverse into a core.logic relation.\"\n ([f g]\n (fn [& vs]\n (let [[x y] vs]\n (conda \n [(pred x number?) (project [x] (== y (f x)))]\n [(pred y number?) (project [y] (== x (g y)))])))))\n\n\n(defn constant?\n \"checks whether expr is constant\"\n [expr]\n (number? expr))\n\n\n(defn resolve-opo \n \"Resolves an operator to an actual function\"\n ([op resolved-fn]\n (fresh []\n (project [op]\n (== resolved-fn @(resolve op)))))) \n\n(defn applyo \n \"Applies a logic function to a set of parameters.\"\n ([fo params result]\n (fresh []\n (project [params]\n (apply fo (concat params (list result)))))))\n\n\n(defn inco\n \"core.logic non-relational inc\"\n [a res]\n (project [a]\n (== res (inc a))))\n\n\n\n\n(defn without-symbol?\n \"true if expr does not have any occurrences of sym\"\n [sym expr]\n (cond\n (and (symbol? expr) (= sym expr)) false\n (sequential? expr) (every? #(without-symbol? sym %) expr)\n :else true))\n\n\n(defn expo \n \"Creates an expression with the given operator and parameters\"\n ([op params exp]\n (conso op params exp)))\n\n\n(defn- extract [c]\n (let [res \n (mapcat\n #(if (and (coll? %) (= (first %) :numeric.expresso.construct/seq-match))\n (second %) [%]) c)]\n (if (vector? c) (into [] res)\n res)))\n\n\n(defn splice-in-seq-matchers\n \"eliminates all seq-matchers in the expression by embedding the data \n the expression\"\n [express]\n (let [nexpress\n (cond\n (vector? express) (mapv splice-in-seq-matchers express)\n (list? express) (apply list (map splice-in-seq-matchers express))\n (seq? express) (doall (map splice-in-seq-matchers express))\n :else express)\n expr (if (instance? clojure.lang.IObj nexpress)\n (with-meta nexpress (meta express)) nexpress)]\n (if (coll? expr)\n (with-meta (extract expr) (meta expr))\n expr)))\n \n\n(defn validate-eq\n \"validates that expr is an equation\"\n [expr]\n (if (and (not= '= (first expr)) (= (count expr) 3))\n (throw (Exception. \"Input is no Equation\"))\n expr))\n\n(defn lasto\n \"y is the last element of x\"\n [x y]\n (fresh [a] (appendo a [y] x)))\n\n(defn butlasto\n \"y ist butlast from x\"\n [x y]\n (fresh [a]\n (appendo y [a] x)))\n\n\n(defn get-in-expression\n \"gets the subexpression in pos posv in expr\"\n [expr posv]\n (loop [expr expr posv posv]\n (if (empty? posv)\n expr\n (recur (nth expr (inc (first posv))) (rest posv)))))\n\n(defn- set-elem-in-pos\n [l pos sub]\n (apply list (concat (take pos l) [sub] (drop (inc pos) l))))\n\n(defn set-in-expression\n \"assocs sub in the position posv in the expression\"\n [expr posv sub]\n (loop [posv posv sub sub]\n (if (< (count posv) 2)\n (set-elem-in-pos expr (inc (first posv)) sub)\n (let [p (get-in-expression expr (butlast posv))\n nsub (set-elem-in-pos p (inc (last posv)) sub)]\n (recur (butlast posv) nsub)))))\n\n(defn substitute-in-positions\n \"substitutes the expression giving the pos -> subexpression map\"\n [expr pos-map]\n (reduce (fn [expr [k v]]\n (set-in-expression expr k v)) expr pos-map))\n\n(defn only-one-occurrence\n \"checks if there is at most one occurrence ov v in equation\"\n [v equation]\n (>= 1 (->> equation flatten (filter #{v}) count)))\n\n(defn positions-of\n \"returns the positions of v in equation\"\n ([v equation] (positions-of v equation []))\n ([v equation pos]\n (if-let [op (expr-op equation)]\n (filter identity\n (mapcat #(positions-of v %1 (conj pos %2))\n (rest equation) (range)))\n (if (= v equation) [pos] nil))))\n \n(defn swap-sides\n \"swaps the sides of the equation\"\n [[eq lhs rhs]]\n (list eq rhs lhs))\n\n(def combine-solutions mapcat)\n\n\n\n(def ^:dynamic *treshold* 1e-9)\n\n(defn num=\n \"equals operation applicable on all expression types. compares numbers with\n == other types with =. Does not throw. Also succeeds if a and b are a very\n near numerically according to *treshold*\"\n [a b]\n (or (= a b) (and (number? a) (number? b)\n (or (clojure.core/== a b)\n (< (Math/abs (- (Math/abs (double a))\n (Math/abs (double b)))) *treshold*)))))\n\n(defn eq-lhs\n \"returns the lhs of equation\"\n [equation]\n (second equation))\n\n(defn eq-rhs\n \"returns the rhs of equation\"\n [equation]\n (nth equation 2))\n\n(defn solved?\n \"checks if equation is already solved in regard to v\"\n [v equation]\n (and (= (nth equation 1) v)\n (not= v (nth equation 2))\n (= 0 (->> (nth equation 2) flatten (filter #{v}) count))))\n\n(defn submap\n \"returns the reduced map m which contains only keys in keys\"\n [keys m]\n (into {} (reduce (fn [kvs symb]\n (if (contains? m symb)\n (conj kvs [symb (get m symb)])\n kvs)) [] keys)))\n\n(defn common-prefix\n \"returns the common-prefix of the position vectors in positions\"\n [positions]\n (let [minl (apply min (map count positions))]\n (loop [l minl]\n (if (> l 0)\n (if (every? #{(subvec (first positions) 0 l)}\n (map #(subvec % 0 l) (rest positions)))\n (subvec (first positions) 0 l)\n (recur (dec l)))\n []))))\n\n\n(defn gcd\n \"calculates gcd of m and n\"\n [m n]\n (loop [m (long m) n (long n)]\n (if (> n 0)\n (recur n (rem m n))\n m)))\n\n(defn round\n \"rounds m if m is not an integer\"\n [m]\n (if (integer? m)\n m (Math/round (double m))))" }, { "path": "src/test/clojure/numeric/expresso/test_construct.clj", "content": "(ns numeric.expresso.test-construct\n (:refer-clojure :exclude [== record?])\n (:use numeric.expresso.construct)\n (:use [clojure.core.logic :exclude [is]]\n [clojure.test])\n (:require [numeric.expresso.protocols :as protocols]\n [numeric.expresso.impl.pimplementation :as impl]))\n\n(deftest test-to-expression\n (testing \"a normal s-expression is converted to an expresso expression in an idempotent step\"\n (let [sexp '(clojure.core/+ x 2)\n exp1 (to-expression sexp)\n exp2 (to-expression exp1)]\n (is (not (identical? exp1 sexp)))\n (is (identical? exp1 exp2)))))\n\n(deftest test-ex\n (is (= '(+ 1 2 3) (ex (+ 1 2 3))))\n (is (= '(+ x y z a b) (ex (+ x y z a b))))\n (is (= '(+ x 3) (let [x 3] (ex (+ x ~x))))))\n\n(deftest test-ex'\n (is (= '(+ 1 2 3) (ex' (+ 1 2 3))))\n (is (= '(+ x y z a b) (ex' (+ 'x 'y 'z 'a 'b))))\n (is (= '(+ x y z a b) (ex' [x y z a b] (+ x y z a b))))\n (is (= '(+ x 20) (ex' [x] (+ x ~(+ 4 (* 2 5) (+ 1 (+ 2 3)))))))\n (is (= '(+ c 3) (let [x 3] (ex' [c] (+ c x))))))\n\n\n\n\n(deftest test-shape-elemwise\n (is (= [] (protocols/shape (ex (+ 1 2 3)))))\n (is (= [2 2] (protocols/shape (ex (+ [[1 2][3 4]] 5)))))\n (is (= [] (protocols/shape (ex (+ 1 x 2)))))\n (is (= [] (let [expr (ex (+ 1 x 2))]\n (protocols/shape (impl/check-constraints\n (protocols/add-constraint expr\n [== (protocols/shape (nth expr 2)) []])))))))\n\n(deftest test-shape-inner-product\n (is (= [] (protocols/shape (ex (inner-product 1 2)))))\n (is (= [] (protocols/shape (ex (inner-product 1 2 3 4 )))))\n (is (= [] (protocols/shape (ex (inner-product [1 2] [3 4])))))\n (is (= [2] (protocols/shape (ex (inner-product 2 [1 2])))))\n (is (= [2 2] (protocols/shape (ex (inner-product [[1 2][3 4]] 1 [[1 2][3 4]])))))\n (is (= [3 1] (protocols/shape (ex (inner-product [[1 2][3 4][5 6]] [[1][2]])))))\n (is (protocols/expr-op (protocols/shape (ex (inner-product 1 ^:matrix x [[1 2][3 4]]))))))" }, { "path": "src/test/clojure/numeric/expresso/test_core.clj", "content": "(ns numeric.expresso.test-core\n (:use numeric.expresso.core)\n (:use [clojure.test :exclude [test-vars]])\n (:require [numeric.expresso.types :as types]\n [numeric.expresso.protocols :as protocols]\n [clojure.core.logic :as logic]))\n\n\n(deftest test-ex\n (is (= 5 (ex 5)))\n (is (= '(+ x y) (ex (+ x y))))\n (is (not (empty? (meta (ex (+ x y))))))\n (is (not (empty? (meta (first (ex (+ x y)))))))\n (is (= '(+ a b) (ex (+ ^:matrix a ^:matrix b))))\n (is (= '(+ x (* x y)) (ex (+ x (* x y)))))\n (is (= '(+ x (* 3 y)) (let [x 3] (ex (+ x (* ~x y)))))))\n\n(deftest test-ex'\n (is (= 5 (ex 5)))\n (is (= '(+ x y) (ex' (+ 'x 'y))))\n (is (= '(+ 3 3) (let [x 3] (ex' (+ 3 x)))))\n (is (= '(+ 3 x) (let [x 3] (ex' [x] (+ 3 x))))))\n\n(deftest test-expression?\n (is (expression? (ex (+ 1 2))))\n (is (not (expression? [+ 1 2])))\n (is (expression? '(+ 1 2))))\n\n(deftest test-constant?\n (is (not (constant? (ex (+ 1 2)))))\n (is (constant? [+ 1 2]))\n (is (not (constant? '(+ 1 2)))))\n\n\n(deftest test-properties\n (is (= #{:positive}\n (properties (expresso-symbol 'x :properties #{:positive}))))\n (is (contains? (properties 1) :positive)))\n\n(deftest test-vars\n (is (= '#{x y} (vars (ex (* x y x)))))\n (is (= '#{x} (vars 'x))))\n\n(deftest test-shape\n (is (= [] (shape (ex (+ 1 2)))))\n (is (logic/lvar? (shape (matrix-symbol 'x)))))\n\n(deftest test-expresso-symbol\n (is (= 'x (expresso-symbol 'x)))\n (is (= types/number (protocols/type-of (expresso-symbol 'x))))\n (is (= types/matrix\n (protocols/type-of (expresso-symbol 'x :type types/matrix))))\n (is (= types/matrix\n (protocols/type-of (expresso-symbol 'x :shape [2 3]))))\n (is (= [] (shape (expresso-symbol 'x))))\n (is (logic/lvar? (shape (expresso-symbol 'x :type types/matrix))))\n (is (= [2 2] (shape (expresso-symbol 'x :shape [2 2])))))\n\n\n(deftest test-matrix-symbol\n (is (= types/matrix\n (protocols/type-of (matrix-symbol 'x))))\n (is (logic/lvar? (shape (matrix-symbol 'x))))\n (is (= [2 2] (shape (matrix-symbol 'x :shape [2 2])))))\n\n(deftest test-zero-matrix\n (is (= #{:mzero} (properties (zero-matrix)))))\n\n(deftest test-identity-matrix\n (is (= #{:midentity} (properties (identity-matrix)))))\n \n\n;;see also test_parse.clj\n(deftest test-parse-expression\n (is (= (ex (+ 1 2 3)) (parse-expression \"1 + 2 + 3\")))\n (is (= (ex (+ 1 (* 2 (** 3 4)) 5))\n (parse-expression \"1+2*3**4+5\")))\n (is (= (ex (= (+ (** (sin x) 2) (** (cos x) 2)) 1))\n (parse-expression \"sin(x)**2 + cos(x)**2 = 1\"))))\n\n(deftest test-evaluate\n (is (== 6 (evaluate (ex (* 2 x)) {'x 3}))))\n\n(deftest test-substitute\n (is (= (ex (+ x x (/ y z)))\n (substitute (ex (+ (* a b) (* a b) (/ c d)))\n {(ex (* a b)) 'x 'c 'y 'd 'z}))))\n\n\n(deftest test-simplify\n (is (= 4 (simplify (ex (+ 2 2)))))\n (is (= 137 (simplify (ex (+ (* 5 20) 30 7)))))\n (is (== 0 (simplify (ex (- (* 5 x) (* (+ 4 1) x))))))\n (is (== 0 (simplify (ex (* (/ y z) (- (* 5 x) (* (+ 4 1) x)))))))\n (is (= (ex (* 6 x)) (simplify (ex (* 3 2 x)))))\n (is (= (ex (* 720 x y z)) (simplify (ex (* 2 x 3 y 4 z 5 6)))))\n (is (= 7 (simplify (ex (+ x 3 4 (- x))))))\n (is (= (ex (* a (+ b c)))\n (simplify (ex (+ (* a b) (* a c) 5 -5)))))\n (is (nil? (simplify (ex (+ (* a b) (* a c) 5 -5)) :ratio 0.5))))\n\n(deftest test-multiply-out\n (is (= (ex (+ (** e 2) (* 2 d e) (** d 2) (* b a) (* c a)))\n (multiply-out (ex (+ (* a (+ b c)) (** (+ d e) 2))))))\n (is (= (ex (+ (** c 3) (* 3 b (** c 2)) (* 3 (** b 2) c) (** b 3)\n (* 3 a (** c 2)) (* 6 a b c) (* 3 a (** b 2))\n (* 3 (** a 2) c) (* 3 (** a 2) b) (** a 3)))\n (multiply-out (ex (** (+ a b c) 3))))))\n\n(deftest test-evaluate-constants\n (is (= (ex (+ (* 3 a) 20))\n (evaluate-constants (ex (+ (* (- 5 2) a) (* 4 5))))))\n (is (== 6 (evaluate-constants (substitute (ex (* 2 x)) {'x 3})))))\n\n\n(deftest test-transform-to-polynomial-normal-form\n (is (= (ex (** x 3))\n (to-polynomial-normal-form 'x (ex (+ (** x 3) (* 3 (** x 2))\n (- (* 2 (** x 2))\n (* 5 (** x 2))))) )))\n (is (= (ex (+ 1024 (* 3840 x) (* 9600 (** x 2)) (* 15840 (** x 3))\n (* 20340 (** x 4)) (* 19683 (** x 5)) (* 15255 (** x 6))\n (* 8910 (** x 7)) (* 4050 (** x 8)) (* 1215 (** x 9))\n (* 243 (** x 10))))\n (to-polynomial-normal-form 'x (ex (** (+ (* 3 x) 4 (* 3 (** x 2)))\n 5)))))\n (is (= (ex (+ (* (+ 1 (* 2 a) (** a 2)) x) (* (+ 1 a) (** x 2))))\n (to-polynomial-normal-form 'x (ex (* (+ x a 1) (* x (+ 1 a))))))))\n\n(deftest test-rearrange\n (is (= [(ex (= x (- 4 1)))]\n (rearrange 'x (ex (= (+ 1 x) 4)))))\n (is (= '[(= x 3) (= x (- 3))]\n (rearrange 'x (ex (= (abs x) 3)))))\n (is (nil? (rearrange 'x (ex (= (+ x x) 0))))))\n\n\n(deftest test-solve\n (is (= #{2} (solve 'x (ex (= (+ 1 x) 3)))))\n (is (= '#{} (solve '#{x} (ex (= x (+ x 1))))))\n (is (= '_0 (solve '#{x} (ex (= x x)))))\n (is (= '#{0 1} (solve '#{x} (ex (= (* (sin x) (- x 1)) 0)))))\n (is (= #{4} (solve '#{x} (ex (= (+ 1 (* 2 (- 3 (/ 4 x)))) 5))))) \n (is (= #{-4}\n (solve '#{x} (ex (= (* 3 x) (+ (* 4 x) 4))))))\n (is (= '#{(* 1/2 (+ (- a) (sqrt (+ (** a 2) -4))))\n (* 1/2 (+ (- a) (- (sqrt (+ (** a 2) -4)))))}\n (solve '#{x} (ex (= (+ (** x 2) (* a x) 1) 0)))))\n (is (= '#{{y (+ (* a 1/2) (* -1/4 (- (sqrt (+ (* -4.0 (** a 2)) 8))))),\n x (+ (* 1/2 a) (* (- (sqrt (+ (* -4.0 (** a 2)) 8))) 1/4))}\n {y (+ (* a 1/2) (* -1/4 (sqrt (+ (* -4.0 (** a 2)) 8)))),\n x (+ (* 1/2 a) (* (sqrt (+ (* -4.0 (** a 2)) 8)) 1/4))}}\n (solve '[x y] (ex (= (+ (** x 2) (** y 2)) 1))\n (ex (= (+ x y) a)))))\n (is (= '#{0 1 -1}\n (solve 'x (ex (= (- (** x 4) (** x 2)) 0)))))\n (is (= '#{1 3}\n (solve 'x (ex (= (+ (** 2 (* 2 x)) (- (* 5 (** 2 (+ x 1)))) 16) 0)))))\n (is (= #{10N}\n (solve 'x (ex (= (+ (* (/ 3 4) x) (/ 5 6)) (- (* 5 x) (/ 125 3)))))))\n (is (= #{3N}\n (solve 'x (ex (= (+ (/ (- (* 6 x) 7) 4)\n (/ (- (* 3 x) 5) 7))\n (/ (+ (* 5 x) 78) 28))))))\n (is (= #{17}\n (solve 'x (ex (= (sqrt (- x 8)) 3)))))\n (is (= #{-2 3}\n (solve 'x (ex (= (abs (- (* 2 x) 1)) 5)))))\n (is (= '#{{remaining2 (+ -15N (* 3/5 _0))}}\n (solve '[remaining2]\n (ex (= original b))\n (ex (= remaining1 (- original (/ original 4))))\n (ex (= remaining2 (- remaining1 (+ (/ remaining1 5) 15)))))))\n (is (= (solve '[x y]\n (ex (= y (* x 4/3))) ;; y = 4/3 x\n (ex (= 25 (+ (** (- x 0) 2) (** (- y 0) 2)))) ;; x^2 + y^2 = 25\n ) '#{{x -3, y -4N} {x 3, y 4N}}))\n (is (= (solve '[x y]\n (ex (= 25 (+ (* (- x 6) (- x 6)) (* (- y 0) (- y 0))))) ;; (x-6)^2 + y^2 = 25\n (ex (= 25 (+ (** (- x 0) 2) (** (- y 0) 2)))) ;; x^2 + y^2 = 25\n ) '#{{x 3, y 4.0} {x 3, y -4.0}})))\n\n\n(deftest test-solve-variable-order\n (is (= '#{{dx 4}} (solve 'dx (ex (= 4 dx)) (ex (= dt 5)) (ex (= cs (/ dt dx))))))\n (is (= '#{{s 5/9, m 5/3}}\n (solve ['s 'm] \n (ex (= m (/ t x)))\n (ex (= s (/ m 3)))\n (ex (= t 5))\n (ex (= x 3)))))\n (is (= '#{{s 5/9, m 5/3}}\n (solve ['m 's] \n (ex (= m (/ t x)))\n (ex (= s (/ m 3)))\n (ex (= t 5))\n (ex (= x 3))))))\n\n(deftest test-differentiate\n (is (= (ex (* 2 x)) (differentiate '[x] (ex (** x 2)))))\n (is (= 2.0 (differentiate '[x x] (ex (** x 2)))))\n (is (= (ex (* 3 (** x 2))) (differentiate '[x] (ex (** x 3)))))\n (is (= (ex (* 12.0 (** x 3)))\n (differentiate '[x] (ex (* (** x 3) (* 3 x))))))\n (is (= (ex (* 36.0 (** x 2)))\n (differentiate '[x x] (ex (* (** x 3) (* 3 x)))))))\n\n;;see also test-optimize\n\n(deftest test-compile-expr\n (is (= 4 ((compile-expr [] (ex (+ (* 1 2) (* 2 1)))))))\n (is (= 8 ((compile-expr [x] (ex (+ (* x 2) (* 2 x)))) 2))))\n\n(deftest test-compile-expr*\n (is (= 4 ((compile-expr* [] (ex (+ (* 1 2) (* 2 1)))))))\n (is (= 8 ((compile-expr* '[x] (ex (+ (* x 2) (* 2 x)))) 2))))\n\n(deftest test-optimize\n (is (= 4 (evaluate (optimize (ex (+ (* 1 2) (* 2 1)))) {})))\n (is (= 8 (evaluate (optimize (ex (+ (* x 2) (* 2 x)))) {'x 2}))))\n\n" }, { "path": "src/test/clojure/numeric/expresso/test_optimize.clj", "content": "(ns numeric.expresso.test-optimize\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic :exclude [is] :as l]\n [numeric.expresso.optimize]\n [numeric.expresso.construct]\n [numeric.expresso.protocols]\n [clojure.test]))\n\n\n(deftest test-common-subexpressions\n (is (= [#{(ex (* 1 (* 2 3)))} #{(ex (* 2 3))}]\n (common-subexpressions (ex (+ (* 1 (* 2 3)) (+ (* 1 (* 2 3))))))))\n (is (= [] (common-subexpressions (ex (+ 3 4 (+ 1 2))))))\n (is (= [#{(ex (* 2 1)) (ex (* 1 2))}]\n (common-subexpressions (ex (+ (* 1 2) (* 2 1)))))))\n\n\n(deftest test-evaluate-let\n (is (= 4 (evaluate (optimize (ex (+ (* 1 2) (* 2 1)))) {}))))\n\n(deftest test-compile\n (is (= 8 ((compile-expr [x] (optimize (ex (+ (* x 2) (* 2 x))))) 2))))\n\n(deftest test-optimize\n (is (= 3 (optimize (ex (+ 1 2)))))\n (is (= (ex (+ 3 x)) (optimize (ex (+ 1 2 x)))))\n (is (= (ex (* x (+ y z))) (optimize (ex (+ (* x y) (* x z))))))\n (is (= 0 (optimize (ex (+ x (- x))))))\n (is (= 0 (optimize (ex (- x x)))))\n (is (= 1 (optimize (ex (/ x x)))))\n (is (= 1 (optimize (ex (* x (/ x))))))\n (is (= 'x (optimize (ex (- (- x))))))\n (is (= (ex (sqrt x)) (optimize (ex (** x 0.5)))))\n (is (= (ex (* z (sum k 0 5 k) (** x 2)))\n (optimize (ex (sum k 0 5 (* x x z k))))))\n (is (= (ex (inner-product (inner-product a (inner-product b c)) d))\n (optimize (ex (inner-product \t^{:shape [40 20]} a\n ^{:shape [20 30]} b\n ^{:shape [30 10]} c\n ^{:shape [10 30]} d)))))\n (is (= (ex (inner-product (inner-product (inner-product a b) c) d))\n (optimize (ex (inner-product \t^{:shape [10 20]} a\n ^{:shape [20 30]} b\n ^{:shape [30 40]} c\n ^{:shape [40 30]} d))))))\n\n\n(deftest test-emit-code*\n (is (= '(* x (+ y z)) (emit-code (ex (* x (+ y z))))))\n (is (= '(_0)\n (run* [q] (fresh[n res]\n (== `(loop [~n (long 0) ~res 0]\n (if (<= ~n 5)\n (let [~'k ~n]\n (recur (inc ~n)\n (clojure.core.matrix/add ~res ~'k)))\n ~res))\n (emit-code (ex (sum k 0 5 k)))))))))\n\n\n" }, { "path": "src/test/clojure/numeric/expresso/test_parse.clj", "content": "(ns numeric.expresso.test-parse\n (:use [numeric.expresso.construct]\n [numeric.expresso.parse]\n [clojure.test]))\n\n(deftest test-parse-expression\n (is (= (ex (+ 1 2)) (parse-expression \"1+2\")))\n (is (= (ex (+ 1 2 3 4)) (parse-expression \"1+2+3+4\")))\n (is (= (ex (+ (* 1 2 3) 4)) (parse-expression \"1*2*3+4\")))\n (is (= (ex (* 1 2 (+ 3 4))) (parse-expression \"1*2*(3+4)\")))\n (is (= (ex (+ 1 (* 2 (** 3 4)) 5)) (parse-expression \"1+2*3**4+5\"))))\n\n(deftest test-parse-variables\n (is (= (ex (+ x 1)) (parse-expression \"x+1\"))))\n\n(deftest test-parse-function\n (is (= (ex (abs x)) (parse-expression \"abs(x)\"))))\n\n(deftest test-literal-symbols\n (is (= 'inner-product (parse-expression \"`inner-product`\")))\n (is (= (ex (inner-product a)) (parse-expression \"`inner-product`(a)\"))))\n\n\n(deftest test-double-braces-and-spaces\n (is (= '(* (/ (+ 1 a) 2) (/ (+ 1 b) 2))\n (parse-expression \"( ( 1 + a )/2 )*( ( 1 + b )/2 )\")))\n (is (= '(+ 1 a)\n (parse-expression \"((1) + a)\")))\n (is (= '(+ 1 a)\n (parse-expression \"((1) + a)\"))))\n" }, { "path": "src/test/clojure/numeric/expresso/test_polynomial.clj", "content": "(ns numeric.expresso.test-polynomial\n (:use numeric.expresso.impl.polynomial)\n (:use clojure.test))\n\n(deftest test-to-poly-normal-form\n (is (= 7 (to-poly-normal-form '(+ 3 x 4 (- x)))))\n (is (= (poly 'x (poly 'y 0 2) 2) (to-poly-normal-form '(+ x y y x)))))" }, { "path": "src/test/clojure/numeric/expresso/test_properties.clj", "content": "(ns numeric.expresso.test-properties\n (:use [clojure.test]))\n\n\n" }, { "path": "src/test/clojure/numeric/expresso/test_protocols.clj", "content": "(ns numeric.expresso.test-protocols\n (:use [numeric.expresso.protocols])\n (:use clojure.test)\n (:refer-clojure :exclude [== record?])\n (:use [numeric.expresso.impl.pimplementation]\n [clojure.core.logic :exclude [is] :as l])\n (:import [numeric.expresso.impl.pimplementation\n Expression]))\n\n(deftest test-unification\n (is (= [1] (run* [q] (== (Expression. `+ [q 2 3]) (Expression. `+ [1 2 3])))))\n (is (= ['_0] (run* [q] (== (Expression. `+ [q 2 3]) (Expression. `+ [q 2 3])))))\n (is (= [] (run* [q] (== (Expression. `+ [q 1 3]) (Expression. `+ [q 2 3])))))\n (is (= ['_0] (run* [q] (== (Expression. `+ [q 1 2]) [`+ q 1 2]))))\n (is (= ['_0] (run* [q] (== [`+ q 1 2] (Expression. `+ [q 1 2])))))\n (is (= [] (run* [q] (== [`+ q q q] (Expression. `+ [q 1 2])))))\n (is (= [] (run* [q] (== (Expression. `+ [q 1 2]) [`+ q q q]))))\n (is (= [`+] (run* [q] (== (Expression. `+ [1 2 3]) [q 1 2 3])))))\n\n(deftest test-sequential\n (is (= `+ (first (Expression. `+ [1 2 3]))))\n (is (= [1 2 3] (rest (Expression. `+ [1 2 3]))))\n (is (= (Expression. `* [1 2 3]) (first (rest (Expression. `+ [(Expression. `* [1 2 3])]))))))\n\n\n\n(deftest test-shape\n (is (= '() (shape 1)))\n (is (= [2 2] (shape [[1 2][3 4]])))\n (is (nil? (shape 'bla))))\n\n\n\n\n(def lhs (lvar 'lhs false))\n(def rhs (lvar 'rhs false))\n(def transs (lvar 'transs false))\n\n(def v1 (check-constraints (add-constraint [lhs rhs] [== lhs rhs])))\n(def v2 (check-constraints (add-constraint [lhs transs] [== lhs transs])))\n\n(def vv1 (check-constraints v1))\n(def vv2 (check-constraints v2))\n\n(def cv (check-constraints (add-constraint [vv1 vv2] [== lhs rhs])))\n(def cv (check-constraints (add-constraint cv [== lhs transs])))\n\n(def ccv (check-constraints cv))\n\n(deftest test-check-constraints\n (is (= [rhs rhs] vv1))\n (is (= [transs transs] vv2))\n (is (= 1 (count (into #{} (flatten ccv))))))\n\n(deftest test-add-constraint\n (is (= 1 (count (constraints (add-constraint 'a [== 0 0])))))\n (is (= [rhs rhs] (shape (check-constraints\n (add-constraint (with-meta 'x {:shape [lhs rhs]})\n [== lhs rhs]))))))" }, { "path": "src/test/clojure/numeric/expresso/test_rules.clj", "content": "(ns numeric.expresso.test-rules\n (:use numeric.expresso.rules)\n (:use clojure.test)\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic :exclude [is] :as l]\n [numeric.expresso.construct]))\n\n\n\n(construct-with [* + - e/ca+ e/ca* e/- e/div]\n(def rules [(rule (* ?x 1) :=> ?x)\n (rule (* ?x 0) :=> 0)\n (rule (+ ?x 0) :=> ?x)\n (rule (+ ?x (- ?x)) :=> 0)\n (rule (- ?x ?x) :=> (- (* 2 ?x)))])\n\n(deftest test-apply-ruleo\n (is (= '(3) (run* [q] (apply-ruleo (first rules) (* 3 1) q))))\n (is (= '() (run* [q] (apply-ruleo (first rules) (+ 3 1) q))))\n (is (= '(0) (run* [q] (apply-ruleo (nth rules 3) (+ 2 (- 2)) q))))\n (is (= (list (- (* 2 1)))\n (run* [q] (apply-ruleo (last rules) (- 1 1) q)))))\n)\n\n(defn collabs-factorso [x a b]\n (fn [res]\n (project [a b]\n (== res (ce 'e/ca* x (+ a b))))))\n\n \n(defna numberso [vars] \n ([[n . rest]] (project [n] (do (== true (number? n))) (numberso rest)))\n ([[]] succeed))\n\n\n\n(construct-with [* + - e/ca+ e/ca* e/- e/div ° map]\n\n(def simplification-rules\n [(rule (e/ca+ 0 ?&*) :=> ?&*)\n (rule (e/ca* 0 ?&*) :=> 0)\n (rule (e/ca* 1 ?&x) :=> ?&x)\n (rule (e/- 0 ?x) :=> (e/- ?x))\n (rule (e/- ?x 0) :=> ?x)\n (rule (e/ca* ?x (e/div 1 ?x) ?&*) :=> (e/ca* ?&*) :if (!= ?x 0))\n (rule (e/ca+ ?x (e/- ?x) ?&*) :=> 0)\n (rule (e/ca+ (e/ca* ?a ?x) (e/ca* ?b ?x)) :=> (collabs-factorso ?x ?a ?b)\n :if (numberso [?a ?b]))\n (rule (e/ca* ?x (e/ca+ ?a ?b)) :=> (e/ca+ (e/ca* ?x ?a) (e/ca* ?x ?b)))])\n\n(deftest test-transform-with-rules\n (is (= (list '* 3 3)\n (transform-with-rules simplification-rules \n (* 3 (+ (+ 0 3) (* 0 3)))))))\n\n(def factor-out-rule (rule (+ (* ?x ?&*a) (* ?x ?&*b) ?&*r) :=>\n (+ (* ?x (+ (* ?&*a) (* ?&*b))) ?&*r)))\n\n(deftest test-seq-matching-commutative-rule\n (is (= (+ (* 'x (+ (* 3 2) (* 4 3))) 1)\n (apply-rule factor-out-rule (+ (* 'x 3 2) (* 'x 4 3) 1)))))\n\n;; ° (the list constructor) is an associative operation\n;; (° 1 2 3) means the list with elements 1 2 3\n\n(defn biggero [x y] (project [x y] (== true (> x y))))\n\n(def sort-rule (rule (° ?&*1 ?x ?&*2 ?y ?&*3) :=> (° ?&*1 ?y ?&*2 ?x ?&*3)\n :if (biggero ?y ?x)))\n\n\n\n(deftest test-seq-matcher-in-associative-rule\n (is (= (° 9 8 7 6 5 4 4 3 2 1)\n (transform-expression [sort-rule] (° 1 4 2 6 5 4 3 7 8 9))))))\n\n(def inline-trans\n (rule (ex (- ?a ?&+)) :==>\n (ex (+ ~?a ~(seq-matcher (map #(ex (- ~%))\n (matcher-args ?&+)))))))\n\n(deftest test-inline-trans\n (is (= (ex (+ 3 (- 4))) (apply-rule inline-trans\n (ex (- 3 4)))))\n (is (= (ex (+ 3 (- 4) (- 5)))\n (apply-rule inline-trans (ex (- 3 4 5))))))\n\n(def inline-guard\n (rule (ex (/ ?x ?x)) :=> 1 :if (guard (not= 0 ?x))))\n\n(deftest test-inline-guard\n (is (= 1 (apply-rule inline-guard (ex (/ 3 3)))))\n (is (= nil (apply-rule inline-guard (ex (/ 0 0))))))\n\n(def guardr (guardrel [x] (nilo x)))\n\n(def tgr (rule ?x :=> 0 :if (guardr ?x)))\n\n(def ttr (transrel [x res] (== res (+ x 1))))\n\n(def rttr (rule ?x :=> (ttr ?x)))\n\n(deftest test-convenience-macros\n (is (= 0 (apply-rule tgr nil)))\n (is (= nil (apply-rule tgr 0)))\n (is (= 1 (apply-rule rttr 0))))\n\n(deftest test-extractor\n (is (= '(2 3) (apply-rule (rule (ex (cons? ?p ?ps)) :=> ?ps) [1 2 3]))))" }, { "path": "src/test/clojure/numeric/expresso/test_simplify.clj", "content": "(ns numeric.expresso.test-simplify\n (:refer-clojure :exclude [== record?])\n (:use numeric.expresso.simplify)\n (:use clojure.test)\n (:use [numeric.expresso.protocols]\n [numeric.expresso.impl.pimplementation]\n [numeric.expresso.construct]\n [clojure.core.logic :exclude [is]]))\n\n\n(def matr (matrix-symb 'a))\n\n(deftest test-simp-shape-inference\n (is (symbol? (simp-expr (ex' (- matr matr)))))\n (is (= [[0.0 0.0]\n [0.0 0.0]] (value\n (check-constraints\n (add-constraint (simp-expr (ex' (- matr matr)))\n [== (shape matr) [2 2]]))))))" }, { "path": "src/test/clojure/numeric/expresso/test_solve.clj", "content": "(ns numeric.expresso.test-solve\n (:refer-clojure :exclude [== record?])\n (:use numeric.expresso.solve)\n (:use clojure.test)\n (:use numeric.expresso.construct)\n (:use [clojure.core.logic :exclude [is log] :as l]))\n\n\n\n\n(deftest test-solve-linear-system\n (is (= '#{{x 3}} (solve-linear-system '[x] [(ex (= x y))\n (ex (= y 3))])))\n (is (= '#{{x 3.0, y _1, z _0}}\n (solve-linear-system '[x y z] [(ex (= x 3))\n (ex (= y y))\n (ex (= z z))])))\n (is (= nil\n (solve-linear-system '[x] [(ex (= x (+ x 1)))])))\n (is (= '#{{y _0 x _0}}\n (solve-linear-system '[x y] [(ex (= x y))])))\n (is (= '#{{x 180/7 y 40/7}}\n (solve-linear-system '[x y] [(ex (= (+ (* 3 x) (* 4 y)) 100))\n\t\t\t\t\t\t (ex (= (- x y) 20))]))))\n\n(deftest test-solve-system\n (is (= #{{'y [3 6 9]}}\n (solve-system '[y]\n #{(ex (= z (* 2 x)))\n (ex (= y (+ x z)))\n (ex (= x [1 2 3]))})))\n (is (= #{{'y [3 6 9]\n 'z [2 4 6]\n 'x [1 2 3]}}\n (solve-system '[y z x]\n #{(ex (= z (* 2 x)))\n (ex (= y (+ x z)))\n (ex (= x [1 2 3]))})))\n (is (= #{{'x 2}} (solve-system '[x] #{(ex (= (+ x y) 3))\n\t\t\t\t (ex (= y 1))})))\n (is (= #{{'x 1}} (solve-system '[x] #{(ex (= (+ x y) 3))\n (ex (= (+ x 1) y))})))\n (is (= '#{{y (+ 7 (* -8 (/ (+ b a)) a)), x (* 8 (/ (+ b a)))}}\n (solve-system '[x y] #{(ex (= (+ (* a x) y) 7))\n (ex (= (- (* b x) y) 1))})))\n (is (= '#{{y (+ (* a 1/2) (* -1/4 (sqrt (+ (* -4.0 (** a 2)) 8)))),\n x (+ (* 1/2 a) (* (sqrt (+ (* -4.0 (** a 2)) 8)) 1/4))}\n {y (+ (* a 1/2) (* -1/4 (- (sqrt (+ (* -4.0 (** a 2)) 8))))),\n x (+ (* 1/2 a) (* (- (sqrt (+ (* -4.0 (** a 2)) 8))) 1/4))}}\n (solve-system '[x y] #{(ex (= (+ (** x 2) (** y 2)) 1))\n (ex (= (+ x y) a))}))))\n\n(deftest test-solve-square-roots\n (is (= #{9} (solve 'x (ex (= (+ (sqrt x) (sqrt (- x 5))) 1)))))\n (is (= '#{(+ (* 0.25 (+ (** a 2) 1)) (* 0.5 a))}\n (solve 'x (ex (= (+ (sqrt x) (sqrt (- x a))) 1)))))\n (is (= #{1 -4.2444444444444445}\n (solve\n 'x (ex (= (+ (sqrt (+ x 8)) (sqrt (+ x 15))) (sqrt (+ (* 9 x) 40)))))))\n (is (= #{1 -0.01799485861182519}\n (solve\n 'x (ex (= (+ (sqrt (+ (* 5 x) 4))\n (sqrt (+ (* 7 x) 2)))\n (sqrt (+ (* 35 x) 1)))))))\n (is (= #{5 0.39167589808513964}\n (solve\n 'x (ex (= (- (* 7 (sqrt (- (* 2 x) 1)))\n (* 8 (sqrt (- x 1))))\n (* 10 (sqrt (/ (- x 4) 4))))))))\n (is (= #{8.165253628132167 4.890301927423389}\n (solve\n 'x (ex (= (- (sqrt (- (* 9 x) 14)) (sqrt (+ (* 3 x) 6)))\n (sqrt (/ (- (* 6 x) 25) 5))))))))\n\n(deftest test-solve-fractions\n (is (= #{5} (solve\n 'x (ex (= (+ (/ (- x 3))\n (/ (+ x 3)))\n (/ 10 (- (** x 2) 9)))))))\n (is (= #{} (solve\n 'x (ex (= (/ 1 (- x 2))\n (- (/ 3 (+ x 2))\n (/ (* 6 x) (- (** x 2) 4))))))))\n (is (= #{0.7588723439378913 -0.6588723439378913}\n (solve\n 'x (ex (= (/ (- (* 2 x) 1) (+ x 1))\n (+ (/ (* 2 x) (- x 1)) (/ 5 x)))))))\n (is (= #{-3.424428900898052 6.424428900898052}\n (solve\n 'x (ex (= (+ (/ (- (** x 2) 8)\n (- (** x 2) 4))\n (/ 2 (+ x 2))) (/ 5 (- x 2)))))))\n (is (= #{5}\n (solve\n 'x (ex (= (+ (/ 34 (+ (** x 2) (* -3 x) 7)) 5) (- (* 2 x) 3)))))))\n(deftest test-solve-abs\n (is (= #{-2 -1/3} (solve 'x (ex (= (abs (- (* 2 x) 1)) (abs (+ (* 4 x) 3)))))))\n (is (= #{1 3.5 7.694933459514875 -0.19493345951487484}\n (solve\n 'x (ex (= (abs (+ (** x 2) (* -6 x) 1)) (abs (/ (+ (* 3 x) 5) 2)))))))\n (is (= #{-3 1.7320508075688772}\n (solve 'x (ex (= (abs x) (+ (** x 2) x -3)))))))\n\n(deftest test-solve-exp\n (is (= #{5.889547542811505 0.11045245718849461}\n (solve 'x (ex (= (+ (** 100 (+ (** x 2) (* -6 x) 1)) 5) 10)))))\n (is (= #{0 0.6931471805599453}\n (solve 'x (ex (= (+ (exp (* 2 x)) (* -3 (exp x)) 2) 0))))))\n\n(deftest test-solve-log\n (is (= #{6}\n (solve 'x (ex (= (+ (log (- x 2)) (log (- (* 2 x) 3)))\n (* 2 (log x)))))))\n (is (= #{16.168643024342963 -10.168643024342964}\n (solve 'x (ex (= (log (- (** x 2) (* 6 x) 16)) 5))))))\n" }, { "path": "src/test/clojure/numeric/expresso/test_symbolic.clj", "content": "(ns numeric.expresso.test-symbolic\n (:refer-clojure :exclude [])\n (:use [clojure.core.logic.protocols]\n [numeric.expresso.impl.symbolic]\n [clojure.test])\n (:require [clojure.core.matrix :as mat]))\n\n(def test2 (mat/matrix [[0 1 2 3 4 5]\n [0 1 2 3 4 5]\n [5 4 3 2 1 0]\n [0 1 2 3 4 5]]))\n\n(def test3 (mat/matrix [[1 2]\n [3 4]\n [5 6]]))\n\n(def test4 (mat/matrix [[2 1 -1 8]\n [-3 -1 2 -11]\n [-2 1 2 -3]]))\n\n(deftest test-gaus-solve\n (is (mat/e== [1/2 -1 3/4 2] (gaus-solve testmatrix)))\n (is (= '() (gaus-solve test3)))\n (is (= '[(/ (- 0 (+ (+ (+ (+ 0 (* 1 _0)) (* 2 _1)) (* 3 _2)) (* 4 (/ (- 25 (+ (+ (+ 0 (* 20 _0)) (* 15 _1)) (* 10 _2))) 5)))) 5) (/ (- 25 (+ (+ (+ 0 (* 20 _0)) (* 15 _1)) (* 10 _2))) 5) _2 _1 _0]\n (gaus-solve test2)))\n (is (mat/e== [2 3 -1] (gaus-solve test4))))" }, { "path": "src/test/clojure/numeric/expresso/test_utils.clj", "content": "(ns numeric.expresso.test-utils\n (:use numeric.expresso.utils)\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic :exclude [is] :as l]\n [clojure.test]))\n\n\n(deftest test-expo \n (is (= [[1 2]] (run* [q] (fresh [ex op lhs rhs]\n (expo '+ [1 2] ex)\n (expo op [lhs rhs] ex)\n (== q [lhs rhs]))))))\n\n\n(deftest test-lifto-with-inverse\n (let [inco (lifto-with-inverse inc dec)]\n (is (= [3] (run* [q] (inco 2 q))))\n (is (= [2] (run* [q] (inco q 3))))))\n\n\n(deftest test-mapo \n (is (= [2] (run* [q] (mapo (lifto-with-inverse inc dec) [1 q 3] [2 3 4])))))\n\n(deftest test-resolve-opo\n (is (= [clojure.core/+] (run* [q] (resolve-opo '+ q)))))\n\n(deftest test-applyo \n (is (= [[1 2 3 4]] (run* [q] (applyo conso [1 [2 3 4]] q))))\n (is (= [3] (run* [q] (applyo conso [1 [2 q 4]] [1 2 3 4])))))" }, { "path": "src/test/clojure/numeric/expresso/test_various.clj", "content": "(ns numeric.expresso.test-various\n (:refer-clojure :exclude [== record?])\n (:use [clojure.core.logic.protocols]\n [clojure.core.logic :exclude [is] :as l]\n [numeric.expresso.construct]\n [numeric.expresso.properties :as props]\n [numeric.expresso.protocols]\n [numeric.expresso.impl.pimplementation]\n [numeric.expresso.rules]\n [numeric.expresso.simplify]\n [clojure.test])\n (:require [clojure.core.logic.fd :as fd :exclude [record?]]\n [clojure.walk :as walk]\n [clojure.core.logic.unifier :as u :exclude [record?]]\n [numeric.expresso.utils :as utils]\n [clojure.core.matrix :as matrix]\n [clojure.core.matrix.operators :as mop]\n [numeric.expresso.impl.matcher :as m]\n [numeric.expresso.construct :as c]))\n\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;,,\n\n(defn expression? [exp]\n (or (not (sequential? exp)) (and (sequential? exp) (symbol? (first exp)))))\n\n\n(construct-with [+ - * / **]\n (def transform-to-polynomial-normal-form-rules\n (concat universal-rules\n [(rule (+ [?x ?y] [?z ?y] ?&*)\n :==> (+ [(+ ?x ?z) ?y] ?&*)\n :if (guard (and (number? ?y))))\n (rule (* [?x ?y] [?z ?a] ?&*)\n :==> (* [(* ?x ?z) (clojure.core/+ ?y ?a)] ?&*)\n :if (guard (and (number? ?y)\n (number? ?a))))\n (rule (- [?x ?y]) :==> [(- ?x) ?y]\n :if (guard (and (number? ?y))))\n (rule (/ [?x ?y]) :==>[(/ ?x) ?y]\n :if (guard (and (number? ?y))))\n (rule (ce ?op [?x 0]) :=> [(ce ?op ?x) 0])])))\n\n(defn- transform-to-coefficients-form [v expr]\n (if (sequential? expr)\n (if (= (first expr) '**)\n [1 (second (rest expr))]\n (apply (partial ce (first expr)) (map (partial transform-to-coefficients-form v) (rest expr))))\n (if (= v expr) [1 1] [expr 0])))\n\n\n(defn translate-back [v expr]\n (conj\n (walk/postwalk #(if (and (sequential? %) (= (count %) 2) (expression? (first %)) (number? (second %)))\n (if (= 0 (second %)) (first %)\n (ex' (* ~(first %) (** v ~(second %)))))\n %) (sort #(> (second %1) (second %2)) (rest expr))) (first expr)))\n\n\n\n(defn dbg\n ([x] (prn x) x)\n ([m x] (prn m x) x))\n\n\n(defn to-polynomial-normal-form [v expr]\n (->> expr\n (transform-expression (concat eval-rules\n universal-rules\n to-inverses-rules\n multiply-out-rules))\n (transform-to-coefficients-form v)\n (transform-expression transform-to-polynomial-normal-form-rules)\n (#(ce `+ %))\n (apply-rules [(rule (ex (+ (+ ?&*) ?&*r)) :=> (ex (+ ?&* ?&*r)))])\n (translate-back v)\n (transform-expression (concat eval-rules\n universal-rules\n to-inverses-rules\n multiply-out-rules))))\n\n(def c= =)\n\n(construct-with [+ cons? nth-arg? = - / * mop/+ mop/- mop/* matrix/div]\n(def rearrange-rules\n [(rule [(cons? ?p ?ps) (= (+ ?&+) ?rhs)]\n :==> (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (- ?rhs left right))]))\n (rule [(cons? ?p ?ps) (= (mop/+ ?&+) ?rhs)]\n :==> (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (mop/- ?rhs left right))]))\n (rule [(cons? ?p ?ps) (= (* ?&+) ?rhs)]\n :==> (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (/ ?rhs (* left right)))]))\n (rule [(cons? ?p ?ps) (= (mop/* ?&+) ?rhs)]\n :==> (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (matrix/div ?rhs (mop/* left right)))]))\n (rule [(cons? ?p ?ps) (= (- ?&+) ?rhs)]\n :==> (if (c= (count-sm ?&+) 1)\n [?ps (= ?&+ (- ?rhs))]\n (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (if (c= ?p 0)\n (+ ?rhs right)\n #_(- left right ?rhs)\n (+ (- ?rhs (first-sm left)) (rest-sm left)\n right)))])))\n (rule [(cons? ?p ?ps) (= (mop/- ?&+) ?rhs)]\n :==> (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (if (c= ?p 0)\n (mop/+ ?rhs right)\n (mop/- left right ?rhs)))]))\n (rule [(cons? ?p ?ps) (= (/ ?&+) ?rhs)]\n :==> (let [[left x right] (split-in-pos-sm ?&+ ?p)]\n [?ps (= x (if (c= ?p 0)\n (* ?rhs right)\n (/ left right ?rhs)))]))]))\n\n\n(deftest test-transform-to-polynomial-normal-form\n (is (= (ex (** x 3))\n (to-polynomial-normal-form 'x (ex (+ (** x 3) (* 3 (** x 2))\n (- (* 2 (** x 2))\n (* 5 (** x 2))))) )))\n (is (= (ex (+ (* 243.0 (** x 10)) (* 1215.0 (** x 9)) (* 4050.0 (** x 8)) (* 8910.0 (** x 7)) (* 15255.0 (** x 6)) (* 19683.0 (** x 5)) (* 20340.0 (** x 4)) (* 15840.0 (** x 3)) (* 9600.0 (** x 2)) (* 3840.0 x) 1024.0))\n (to-polynomial-normal-form 'x (ex (** (+ (* 3 x) 4 (* 3 (** x 2))) 5))))))\n\n(def disjunctive-normal-form-rules\n (construct-with [not and or]\n [(rule (not (not ?x)) :=> ?x :syntactic)\n (rule (not (or ?a ?b)) :=> (and (not ?a) (not ?b)) :syntactic)\n (rule (not (and ?a ?b)) :=> (or (not ?a) (not ?b)) :syntactic)\n (rule (and ?a (or ?b ?c)) :=> (or (and ?a ?b) (and ?a ?c)) :syntactic)\n (rule (and (or ?a ?b) ?c) :=> (or (and ?a ?c) (and ?b ?c)) :syntactic)\n (rule (and (and ?a ?b) ?c) :=> (and ?a (and ?b ?c)) :syntactic)\n (rule (or (or ?a ?b) ?c) :=> (or ?a (or ?b ?c)) :syntactic)]))\n\n(construct-with [and not or]\n (transform-with-rules disjunctive-normal-form-rules\n (or 'a (not (or 'b (and 'c (not 'd)))))))\n" }, { "path": "src/test/java/mikera/expresso/TestExpresso.java", "content": "package mikera.expresso;\n\nimport mikera.cljunit.ClojureTest;\n\npublic class TestExpresso extends ClojureTest {\n\tpublic String filter() {\n\t\treturn \"numeric.expresso\";\n\t}\n}\n" } ]