[Common Lisp][ニューラルネットワーク] 教師つきの単純なニューラルネットワーク

前回はランダムな重みづけてネットワークを作りなおしていたが、今回は期待した出力でない場合に重みをちょっとずつ修正するネットワークにした。『脳 回路網のなかの精神』の次のステップね。

ロジックは適当、実装もぐぐちゃべただけど、ちゃんと学習しているよね？だいたい10回くらいの繰り返しで、学習が完了して、期待したネットワークができあがる。

グラフィカルな表示が欲しいな。Context Free とか Processing とかだと簡単にできるのかな。

#|
単純なネットワーク
教師つき学習バージョン。

期待するネットワーク

パターン1
●    ●
○ -> ○
●    ○

パターン2
●    ○
● -> ●
●    ○

パターン3
○    ○
● -> ○
○    ●
|#

(defparameter *threshold* 0.8 "閾値")

(defparameter *delta* 0.1)

(defclass value-mixin ()
  ((value :initarg :value :initform nil :accessor value-of)))

(defclass name-mixin ()
  ((name :initarg :name :initform "unknown" :accessor name-of)))

(defclass 2layer-network ()
  ((input :initarg :input :initform nil :accessor input-of)
   (output :initarg :ouput :initform nil :accessor output-of)))

(defclass connection ()
  ((from   :initarg :from   :accessor from-of)
   (to     :initarg :to     :accessor to-of)
   (weight :initarg :weight :accessor weight-of)))

(defclass neuron (value-mixin name-mixin)
  ((froms :initarg :froms :initform nil :accessor froms-of)
   (tos :initarg :tos :initform nil :accessor tos-of))
  (:default-initargs :value 0.0))

(defmethod print-object ((x connection) stream)
  (print-unreadable-object (x stream)
    (format stream "~a *~d ~a" (name-of (from-of x)) (weight-of x)
            (name-of (to-of x)))))

(defmethod print-object ((x neuron) stream)
  (print-unreadable-object (x stream)
    (mapc (lambda (connection) (print-object connection stream))
          (tos-of x))))

(defmethod fire ((neuron neuron))
  (mapc #'fire (tos-of neuron)))

(defmethod fire ((connection connection))
  (fired (to-of connection) (weight-of connection)))

(defmethod fired ((neuron neuron) weight)
  (incf (value-of neuron) weight))

(defmethod fire-p ((neuron neuron))
  (< *threshold* (value-of neuron)))

(defmethod clear ((neuron neuron))
  (setf (value-of neuron) 0.0))

(defun init-random-weight ()
  (- (random 0.4) 0.2))

(defmethod connect ((from neuron) (to neuron)
                    &optional (weight (init-random-weight)))
  (let ((connection
         (make-instance 'connection :from from :to to :weight weight)))
    (push connection (tos-of from))
    (push connection (froms-of to))))

(defmethod get-connection ((from neuron) (to neuron))
  (find to (tos-of from) :key #'to-of))

(defmacro with-2layer-network ((inputs outputs) &body body)
  `(let ,(mapcar (lambda (x) `(,x (make-instance 'neuron :name ',x)))
          (append inputs outputs))
     (loop for i in (list ,@inputs)
           do (loop for j in (list ,@outputs)
                    do (connect i j)))
     ,@body))

(defun ensure-fire (from to)
  (if (fire-p to)
      t
      (prog1 nil
        (let ((delta *delta*)
              (connection (get-connection from to)))
          (incf (weight-of connection) delta)))))

(defun ensure-not-fire (from to)
  (if (not (fire-p to))
      t
      (prog1 nil
        (let ((delta *delta*)
              (connection (get-connection from to)))
          (decf (weight-of connection) delta)))))

(defun all-t-p (&rest args)
  (every #'identity args))

(defun main ()
  (with-2layer-network ((a b c) (x y z))
    (loop
      for i from 1
      until (all-t-p
             (not (sleep 0.5))
             (print (list i a b c))
             (prog1 (all-t-p (mapc #'fire (list a c))
                             (print (list (mapcar #'fire-p (list x y z))))
                             (ensure-fire a x)
                             (ensure-fire c x)
                             (ensure-not-fire a y)
                             (ensure-not-fire c y)
                             (ensure-not-fire a z)
                             (ensure-not-fire c z))
               (clear x) (clear y) (clear z))
             (prog1 (all-t-p (mapc #'fire (list a b c))
                             (print (list (mapcar #'fire-p (list x y z))))
                             (ensure-fire a y)
                             (ensure-fire b y)
                             (ensure-fire c y)
                             (ensure-not-fire a x)
                             (ensure-not-fire b x)
                             (ensure-not-fire c x)
                             (ensure-not-fire a z)
                             (ensure-not-fire b z)
                             (ensure-not-fire c z))
               (clear x) (clear y) (clear z))
             (prog1 (all-t-p (mapc #'fire (list b))
                             (print (list (mapcar #'fire-p (list x y z))))
                             (ensure-fire b z)
                             (ensure-not-fire b x)
                             (ensure-not-fire b y))
               (clear x) (clear y) (clear z))))))