feedforward nn

nn.lisp

(defparameter *float-format* 'long-float)
(setf *read-default-float-format* *float-format*)

(defun sigmoid (x)
  (/ (1+ (exp (- x)))))

(defun dif-sigmoid (y)
  (* y (- 1 y)))

(defun rand ()
  (- (* (random 0.1 (make-random-state t)) 2) 0.1))

(defun randtable (n m)
  (let ((table (make-array (list n m)
                           :element-type *float-format*)))
    (loop :for i :below n
       :do
       (loop :for j :below m
          :do
          (setf (aref table i j) (rand))))
    table))

(defclass neuralnet ()
  ((in-edge :type #.(list 'array *float-format*))
   (out-edge :type #.(list 'array *float-format*))
   (in-data :type #.(list 'array *float-format*))
   (hid-data :type #.(list 'array *float-format*))
   (out-data :type #.(list 'array *float-format*))
   (rate :initarg :rate
         :initform (error "Must supply rate."))
   (n-in :initarg :n-input
         :initform (error "Must supply n-input."))
   (n-hid :initarg :n-hidden
          :initform (error "Must supply n-hidden."))
   (n-out :initarg :n-output
          :initform (error "Must supply n-output."))))

(defmethod initialize-instance :after ((net neuralnet) &key)
  (with-slots (in-edge out-edge in-data hid-data out-data rate n-in n-hid n-out)
      net
    (setf in-edge (randtable n-in n-hid)
          out-edge (randtable n-hid n-out)
          in-data (make-array n-in :element-type *float-format*)
          hid-data (make-array n-hid :element-type *float-format*)
          out-data (make-array n-out :element-type *float-format*))))

(defun feed-forward (net data)
  (declare (type neuralnet net))

  (with-slots (n-in n-hid n-out in-edge out-edge in-data hid-data out-data) net
    (loop :for i :below n-in
       :do
       (setf (aref in-data i)
             (aref data i)))
    
    (loop :for j :below n-hid
       :with s := 0
       :do
       (progn
         (loop :for i :below n-in
            :do
            (incf s (* (aref in-data i)
                       (aref in-edge i j))))
         (setf (aref hid-data j) (sigmoid s))))
    
    (loop :for k :below n-out
       :with s := 0
       :do
       (progn
         (loop :for j :below n-hid
            :do
            (incf s (* (aref hid-data j)
                       (aref out-edge j k))))
         (setf (aref out-data k) (sigmoid s))))
    
    out-data))

(defun back-propagate (net data answer)
  (declare (type neuralnet net))

  (with-slots (rate n-in n-hid n-out in-edge out-edge hid-data) net
    (let ((ret (feed-forward net data))
          (out-dif (make-array n-out :element-type *float-format*))
          (hid-dif (make-array n-hid :element-type *float-format*)))

      (loop :for k :below n-out
         :do
         (setf (aref out-dif k)
               (* (- (aref answer k) (aref ret k))
                  (dif-sigmoid (aref ret k)))))

      (loop :for j :below n-hid
         :with s := 0
         :do
         (progn
           (loop :for k :below n-out
              :do
              (incf s (* (aref out-edge j k)
                         (aref out-dif k))))
           (setf (aref hid-dif j)
                 (* s (dif-sigmoid (aref hid-data j))))))

      (loop :for i :below n-in
         :do
         (loop :for j :below n-hid
            :do
            (incf (aref in-edge i j)
                  (* rate (aref hid-dif j) (aref data i)))))

      (loop :for j :below n-hid
         :do
         (loop :for k :below n-out
            :do
            (incf (aref out-edge j k)
                  (* rate (aref out-dif k) (aref hid-data j))))))))

(defvar *net* (make-instance 'neuralnet
                             :n-output 1
                             :n-input 2
                             :n-hidden 3
                             :rate 0.5))

(defvar *or-features*
  (loop :repeat 10000
     :collect
     (list
      (list (make-array 2
                        :element-type *float-format*
                        :initial-contents '(1.0 1.0))
            (make-array 1
                        :element-type *float-format*
                        :initial-contents '(1.0)))
      (list (make-array 2
                        :element-type *float-format*
                        :initial-contents '(1.0 0.0))
            (make-array 1
                        :element-type *float-format*
                        :initial-contents '(1.0)))
      (list (make-array 2
                        :element-type *float-format*
                        :initial-contents '(0.0 1.0))
            (make-array 1
                        :element-type *float-format*
                        :initial-contents '(1.0)))
      (list (make-array 2
                        :element-type *float-format*
                        :initial-contents '(0.0 0.0))
            (make-array 1
                        :element-type *float-format*
                        :initial-contents '(0.0))))))

(loop :for l :in (butlast *or-features* 10)
   :do
   (dolist (e l)
     (back-propagate *net* (first e) (second e))))

(loop :for l :in (last *or-features* 10)
   :do
   (dolist (e l)
     (format t "~A: ~A~%"
             (first e)
             (feed-forward *net* (first e)))))