Skip to content
Snippets Groups Projects
Commit 93dcc8c2 authored by ram's avatar ram
Browse files

;;; 11/9/90:

;;; Added some additional type declarations for maximum speed under certain
;;; Common Lisp compilers.
parent ba62abef
No related branches found
No related tags found
No related merge requests found
...@@ -46,8 +46,12 @@ ...@@ -46,8 +46,12 @@
;;; Added CHANGED-TRAINING-SET, which should be called when the training set ;;; Added CHANGED-TRAINING-SET, which should be called when the training set
;;; is changed but you don't want to reinitialize the net. This rebuilds ;;; is changed but you don't want to reinitialize the net. This rebuilds
;;; the caches. ;;; the caches.
;;;
;;; 11/9/90:
;;; Added some additional type declarations for maximum speed under certain
;;; Common Lisp compilers.
;;; *************************************************************************** ;;; ***************************************************************************
;;;
;;; This proclamation buys a certain amount of overall speed at the expense ;;; This proclamation buys a certain amount of overall speed at the expense
;;; of runtime checking. Comment it out when debugging new, bug-infested code. ;;; of runtime checking. Comment it out when debugging new, bug-infested code.
(proclaim '(optimize (speed 3) (space 0) (safety 0))) (proclaim '(optimize (speed 3) (space 0) (safety 0)))
...@@ -55,15 +59,9 @@ ...@@ -55,15 +59,9 @@
;;; Style note: Because some of these runs take a long time, this code is ;;; Style note: Because some of these runs take a long time, this code is
;;; extensively hacked for good performance under a couple of Common Lisp ;;; extensively hacked for good performance under a couple of Common Lisp
;;; systems, some of which have poor performance on multi-dimensional ;;; systems, some of which have poor performance on multi-dimensional
;;; arrays and some of which have weak type-inference int he compiler. ;;; arrays and some of which have weak type-inference in the compiler.
;;; Elegance and clarity have in some cases been sacrificed for speed. ;;; Elegance and clarity have in some cases been sacrificed for speed.
;;; The EXTENSIONS:*IGNORE-FLOATING-POINT-UNDERFLOW* switch, if non-null,
;;; says that floating point underflows should quietly return zero rather
;;; than signalling an error. If your Lisp does not have such a switch,
;;; you will either have to define an error handler for floating underflows
;;; or check for tiny values at various critical points of the code.
;;; In some problems, floating point underflow errors may occur as a result ;;; In some problems, floating point underflow errors may occur as a result
;;; of weight-decay and other operations. Most Common Lisp implementations ;;; of weight-decay and other operations. Most Common Lisp implementations
;;; have an option to turn floating underflows into zero values without ;;; have an option to turn floating underflows into zero values without
...@@ -76,10 +74,11 @@ ...@@ -76,10 +74,11 @@
;;; Compensate for the clumsy Common Lisp declaration system and weak ;;; Compensate for the clumsy Common Lisp declaration system and weak
;;; type-inference in some primitive Common Lisp compilers. INCF-SF, *SF, ;;; type-inference in some Common Lisp compilers.
;;; etc. are like INCF, *, etc., but they declare their operands and
;;; results to be short-floats. The code gets unreadable quickly if you ;;; INCF-SF, *SF, etc. are like INCF, *, etc., but they declare their
;;; insert all these declarations by hand. ;;; operands and results to be short-floats. The code gets unreadable
;;; quickly if you insert all these declarations by hand.
(defmacro incf-sf (place &optional (increment 1.0)) (defmacro incf-sf (place &optional (increment 1.0))
`(the short-float (incf (the short-float ,place) `(the short-float (incf (the short-float ,place)
...@@ -105,6 +104,12 @@ ...@@ -105,6 +104,12 @@
`(the short-float `(the short-float
(/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) (/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
;;; DOTIMES1 is like DOTIMES, only with the loop counter declared as a
;;; fixnum. This is for compilers with weak type inference.
(defmacro dotimes1 (form1 &body body)
`(dotimes ,form1 (declare (fixnum ,(car form1))) . ,body))
;;; Create vector-access forms similar to SVREF, but for vectors of ;;; Create vector-access forms similar to SVREF, but for vectors of
;;; element-type SHORT-FLOAT and FIXNUM. ;;; element-type SHORT-FLOAT and FIXNUM.
...@@ -296,9 +301,9 @@ ...@@ -296,9 +301,9 @@
"Turned briefly to T in order to continue after a pause.") "Turned briefly to T in order to continue after a pause.")
;;; The sets of training inputs and outputs are stored in parallel vectors. ;;; The sets of training inputs and outputs are stored in parallel vectors.
;;; Each element is a SIMPLE-VECTOR of short-float values, one for each ;;; Each element is a SIMPLE-VECTOR holding short-float values, one for
;;; input or output. Note: the elements are not specialized vectors of ;;; each input or output. Note: this is a simple vector, not a specialized
;;; type SHORT-FLOAT. ;;; vector of element-type short-float.
(defvar *training-inputs* (make-array 0) (defvar *training-inputs* (make-array 0)
"Vector of input patterns for training the net.") "Vector of input patterns for training the net.")
...@@ -334,9 +339,11 @@ ...@@ -334,9 +339,11 @@
(defvar *test-inputs* nil (defvar *test-inputs* nil
"Vector of input patterns for testing the net.") "Vector of input patterns for testing the net.")
(proclaim '(simple-vector *test-inputs*))
(defvar *test-outputs* nil (defvar *test-outputs* nil
"Vector of output patterns for testing the net.") "Vector of output patterns for testing the net.")
(proclaim '(simple-vector *test-outputs*))
;;;; Fundamental data structures. ;;;; Fundamental data structures.
...@@ -550,7 +557,7 @@ ...@@ -550,7 +557,7 @@
*cand-prev-slopes* (make-array *ncandidates* :initial-element nil)) *cand-prev-slopes* (make-array *ncandidates* :initial-element nil))
;; Only create the caches if *USE-CACHE* is on -- may not always have room. ;; Only create the caches if *USE-CACHE* is on -- may not always have room.
(when *use-cache* (when *use-cache*
(dotimes (i *max-cases*) (dotimes1 (i *max-cases*)
(setf (svref *values-cache* i) (setf (svref *values-cache* i)
(make-array *max-units* (make-array *max-units*
:element-type 'short-float :element-type 'short-float
...@@ -560,7 +567,7 @@ ...@@ -560,7 +567,7 @@
:element-type 'short-float :element-type 'short-float
:initial-element 0.0)))) :initial-element 0.0))))
;; For each output, create the vectors holding per-weight information. ;; For each output, create the vectors holding per-weight information.
(dotimes (i *noutputs*) (dotimes1 (i *noutputs*)
(setf (svref *output-weights* i) (setf (svref *output-weights* i)
(make-array *max-units* (make-array *max-units*
:element-type 'short-float :element-type 'short-float
...@@ -579,7 +586,7 @@ ...@@ -579,7 +586,7 @@
:initial-element 0.0))) :initial-element 0.0)))
;; For each candidate unit, create the vectors holding the correlations, ;; For each candidate unit, create the vectors holding the correlations,
;; incoming weights, and other stats. ;; incoming weights, and other stats.
(dotimes (i *ncandidates*) (dotimes1 (i *ncandidates*)
(setf (svref *cand-cor* i) (setf (svref *cand-cor* i)
(make-array *noutputs* (make-array *noutputs*
:element-type 'short-float :element-type 'short-float
...@@ -617,47 +624,39 @@ ...@@ -617,47 +624,39 @@
;; Set up the *ALL-CONNECTIONS* vector. ;; Set up the *ALL-CONNECTIONS* vector.
(setq *all-connections* (setq *all-connections*
(make-array *max-units* :element-type 'fixnum)) (make-array *max-units* :element-type 'fixnum))
(dotimes (i *max-units*) (dotimes1 (i *max-units*)
(declare (fixnum i))
(setf (ivref *all-connections* i) i)) (setf (ivref *all-connections* i) i))
;; Initialize the active unit data structures. ;; Initialize the active unit data structures.
(dotimes (i *max-units*) (dotimes1 (i *max-units*)
(declare (fixnum i))
(setf (fvref *extra-values* i) 0.0) (setf (fvref *extra-values* i) 0.0)
(setf (ivref *nconnections* i) 0) (setf (ivref *nconnections* i) 0)
(setf (svref *connections* i) nil) (setf (svref *connections* i) nil)
(setf (svref *weights* i) nil) (setf (svref *weights* i) nil)
(setf (svref *output-weights-record* i) nil)) (setf (svref *output-weights-record* i) nil))
;; Initialize the per-output data structures. ;; Initialize the per-output data structures.
(dotimes (i *noutputs*) (dotimes1 (i *noutputs*)
(declare (fixnum i))
(setf (fvref *outputs* i) 0.0) (setf (fvref *outputs* i) 0.0)
(setf (fvref *extra-errors* i) 0.0) (setf (fvref *extra-errors* i) 0.0)
(let ((ow (svref *output-weights* i)) (let ((ow (svref *output-weights* i))
(od (svref *output-deltas* i)) (od (svref *output-deltas* i))
(os (svref *output-slopes* i)) (os (svref *output-slopes* i))
(op (svref *output-prev-slopes* i))) (op (svref *output-prev-slopes* i)))
(dotimes (j *max-units*) (dotimes1 (j *max-units*)
(declare (fixnum j))
(setf (fvref ow j) 0.0) (setf (fvref ow j) 0.0)
(setf (fvref od j) 0.0) (setf (fvref od j) 0.0)
(setf (fvref os j) 0.0) (setf (fvref os j) 0.0)
(setf (fvref op j) 0.0)) (setf (fvref op j) 0.0))
;; Set up initial random weights for the input-to-output connections. ;; Set up initial random weights for the input-to-output connections.
(dotimes (j (1+ *ninputs*)) (dotimes1 (j (1+ *ninputs*))
(declare (fixnum j))
(setf (fvref ow j) (random-weight))))) (setf (fvref ow j) (random-weight)))))
;; Initialize the caches if they are in use. ;; Initialize the caches if they are in use.
(when *use-cache* (when *use-cache*
(dotimes (j *max-cases*) (dotimes1 (j *max-cases*)
(declare (fixnum j))
(let ((v (svref *values-cache* j)) (let ((v (svref *values-cache* j))
(e (svref *errors-cache* j))) (e (svref *errors-cache* j)))
(dotimes (i *max-units*) (dotimes1 (i *max-units*)
(declare (fixnum i))
(setf (fvref v i) 0.0)) (setf (fvref v i) 0.0))
(dotimes (i *noutputs*) (dotimes1 (i *noutputs*)
(declare (fixnum i))
(setf (fvref e i) 0.0))))) (setf (fvref e i) 0.0)))))
;; Candidate units get initialized in a separate routine. ;; Candidate units get initialized in a separate routine.
(init-candidates) (init-candidates)
...@@ -684,8 +683,7 @@ ...@@ -684,8 +683,7 @@
*errors-cache* (make-array *max-cases* :initial-element nil)) *errors-cache* (make-array *max-cases* :initial-element nil))
;; Only create the caches if *USE-CACHE* is on -- may not always have room. ;; Only create the caches if *USE-CACHE* is on -- may not always have room.
(when *use-cache* (when *use-cache*
(dotimes (i *max-cases*) (dotimes1 (i *max-cases*)
(declare (fixnum i))
(setf (svref *errors-cache* i) (setf (svref *errors-cache* i)
(make-array *noutputs* (make-array *noutputs*
:element-type 'short-float :element-type 'short-float
...@@ -718,7 +716,7 @@ ...@@ -718,7 +716,7 @@
;; Asymmetric sigmoid in range 0.0 to 1.0. ;; Asymmetric sigmoid in range 0.0 to 1.0.
(cond ((< sum -15.0) 0.0) (cond ((< sum -15.0) 0.0)
((> sum 15.0) 1.0) ((> sum 15.0) 1.0)
(t (/sf (+sf 1.0 (exp (-sf sum))))))) (t (/sf 1.0 (+sf 1.0 (exp (-sf sum)))))))
(:gaussian (:gaussian
;; Gaussian activation function in range 0.0 to 1.0. ;; Gaussian activation function in range 0.0 to 1.0.
(let ((x (*sf -0.5 sum sum))) (let ((x (*sf -0.5 sum sum)))
...@@ -750,7 +748,7 @@ ...@@ -750,7 +748,7 @@
(ecase *output-type* (ecase *output-type*
(:sigmoid (cond ((< sum -15.0) -0.5) (:sigmoid (cond ((< sum -15.0) -0.5)
((> sum 15.0) +0.5) ((> sum 15.0) +0.5)
(t (-sf (/sf (+sf 1.0 (exp (-sf sum)))) 0.5)))) (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5))))
(:linear sum))) (:linear sum)))
(defun output-prime (output) (defun output-prime (output)
...@@ -811,7 +809,8 @@ ...@@ -811,7 +809,8 @@
(setf (fvref deltas i) next-step) (setf (fvref deltas i) next-step)
(setf (fvref weights i) (+sf w next-step)) (setf (fvref weights i) (+sf w next-step))
(setf (fvref prevs i) s) (setf (fvref prevs i) s)
(setf (fvref slopes i) 0.0))) (setf (fvref slopes i) 0.0)
nil))
;;;; Machinery for training output weights. ;;;; Machinery for training output weights.
...@@ -821,20 +820,18 @@ ...@@ -821,20 +820,18 @@
in the values vector." in the values vector."
(declare (simple-vector input)) (declare (simple-vector input))
(setf (fvref *values* 0) 1.0) (setf (fvref *values* 0) 1.0)
(dotimes (i *ninputs*) (dotimes1 (i *ninputs*)
(declare (fixnum i))
(setf (fvref *values* (1+ i)) (setf (fvref *values* (1+ i))
(the short-float (svref input i))))) (the short-float (svref input i)))))
(defun output-forward-pass () (defun output-forward-pass ()
"Assume the *VALUES* vector has been set up. Just compute the network's "Assume the *VALUES* vector has been set up. Just compute the network's
outputs." outputs."
(dotimes (j *noutputs*) (dotimes1 (j *noutputs*)
(declare (fixnum j))
(let ((ow (svref *output-weights* j)) (let ((ow (svref *output-weights* j))
(sum 0.0)) (sum 0.0))
(declare (short-float sum)) (declare (short-float sum))
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(incf-sf sum (*sf (fvref *values* i) (fvref ow i)))) (incf-sf sum (*sf (fvref *values* i) (fvref ow i))))
(setf (fvref *outputs* j) (setf (fvref *outputs* j)
(output-function sum))))) (output-function sum)))))
...@@ -847,11 +844,11 @@ ...@@ -847,11 +844,11 @@
(w (svref *weights* j)) (w (svref *weights* j))
(sum 0.0)) (sum 0.0))
(declare (short-float sum)) (declare (short-float sum))
(dotimes (i (ivref *nconnections* j)) (dotimes1 (i (ivref *nconnections* j))
(declare (fixnum i))
(incf-sf sum (*sf (fvref *values* (ivref c i)) (incf-sf sum (*sf (fvref *values* (ivref c i))
(fvref w i)))) (fvref w i))))
(setf (fvref *values* j) (activation sum)))) (setf (fvref *values* j) (activation sum))
nil))
(defun full-forward-pass (input) (defun full-forward-pass (input)
"Set up the inputs from the INPUT vector, then propagate activation values "Set up the inputs from the INPUT vector, then propagate activation values
...@@ -878,8 +875,7 @@ ...@@ -878,8 +875,7 @@
OUTPUT-SLOPES-P is T, then use errors to compute slopes for output OUTPUT-SLOPES-P is T, then use errors to compute slopes for output
weights. If STATS-P is T, accumulate error statistics." weights. If STATS-P is T, accumulate error statistics."
(declare (simple-vector goal)) (declare (simple-vector goal))
(dotimes (j *noutputs*) (dotimes1 (j *noutputs*)
(declare (fixnum j))
(let* ((out (fvref *outputs* j)) (let* ((out (fvref *outputs* j))
(dif (-sf out (svref goal j))) (dif (-sf out (svref goal j)))
(err-prime (*sf dif (output-prime out))) (err-prime (*sf dif (output-prime out)))
...@@ -898,8 +894,7 @@ ...@@ -898,8 +894,7 @@
(incf-sf *sum-error* err-prime) (incf-sf *sum-error* err-prime)
(incf-sf *sum-sq-error* (*sf err-prime err-prime)))) (incf-sf *sum-sq-error* (*sf err-prime err-prime))))
(when output-slopes-p (when output-slopes-p
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(declare (fixnum i))
(incf-sf (fvref os i) (*sf err-prime (fvref *values* i)))))))) (incf-sf (fvref os i) (*sf err-prime (fvref *values* i))))))))
;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the ;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the
...@@ -911,14 +906,12 @@ ...@@ -911,14 +906,12 @@
"Update the output weights, using the pre-computed slopes, prev-slopes, "Update the output weights, using the pre-computed slopes, prev-slopes,
and delta values. Uses the quickprop update function." and delta values. Uses the quickprop update function."
(let ((eps (/ *output-epsilon* *ncases*))) (let ((eps (/ *output-epsilon* *ncases*)))
(dotimes (j *noutputs*) (dotimes1 (j *noutputs*)
(declare (fixnum j))
(let ((ow (svref *output-weights* j)) (let ((ow (svref *output-weights* j))
(od (svref *output-deltas* j)) (od (svref *output-deltas* j))
(os (svref *output-slopes* j)) (os (svref *output-slopes* j))
(op (svref *output-prev-slopes* j))) (op (svref *output-prev-slopes* j)))
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(declare (fixnum i))
(quickprop-update i ow od os op eps *output-decay* (quickprop-update i ow od os op eps *output-decay*
*output-mu* *output-shrink-factor*)))))) *output-mu* *output-shrink-factor*))))))
...@@ -959,13 +952,11 @@ ...@@ -959,13 +952,11 @@
"Store the output weights developed after each output-training phase "Store the output weights developed after each output-training phase
in the *ouput-weights-record* vector." in the *ouput-weights-record* vector."
(let ((record (make-array *noutputs* :initial-element nil))) (let ((record (make-array *noutputs* :initial-element nil)))
(dotimes (o *noutputs*) (dotimes1 (o *noutputs*)
(declare (fixnum o))
(let ((original (svref *output-weights* o)) (let ((original (svref *output-weights* o))
(copy (make-array *nunits* :element-type 'short-float (copy (make-array *nunits* :element-type 'short-float
:initial-element 0.0))) :initial-element 0.0)))
(dotimes (u *nunits*) (dotimes1 (u *nunits*)
(declare (fixnum u))
(setf (fvref copy u) (fvref original u))) (setf (fvref copy u) (fvref original u)))
(setf (svref record o) copy))) (setf (svref record o) copy)))
(setf (svref *output-weights-record* (1- *nunits*)) record))) (setf (svref *output-weights-record* (1- *nunits*)) record)))
...@@ -983,10 +974,9 @@ ...@@ -983,10 +974,9 @@
(first-time t)) (first-time t))
(declare (fixnum quit-epoch) (declare (fixnum quit-epoch)
(short-float last-error)) (short-float last-error))
(dotimes (i max-epochs (progn (dotimes1 (i max-epochs (progn
(record-output-weights) (record-output-weights)
:timeout)) :timeout))
(declare (fixnum i))
;; Maybe run a test epoch to see how we're doing. ;; Maybe run a test epoch to see how we're doing.
(when (and *test* (when (and *test*
(not (= 0 *test-interval*)) (not (= 0 *test-interval*))
...@@ -1014,8 +1004,7 @@ ...@@ -1014,8 +1004,7 @@
(defun init-candidates () (defun init-candidates ()
"Give new random weights to all of the candidate units. Zero the other "Give new random weights to all of the candidate units. Zero the other
candidate-unit statistics." candidate-unit statistics."
(dotimes (i *ncandidates*) (dotimes1 (i *ncandidates*)
(declare (fixnum i))
(setf (fvref *cand-sum-values* i) 0.0) (setf (fvref *cand-sum-values* i) 0.0)
(let ((cw (svref *cand-weights* i)) (let ((cw (svref *cand-weights* i))
(cd (svref *cand-deltas* i)) (cd (svref *cand-deltas* i))
...@@ -1023,14 +1012,12 @@ ...@@ -1023,14 +1012,12 @@
(cp (svref *cand-prev-slopes* i)) (cp (svref *cand-prev-slopes* i))
(cc (svref *cand-cor* i)) (cc (svref *cand-cor* i))
(cpc (svref *cand-prev-cor* i))) (cpc (svref *cand-prev-cor* i)))
(dotimes (j *nunits*) (dotimes1 (j *nunits*)
(declare (fixnum j))
(setf (fvref cw j) (random-weight)) (setf (fvref cw j) (random-weight))
(setf (fvref cd j) 0.0) (setf (fvref cd j) 0.0)
(setf (fvref cs j) 0.0) (setf (fvref cs j) 0.0)
(setf (fvref cp j) 0.0)) (setf (fvref cp j) 0.0))
(dotimes (o *noutputs*) (dotimes1 (o *noutputs*)
(declare (fixnum o))
(setf (fvref cc o) 0.0) (setf (fvref cc o) 0.0)
(setf (fvref cpc o) 0.0))))) (setf (fvref cpc o) 0.0)))))
...@@ -1045,7 +1032,7 @@ ...@@ -1045,7 +1032,7 @@
;; Copy the weight vector for the new unit. ;; Copy the weight vector for the new unit.
(let ((w (make-array *nunits* :element-type 'short-float)) (let ((w (make-array *nunits* :element-type 'short-float))
(cw (svref *cand-weights* *best-candidate*))) (cw (svref *cand-weights* *best-candidate*)))
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(setf (fvref w i) (fvref cw i))) (setf (fvref w i) (fvref cw i)))
(setf (svref *weights* *nunits*) w) (setf (svref *weights* *nunits*) w)
;; Tell user about the new unit. ;; Tell user about the new unit.
...@@ -1054,13 +1041,13 @@ ...@@ -1054,13 +1041,13 @@
;; Fix up output weights for candidate unit. ;; Fix up output weights for candidate unit.
;; Use minus the correlation times the *weight-multiplier* as an ;; Use minus the correlation times the *weight-multiplier* as an
;; initial guess. At least the sign should be right. ;; initial guess. At least the sign should be right.
(dotimes (o *noutputs*) (dotimes1 (o *noutputs*)
(setf (fvref (svref *output-weights* o) *nunits*) (setf (fvref (svref *output-weights* o) *nunits*)
(*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o)) (*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o))
*weight-multiplier*))) *weight-multiplier*)))
;; If using cache, run an epoch to compute this unit's values. ;; If using cache, run an epoch to compute this unit's values.
(when *use-cache* (when *use-cache*
(dotimes (i *max-cases*) (dotimes1 (i *max-cases*)
(setq *values* (svref *values-cache* i)) (setq *values* (svref *values-cache* i))
(compute-unit-value *nunits*))) (compute-unit-value *nunits*)))
;; Reinitialize candidate units with random weights. ;; Reinitialize candidate units with random weights.
...@@ -1096,23 +1083,20 @@ ...@@ -1096,23 +1083,20 @@
unit and begin to compute the correlation between that unit's value and unit and begin to compute the correlation between that unit's value and
the error at each output. We have already done a forward-prop and the error at each output. We have already done a forward-prop and
computed the error values for active units." computed the error values for active units."
(dotimes (u *ncandidates*) (dotimes1 (u *ncandidates*)
(declare (fixnum u))
(let ((sum 0.0) (let ((sum 0.0)
(v 0.0) (v 0.0)
(cw (svref *cand-weights* u)) (cw (svref *cand-weights* u))
(cc (svref *cand-cor* u))) (cc (svref *cand-cor* u)))
(declare (short-float sum v)) (declare (short-float sum v))
;; Determine activation value of each candidate unit. ;; Determine activation value of each candidate unit.
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(declare (fixnum i))
(incf-sf sum (*sf (fvref cw i) (incf-sf sum (*sf (fvref cw i)
(fvref *values* i)))) (fvref *values* i))))
(setq v (activation sum)) (setq v (activation sum))
(incf-sf (fvref *cand-sum-values* u) v) (incf-sf (fvref *cand-sum-values* u) v)
;; Accumulate value of each unit times error at each output. ;; Accumulate value of each unit times error at each output.
(dotimes (o *noutputs*) (dotimes1 (o *noutputs*)
(declare (fixnum o))
(incf-sf (fvref cc o) (*sf v (fvref *errors* o))))))) (incf-sf (fvref cc o) (*sf v (fvref *errors* o)))))))
;;; Note: When we were computing true correlations between candidates and ;;; Note: When we were computing true correlations between candidates and
...@@ -1133,16 +1117,14 @@ ...@@ -1133,16 +1117,14 @@
correlation score." correlation score."
(setq *best-candidate* 0) (setq *best-candidate* 0)
(setq *best-candidate-score* 0.0) (setq *best-candidate-score* 0.0)
(dotimes (u *ncandidates*) (dotimes1 (u *ncandidates*)
(declare (fixnum u))
(let* ((cc (svref *cand-cor* u)) (let* ((cc (svref *cand-cor* u))
(cpc (svref *cand-prev-cor* u)) (cpc (svref *cand-prev-cor* u))
(offset (*sf (fvref *cand-sum-values* u) *avg-error*)) (offset (*sf (fvref *cand-sum-values* u) *avg-error*))
(cor 0.0) (cor 0.0)
(score 0.0)) (score 0.0))
(declare (short-float offset cor score)) (declare (short-float offset cor score))
(dotimes (o *noutputs*) (dotimes1 (o *noutputs*)
(declare (fixnum o))
(setq cor (/sf (-sf (fvref cc o) offset) *sum-sq-error*)) (setq cor (/sf (-sf (fvref cc o) offset) *sum-sq-error*))
(setf (fvref cpc o) cor) (setf (fvref cpc o) cor)
(setf (fvref cc o) 0.0) (setf (fvref cc o) 0.0)
...@@ -1158,8 +1140,7 @@ ...@@ -1158,8 +1140,7 @@
"Given the correlation values for each candidate-output pair, compute "Given the correlation values for each candidate-output pair, compute
the derivative of the candidate's score with respect to each incoming the derivative of the candidate's score with respect to each incoming
weight." weight."
(dotimes (u *ncandidates*) (dotimes1 (u *ncandidates*)
(declare (fixnum u))
(let* ((sum 0.0) (let* ((sum 0.0)
(value 0.0) (value 0.0)
(actprime 0.0) (actprime 0.0)
...@@ -1170,16 +1151,14 @@ ...@@ -1170,16 +1151,14 @@
(cpc (svref *cand-prev-cor* u))) (cpc (svref *cand-prev-cor* u)))
(declare (short-float sum value actprime direction)) (declare (short-float sum value actprime direction))
;; Forward pass through each candidate unit to compute activation-prime. ;; Forward pass through each candidate unit to compute activation-prime.
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(declare (fixnum i))
(incf-sf sum (*sf (fvref cw i) (incf-sf sum (*sf (fvref cw i)
(fvref *values* i)))) (fvref *values* i))))
(setq value (activation sum)) (setq value (activation sum))
(setq actprime (activation-prime value sum)) (setq actprime (activation-prime value sum))
;; Now compute which way we want to adjust each unit's incoming ;; Now compute which way we want to adjust each unit's incoming
;; activation. ;; activation.
(dotimes (o *noutputs*) (dotimes1 (o *noutputs*)
(declare (fixnum o))
(let ((error (fvref *errors* o))) (let ((error (fvref *errors* o)))
(decf-sf direction (decf-sf direction
(*sf (if (minusp (fvref cpc o)) -1.0 1.0) (*sf (if (minusp (fvref cpc o)) -1.0 1.0)
...@@ -1190,8 +1169,7 @@ ...@@ -1190,8 +1169,7 @@
(incf-sf (fvref cc o) (*sf error value)))) (incf-sf (fvref cc o) (*sf error value))))
;; Given the direction we want to push the candidate, compute ;; Given the direction we want to push the candidate, compute
;; which way we want to tweak each incoming weight. ;; which way we want to tweak each incoming weight.
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(declare (fixnum i))
(incf-sf (fvref cs i) (incf-sf (fvref cs i)
(*sf direction (fvref *values* i))))))) (*sf direction (fvref *values* i)))))))
...@@ -1205,14 +1183,12 @@ ...@@ -1205,14 +1183,12 @@
"Update the input weights, using the pre-computed slopes, prev-slopes, "Update the input weights, using the pre-computed slopes, prev-slopes,
and delta values. Uses the quickprop update function." and delta values. Uses the quickprop update function."
(let ((eps (/ *input-epsilon* (* *ncases* *nunits*)))) (let ((eps (/ *input-epsilon* (* *ncases* *nunits*))))
(dotimes (u *ncandidates*) (dotimes1 (u *ncandidates*)
(declare (fixnum u))
(let ((cw (svref *cand-weights* u)) (let ((cw (svref *cand-weights* u))
(cd (svref *cand-deltas* u)) (cd (svref *cand-deltas* u))
(cs (svref *cand-slopes* u)) (cs (svref *cand-slopes* u))
(cp (svref *cand-prev-slopes* u))) (cp (svref *cand-prev-slopes* u)))
(dotimes (i *nunits*) (dotimes1 (i *nunits*)
(declare (fixnum i))
(quickprop-update i cw cd cs cp eps *input-decay* (quickprop-update i cw cd cs cp eps *input-decay*
*input-mu* *input-shrink-factor*)))))) *input-mu* *input-shrink-factor*))))))
...@@ -1278,8 +1254,7 @@ ...@@ -1278,8 +1254,7 @@
(first-time t)) (first-time t))
(declare (fixnum quit) (declare (fixnum quit)
(short-float last-score)) (short-float last-score))
(dotimes (i max-epochs :timeout) (dotimes1 (i max-epochs :timeout)
(declare (fixnum i))
(train-inputs-epoch) (train-inputs-epoch)
(cond ((zerop *input-patience*)) (cond ((zerop *input-patience*))
(first-time (first-time
...@@ -1318,11 +1293,10 @@ ...@@ -1318,11 +1293,10 @@
(unless restart (init-net)) (unless restart (init-net))
(list-parameters) (list-parameters)
(when *use-cache* (when *use-cache*
(dotimes (i *max-cases*) (dotimes1 (i *max-cases*)
(setq *values* (svref *values-cache* i)) (setq *values* (svref *values-cache* i))
(set-up-inputs (svref *training-inputs* i)))) (set-up-inputs (svref *training-inputs* i))))
(dotimes (r rounds :lose) (dotimes1 (r rounds :lose)
(declare (fixnum r))
(case (train-outputs outlimit) (case (train-outputs outlimit)
(:win (:win
(list-parameters) (list-parameters)
...@@ -1357,7 +1331,7 @@ ...@@ -1357,7 +1331,7 @@
(*sum-error* 0.0) (*sum-error* 0.0)
(*sum-sq-error* 0.0)) (*sum-sq-error* 0.0))
;; Run all training patterns and count errors. ;; Run all training patterns and count errors.
(dotimes (i (length *training-inputs*)) (dotimes1 (i (length *training-inputs*))
(setq *goal* (svref *training-outputs* i)) (setq *goal* (svref *training-outputs* i))
(full-forward-pass (svref *training-inputs* i)) (full-forward-pass (svref *training-inputs* i))
(compute-errors *goal* nil t)) (compute-errors *goal* nil t))
...@@ -1370,7 +1344,7 @@ ...@@ -1370,7 +1344,7 @@
(setq *sum-sq-error* 0.0) (setq *sum-sq-error* 0.0)
;; Now run all test patterns and report the results. ;; Now run all test patterns and report the results.
(when *test-inputs* (when *test-inputs*
(dotimes (i (length *test-inputs*)) (dotimes1 (i (length *test-inputs*))
(setq *goal* (svref *test-outputs* i)) (setq *goal* (svref *test-outputs* i))
(full-forward-pass (svref *test-inputs* i)) (full-forward-pass (svref *test-inputs* i))
(compute-errors *goal* nil t))) (compute-errors *goal* nil t)))
...@@ -1385,6 +1359,7 @@ ...@@ -1385,6 +1359,7 @@
(setq *nunits* nunits) (setq *nunits* nunits)
(do ((i (1+ *ninputs*) (1+ i))) (do ((i (1+ *ninputs*) (1+ i)))
((= i *nunits*)) ((= i *nunits*))
(declare (fixnum i))
(setf (ivref *nconnections* i) i) (setf (ivref *nconnections* i) i)
(setf (svref *connections* i) *all-connections*))) (setf (svref *connections* i) *all-connections*)))
...@@ -1402,7 +1377,7 @@ ...@@ -1402,7 +1377,7 @@
(setq *noutputs* 1) (setq *noutputs* 1)
(let ((ti (make-array (* 2 n))) (let ((ti (make-array (* 2 n)))
(to (make-array (* 2 n)))) (to (make-array (* 2 n))))
(dotimes (i n) (dotimes1 (i n)
(setf (svref ti (* i 2)) (setf (svref ti (* i 2))
(vector (+ i 1.0))) (vector (+ i 1.0)))
(setf (svref to (* i 2)) (setf (svref to (* i 2))
...@@ -1427,11 +1402,12 @@ ...@@ -1427,11 +1402,12 @@
(defun build-two-spirals (&optional (n 97)) (defun build-two-spirals (&optional (n 97))
"Build N point-pairs of the two-spiral problem, with standard default "Build N point-pairs of the two-spiral problem, with standard default
of 97 pairs." of 97 pairs."
(declare (fixnum n))
(setq *ninputs* 2) (setq *ninputs* 2)
(setq *noutputs* 1) (setq *noutputs* 1)
(let ((ti (make-array (* 2 n))) (let ((ti (make-array (* 2 n)))
(to (make-array (* 2 n)))) (to (make-array (* 2 n))))
(dotimes (i n) (dotimes1 (i n)
(let* ((angle (/ (* i (coerce pi 'short-float)) 16.0)) (let* ((angle (/ (* i (coerce pi 'short-float)) 16.0))
(radius (/ (* 6.5 (- 104.0 i)) 104)) (radius (/ (* 6.5 (- 104.0 i)) 104))
(x (* radius (sin angle))) (x (* radius (sin angle)))
...@@ -1463,4 +1439,10 @@ ...@@ -1463,4 +1439,10 @@
;;; IMu 2.00, IEps 100.00, IDcy 0.00000, IPat 8, IChange 0.030 ;;; IMu 2.00, IEps 100.00, IDcy 0.00000, IPat 8, IChange 0.030
;;; Utype :SIGMOID, Otype :SIGMOID, RawErr NIL, Pool 8 ;;; Utype :SIGMOID, Otype :SIGMOID, RawErr NIL, Pool 8
(defun time-two-spirals ()
(setq *random-state* (make-random-state))
(build-two-spirals)
(time (train 100 100 25)))
;;; The End. ;;; The End.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment