Source

lisp-random / symbolic-function.lisp

Robert Smith 138b497 























Robert Smith a12bcc0 


Robert Smith 138b497 







Robert Smith a12bcc0 
Robert Smith 138b497 










Robert Smith 69ab272 




Robert Smith 138b497 





Robert Smith a12bcc0 





Robert Smith 138b497 






Robert Smith 69ab272 
Robert Smith 138b497 





Robert Smith 69ab272 

Robert Smith 138b497 



Robert Smith e40c73b 





Robert Smith 63832bf 
Robert Smith f94737d 



Robert Smith 63832bf 










Robert Smith f94737d 
Robert Smith 63832bf 

Robert Smith f94737d 






Robert Smith 63832bf 
Robert Smith 3731226 
Robert Smith 63832bf 















Robert Smith 3731226 

Robert Smith 27929e0 























Robert Smith f94737d 
Robert Smith 27929e0 




;;;; symbolic-function.lisp
;;;; Copyright (c) 2012 Robert Smith

;;; Requires MOP.
#-closer-mop
(ql:quickload "CLOSER-MOP")

;;; A `symbolic function' is a function that holds both an executable
;;; form of itself and a symbolic form of itself.

(defclass symbolic-function ()
  ((compiled-function :initarg :compiled-function
                      :initform nil
                      :accessor symbolic-function.compiled-function)

   (parameters :initarg :parameters
               :initform nil
               :accessor symbolic-function.parameters)

   (expression :initarg :expression
               :initform nil
               :accessor symbolic-function.expression))
  (:metaclass c2mop:funcallable-standard-class))

(defvar +function-arrow+
  #+unicode "↦"
  #-unicode "->"
  "The arrow printed in the printed representation of a
  SYMBOLIC-FUNCTION.")

(defmethod print-object ((sf symbolic-function) stream)
  (print-unreadable-object (sf stream)
    (with-slots (parameters expression) sf
      (format
       stream
       "~S ~A ~S"
       (if (endp (rest parameters))
           (first parameters)
           parameters)
       +function-arrow+
       expression))))

(defun symbolic-function-lambda-form (sf)
  "Create the lambda form (data) of SF."
  `(lambda ,(symbolic-function.parameters sf)
     ,(symbolic-function.expression sf)))

(defun compile-symbolic-function (sf)
  "(Re)compile a symbolic function."
  (setf (symbolic-function.compiled-function sf)
        (compile nil (symbolic-function-lambda-form sf))))

(defun make-symbolic-function (parameters expression)
  "Make a SYMBOLIC-FUNCTION with parameters PARAMETERS and expression
  EXPRESSION."
  (make-instance 'symbolic-function :parameters parameters
                                    :expression expression))

;;; Note that a SLAMBDA body does not have a &BODY part of its lambda
;;; list to keep in spirit with the value-producing forms.
(defmacro slambda (lambda-list body)
  `(make-instance 'symbolic-function :parameters ',lambda-list
                                     :expression ',body))

(defmethod initialize-instance :after ((sf symbolic-function) &key)
  (with-slots (compiled-function parameters expression) sf
    ;; Assert PARAMETERS is a list of symbols.
    
    ;; Grab the symbolic function or compute it, and set the
    ;; FUNCALLABLE-INSTANCE-FUNCTION.
    (let ((lam (or (symbolic-function.compiled-function sf)
                   (compile-symbolic-function sf))))
      (c2mop:set-funcallable-instance-function sf lam))))

(defmacro define-symbolic-function (name param-list expression)
  "Define a symbolic function NAME with the parameters PARAM-LIST,
bound to the expression EXPRESSION."
  `(progn
     (when (fboundp ',name)
       (warn "Redefining (symbolic) function ~S." ',name))
     (setf (symbol-function ',name)
           (make-symbolic-function ',param-list
                                   ',expression))
     ',name))

(defun symbolic-compose (f sf)
  "Compose a regular function F and the symbolic function SF."
  (with-slots (parameters expression) sf
    (make-symbolic-function parameters
                            (list f expression))))

(defun function-arity (sf)
  "What is the arity of the symbolic function SF?"
  (length (symbolic-function.parameters sf)))

(defun bound-variable-p (var sf)
  "Is the variable VAR bound in the symbolic function SF?"
  (and (member var (symbolic-function.parameters sf) :test 'eq)
       t))

(defun free-variable-p (var sf)
  "Is the variable VAR free in the symbolic function SF?"
  (not (bound-variable-p var sf)))

(defun nullary-function-p (sf)
  "Is the symbolic function SF nullary?"
  (zerop (function-arity sf)))

(defun unary-function-p (sf)
  "Is the symbolic function SF unary?"
  (= 1 (function-arity sf)))

(defun binary-function-p (sf)
  "Is the symbolic function SF binary?"
  (= 2 (function-arity sf)))


;;; XXX: This should probably make a copy/new function.
(defun alpha-convert (sf new-var &optional old-var)
  (unless (nullary-function-p sf)
    (with-slots (parameters expression) sf
      (unless old-var
        (setf old-var (first parameters)))
      
      (if (bound-variable-p new-var sf)
          (error "Cannot alpha convert ~S to ~S because ~S is bound in ~S."
                 old-var
                 new-var
                 new-var
                 sf)
          (let ((subs (list (cons old-var new-var))))
            (nsublis subs parameters)
            (nsublis subs expression)))))
  sf)

;;; XXX: add substitution and beta reduction

;;; Symbolic Manipulation

;;; A very primitive differentiator
(defun diff (expr var)
  (cond
    ((symbolp expr) (if (eq expr var) 1 0))
    ((atom expr)    0)
    (t (case (first expr)
         ((+) `(+ ,(diff (second expr) var)
                  ,(diff (third expr)  var)))
         ((-) `(- ,(diff (second expr) var)
                  ,(diff (third expr)  var)))
         ((*) `(+ (* ,(diff (second expr) var)
                     ,(third expr))
                  (* ,(second expr)
                     ,(diff (third expr) var))))
         ((sin) `(* ,(diff (second expr) var)
                    (cos ,(second expr))))
         ((cos) `(- 0 (* ,(diff (second expr) var)
                         (sin ,(second expr)))))
         (t (error "Don't know how to diff ~S" expr))))))

(defun differentiate (sf)
  (assert (unary-function-p sf)
          (sf)
          "Symbolic function must have exactly one parameter.")
  (let ((var (first (symbolic-function.parameters sf)))
        (expr (symbolic-function.expression sf)))
    (make-symbolic-function (list var)
                            (diff expr var))))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.