[lisplab-cvs] r80 - src/core

[Jørn Inge Vestgården]

Author: jivestgarden
Date: Mon Aug 10 14:57:49 2009
New Revision: 80

Log:
some testing on symbolic stuff

Modified:
   src/core/level0-expression.lisp

Modified: src/core/level0-expression.lisp
==============================================================================
--- src/core/level0-expression.lisp	(original)
+++ src/core/level0-expression.lisp	Mon Aug 10 14:57:49 2009
@@ -25,6 +25,9 @@
 (defun expr (&rest args)
   (make-instance 'expression :list args))
 
+(defun make-expression (args)
+  (make-instance 'expression :list args))
+
 (defmethod print-object ((ex expression) stream)
   (prin1 (expression-list ex) stream))
 
@@ -102,12 +105,19 @@
 ;;;; Then the derivatives
 
 (defmethod .= ((x symbol) (y symbol) &optional whatever)
+  (declare (ignore whatever))
   (eql x y))
 
 (defmethod .log ((x symbol) &optional (n nil))
   (if x
-      (expr '.log x n)
-      (expr '.log x)))
+      (make-expression `(.log ,x ,n))
+      (make-expression `(.log ,x))))
+
+(defmethod .sin ((x symbol))
+  (make-expression `(.sin ,x)))
+
+(defmethod .cos ((x symbol))
+  (make-expression `(.cos ,x)))
 
 (defgeneric .partial (epxr var)
   (:documentation "Parial derivative of the expressions with regards to the variable."))
@@ -117,20 +127,151 @@
       1
       0))
 
-(defmethod .partial ((x expression) (y symbol)))
+(defmethod .partial ((x number) (y symbol))
+  0)
+
+(defmethod .partial ((x expression) (var symbol)) 
+  ;; The best would'we been to have no special treatment of .+ and .*, 
+  ;; and just go through the partial-of-function.
+  (let ((expr (expression-list x)))
+    (if (atom expr)
+	(.partial expr var)
+	(case (car expr)
+	  (.+ (apply #'.+ (mapcar (lambda (expr) 
+				    (.partial (make-expression expr) var)) 
+				  (cdr expr))))
+	  (.* 'todo)
+	  (t (let* ((args-val (cdr expr))
+		    (args-sym (mapcar (lambda (x) (gensym)) args-val))
+		    (pos (position var args-val)))
+	       (if pos
+		   (.partial-of-function (car expr) pos args-val) ; argument is a symbol
+		   (.* (make-expression 
+			(sublis (mapcar #'cons args-sym args-val)
+				(expression-list 
+				 (.partial-of-function (car expr) 0 args-sym))))		   
+		       (.partial (make-expression (car args-val)) ; Todo make sum
+				 var)))))))))
+
+
+
+;;; Now test the idea of symbolic functions
+
+(defclass symbolic-function ()
+  ((args :initarg :args :initform '(x y) :accessor symbolic-function-args)
+   (body :initarg :body :initform '(* x y) :accessor symbolic-function-body))
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(defmethod initialize-instance :after ((sf symbolic-function) &key) 
+  (with-slots (args body) 
+      sf 
+    (sb-mop:set-funcallable-instance-function 
+     sf
+     (let* ((args2 args)
+	    (body2 body)
+	    (code `(lambda ,args2 ,body2))
+	    (fun (eval code)))
+       fun))))
+
+(defun make-symbolic-function (args body)
+  (make-instance 'symbolic-function :args args :body body))
+
+(defmacro .fun (args &body body)
+  `(make-symbolic-function ',args ', at body))
+  
+
+(defmethod print-object ((o symbolic-function) stream)
+  (format stream "(.fun ~a ~a)" 
+	  (symbolic-function-args o)
+	  (symbolic-function-body o)))
+
+(defun change-argument-names (sf args)
+  "Makes an identical symbolic function, but with new argument names."
+  (let* ((alst (mapcar #'cons (symbolic-function-args sf) args))
+	 (new-body (sublis alst (symbolic-function-body sf))))
+    (make-symbolic-function args new-body)))
 
 (defgeneric .partial-of-function (fun arg-num args)
-  (:documentation "The parial derivive of a function"))
+  (:documentation "The parial derivive of a function. Retuns a list."))
 
 (defmethod .partial-of-function ((f (eql '.log)) (arg-num (eql 0)) args)
-  "Args must be a list"
+  ;; Args must be a list
   (if (cdr args)
-      (expr './ 1 (car args) (.log (cadr args)))
-      (expr './ (car args))))
+      (./ 1 (car args) (.log (cadr args)))
+      (./ (car args))))
 
 (defmethod .partial-of-function ((f (eql '.sin)) (arg-num (eql 0)) args)
-  (expr '.cos (car args)))
+  (.cos (car args)))
 
 (defmethod .partial-of-function ((f (eql '.cos)) (arg-num (eql 0)) args)
-  (expr '.- (expr '.sin (car args))))
+  (.- (.sin (car args))))
+
+  
+
+
+;;;; Some simplifications 
 
+(defmethod .add ((a symbolic-function) (b symbolic-function))
+  (if (equal (symbolic-function-args a)
+	      (symbolic-function-args b))
+      (make-symbolic-function 
+       (symbolic-function-args a)
+       (append '(.+) (symbolic-function-body a) (symbolic-function-body b)))
+      `(.+ ,a ,b)))
+
+
+(defmethod .mul ((a symbolic-function) (b symbolic-function))
+  (if (equal (symbolic-function-args a)
+	      (symbolic-function-args b))
+      (make-symbolic-function 
+       (symbolic-function-args a)
+       (append '(.+) (symbolic-function-body a) (symbolic-function-body b)))
+      `(.* ,a ,b)))
+
+
+
+;;; Some simple simlifications 
+
+(defmethod .add :around ((a symbol) (b number))
+  (if (eql b 0)
+      a
+      (call-next-method)))
+
+(defmethod .add :around ((b number) (a symbol))
+  (if (eql b 0)
+      a
+      (call-next-method)))
+
+(defmethod .add :around ((a expression) (b number))
+  (if (eql b 0)
+      a
+      (call-next-method)))
+
+(defmethod .add :around ((b number) (a expression))
+  (if (eql b 0)
+      a
+      (call-next-method)))
+
+(defmethod .mul :around ((a symbol) (b number))
+  (case b
+    (0 0)
+    (1 a)
+    (t (call-next-method))))
+
+(defmethod .mul :around ((b number) (a symbol))
+  (case b
+    (0 0)
+    (1 a)
+    (t (call-next-method))))
+
+(defmethod .mul :around ((a expression) (b number))
+  (case b
+    (0 0)
+    (1 a)
+    (t (call-next-method))))
+
+(defmethod .mul :around ((b number) (a expression))
+  (case b
+    (0 0)
+    (1 a)
+    (t (call-next-method))))
\ No newline at end of file