;;; Lisplab, level0-expression.lisp
;;; Lazy, simple symbolic expressions

;;; Copyright (C) 2009 Joern Inge Vestgaarden
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License along
;;; with this program; if not, write to the Free Software Foundation, Inc.,
;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

(in-package :lisplab)

(defclass expression-base () 
  ()
  (:documentation "Represents symbolic expressions."))

(defclass whatever (expression-base)
  ()
  (:documentation "Matches anything."))

(defclass symbol-expression (expression-base)
  ((symbol :initarg :symbol :accessor expression-symbol :initform nil))
  (:documentation "Matches the same symbol. "))



(defclass list-expression (expression-base)
  ((list :accessor expression-list :initform nil :initarg :list))
  (:documentation "A collection of expressions."))

(defclass rule-base ()
  ((name :accessor rule-name :initarg :name :initform nil)))

(defclass function-rule (rule-base) 
  ((arg :accessor rule-arg :initarg :arg :initform nil)
   (val :accessor rule-val :initarg :val :initform nil)))
				     

(defclass relation-rule (rule-base) 
  ((a :accessor rule-a :initarg :a :initform nil)
   (b :accessor rule-b :initarg :b :initform nil)
   (val :accessor rule-val :initarg :val :initform nil)))

(defvar *rules* nil)

(defun add-rule (rule)
  (push rule *rules*))

(defgeneric applicable-p (rule expr))

(defgeneric apply-rule (rule expr))

(defgeneric match-p (expr pat))

(defmethod match-p (expr pat)
  nil)

(defmethod match-p (expr (pat whatever))
  t)

(defmethod match-p ((expr symbol-expression) (pat symbol-expression))
  (eql (expression-symbol expr)
       (expression-symbol pat)))

(defmethod match-p ((expr list-expression) (pat list-expression))
  (every #'match-p 
	 (expression-list expr)
	 (expression-list pat)))



(defmethod applicable-p (rule expr) nil)

(defmethod applicable-p ((rule function-rule) (expr list-expression))
  (let ((elms (expression-list expr)))
    (if (< (length elms) 2)
	nil
	(and (match-p (rule-name rule) (car elms))
	     (match-p (rule-arg rule) (cadr elms))))))

	     
;;; Just simple integration with lisplab 

(defmethod print-object ((ex symbol-expression) stream)
  (prin1 (expression-symbol ex) stream))

(defmethod print-object ((ex list-expression) stream)
  (prin1 (expression-list ex) stream))


;;; Bellow is just cut and paste code to simplify debugging. Must do it properly later

(defmethod .= ((a symbol) (b symbol) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .= ((a symbol) (b number) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .= ((a number) (b symbol) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .= ((a expression-base) (b symbol) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .= ((a symbol) (b expression-base) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .= ((a expression-base) (b number) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .= ((a number) (b expression-base) &optional acc)
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.=)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a symbol) (b symbol))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a symbol) (b number))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a number) (b symbol))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a expression-base) (b symbol))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a symbol) (b expression-base))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a expression-base) (b number))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .add ((a number) (b expression-base))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.+)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))




(defmethod .mul ((a symbol) (b symbol))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .mul ((a symbol) (b number))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .mul ((a number) (b symbol))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .mul ((a expression-base) (b symbol))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .mul ((a symbol) (b expression-base))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .mul ((a expression-base) (b number))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))

(defmethod .mul ((a number) (b expression-base))
  (make-instance 'list-expression 
		 :list (list (make-instance 'symbol-expression :symbol '.*)
			     (make-instance 'symbol-expression :symbol a)
			     (make-instance 'symbol-expression :symbol b))))












#|


(defclass expression ()
  ((list :accessor expression-list :initform nil :initarg :list)))

(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))

(defmacro def-num-sym-method (name op)
  (let ((a (gensym))
	(b (gensym)))
    `(progn 
       (defmethod ,name ((,a number) (,b symbol))
	 (expr ',op ,a ,b))
       (defmethod ,name ((,a symbol) (,b number))
	 (expr ',op ,a ,b)))))
       
(def-num-sym-method .add .+)
(def-num-sym-method .mul .*)
(def-num-sym-method .div ./)
(def-num-sym-method .sub .-)
(def-num-sym-method .expt .^)

(defmacro def-sym-sym-method (name op)
  (let ((a (gensym))
	(b (gensym)))
    `(progn 
       (defmethod ,name ((,a symbol) (,b symbol))
	 (expr ',op ,a ,b)))))
       
(def-sym-sym-method .add .+)
(def-sym-sym-method .mul .*)
(def-sym-sym-method .div ./)
(def-sym-sym-method .sub .-)
(def-sym-sym-method .expt .^)

(defmacro def-expr-expr-method (name op)
  (let ((a (gensym))
	(b (gensym)))
    `(progn 
       (defmethod ,name ((,a expression) (,b expression))
	 (expr ',op (expression-list ,a) (expression-list ,b))))))
       
(def-expr-expr-method .add .+)
(def-expr-expr-method .mul .*)
(def-expr-expr-method .div ./)
(def-expr-expr-method .sub .-)
(def-expr-expr-method .expt .^)

(defmacro def-num-expr-method (name op)
  (let ((a (gensym))
	(b (gensym)))
    `(progn 
       (defmethod ,name ((,a number) (,b expression))
	 (expr ',op ,a (expression-list ,b)))
       (defmethod ,name ((,a expression) (,b number))
	 (expr ',op (expression-list ,a) ,b)))))

(def-num-expr-method .add .+)
(def-num-expr-method .mul .*)
(def-num-expr-method .div ./)
(def-num-expr-method .sub .-)
(def-num-expr-method .expt .^)

(defmacro def-sym-expr-method (name op)
  (let ((a (gensym))
	(b (gensym)))
    `(progn 
       (defmethod ,name ((,a symbol) (,b expression))
	 (expr ',op ,a (expression-list ,b)))
       (defmethod ,name ((,a expression) (,b symbol))
	 (expr ',op (expression-list ,a) ,b)))))

(def-sym-expr-method .add .+)
(def-sym-expr-method .mul .*)
(def-sym-expr-method .div ./)
(def-sym-expr-method .sub .-)
(def-sym-expr-method .expt .^)

;;;; 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
      (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."))

(defmethod .partial ((x symbol) (y symbol))
  (if (eql x y)
      1
      0))

(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 ',@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. Retuns a list."))

(defmethod .partial-of-function ((f (eql '.log)) (arg-num (eql 0)) args)
  ;; Args must be a list
  (if (cdr args)
      (./ 1 (car args) (.log (cadr args)))
      (./ (car args))))

(defmethod .partial-of-function ((f (eql '.sin)) (arg-num (eql 0)) args)
  (.cos (car args)))

(defmethod .partial-of-function ((f (eql '.cos)) (arg-num (eql 0)) 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))))

|#