home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / r / rcc1.zip / rcc1 / rcc1.lisp < prev   
Lisp/Scheme  |  1991-10-10  |  62KB  |  1,598 lines

  1. ;;; -*- Mode:Lisp -*-
  2. ;;; ***************************************************************************
  3. ;;; Recurrent Cascade-Correlation simulator, Common Lisp version.
  4. ;;; 
  5. ;;; Written by:   Scott E. Fahlman
  6. ;;;               School of Computer Science
  7. ;;;               Carnegie-Mellon University
  8. ;;;               Pittsburgh, PA 15217
  9. ;;;
  10. ;;;               Phone: (412) 268-2575
  11. ;;;               Internet: fahlman@cs.cmu.edu
  12. ;;;
  13. ;;; This code has been placed in the public domain by the author.  As a
  14. ;;; matter of simple courtesy, anyone using or adapting this code is
  15. ;;; expected to acknowledge the source.  The author would like to hear
  16. ;;; about any attempts to use this system, successful or not.
  17. ;;;
  18. ;;; For an explanation of this algorithm and some results, see "The
  19. ;;; Recurrent Cascade-Correlation Learning Architecture" by Scott E.
  20. ;;; Fahlman in D. S. Touretzky (ed.), "Advances in Neural Information
  21. ;;; Processing Systems 3", Morgan Kaufmann, 1991.  A somewhat longer
  22. ;;; version is available as CMU Computer Science Tech Report CMU-CS-91-100.
  23. ;;; ***************************************************************************
  24.  
  25. ;;; This proclamation buys a certain amount of overall speed at the expense
  26. ;;; of runtime checking.  Comment it out when debugging new, bug-infested code.
  27. (proclaim '(optimize (speed 3) (space 0) (safety 0)))
  28.  
  29. ;;; Style note: Because some of these runs take a long time, this code is
  30. ;;; extensively hacked for good performance under CMU Common Lisp.
  31. ;;; Elegance and clarity have in some cases been sacrificed for speed.
  32.  
  33. ;;; The EXTENSIONS:*IGNORE-FLOATING-POINT-UNDERFLOW* switch, if non-null,
  34. ;;; says that floating point underflows should quietly return zero rather
  35. ;;; than signalling an error.  Underflows occur only in a few tasks, so it
  36. ;;; may be possible to get along without a switch of this sort.  
  37. ;;; (setq extensions:*ignore-floating-point-underflow* t)
  38.  
  39. ;;; Compensate for the clumsy Common Lisp declaration system and weak
  40. ;;; type-inference in some primitive Common Lisp compilers.  INCF-SF, *SF,
  41. ;;; etc. are like INCF, *, etc., but they declare their operands and
  42. ;;; results to be short-floats.  The code gets unreadable quickly if you
  43. ;;; insert all these declarations by hand.
  44.  
  45. (defmacro incf-sf (place &optional (increment 1.0))
  46.   `(the short-float (incf (the short-float ,place)
  47.               (the short-float ,increment))))
  48.  
  49. (defmacro decf-sf (place &optional (increment 1.0))
  50.   `(the short-float (decf (the short-float ,place)
  51.               (the short-float ,increment))))
  52.  
  53. (defmacro *sf (&rest args)
  54.   `(the short-float
  55.     (* ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
  56.  
  57. (defmacro +sf (&rest args)
  58.   `(the short-float
  59.     (+ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
  60.  
  61. (defmacro -sf (&rest args)
  62.   `(the short-float
  63.     (- ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
  64.  
  65. (defmacro /sf (&rest args)
  66.   `(the short-float
  67.     (/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args))))
  68.  
  69. ;;; DOTIMES1 is like DOTIMES, only with the loop counter declared as a
  70. ;;; fixnum.  This is for compilers with weak type inference.
  71.  
  72. (defmacro dotimes1 (form1 &body body)
  73.   `(dotimes ,form1 (declare (fixnum ,(car form1))) . ,body))
  74.  
  75. ;;; Create vector-access forms similar to SVREF, but for vectors of
  76. ;;; element-type SHORT-FLOAT and FIXNUM.
  77.  
  78. (eval-when (compile load eval)
  79.   (defconstant fvector-type
  80.     (array-element-type (make-array '(1) :element-type 'short-float)))
  81.   (defconstant ivector-type
  82.     (array-element-type (make-array '(1) :element-type 'fixnum))))
  83.  
  84. (defmacro fvref (a i)
  85.   "Like SVREF, but with vectors of element-type SHORT-FLOAT."
  86.   (if (eq fvector-type t)
  87.     `(the short-float (svref ,a ,i))
  88.     `(the short-float (aref (the (simple-array ,fvector-type (*)) ,a) ,i))))
  89.  
  90. (defmacro ivref (a i)
  91.   "Like SVREF, but with vectors of element-type FIXNUM."
  92.   (if (eq ivector-type t)
  93.     `(the fixnum (svref ,a ,i))
  94.     `(the fixnum (aref (the (simple-array ,ivector-type (*)) ,a) ,i))))
  95.  
  96.  
  97. ;;;; Assorted Parameters and Controls.
  98.  
  99. ;;; Thse parameters and switches control the quickprop learning algorithm
  100. ;;; used to train the output weights and candidate units.
  101.  
  102. (defvar *unit-type* :sigmoid
  103.   "The type of activation function used by the hidden units.  Options
  104.   currently implemented are :sigmoid, :asigmoid, and :gaussian.  Sigmoid is
  105.   symmetric in range -0.5 to +0.5, while Asigmoid is asymmetric, 0.0 to
  106.   1.0.")
  107.  
  108. (defvar *output-type* :sigmoid
  109.   "The activation function to use on the output units.  Options currently
  110.   implemented are :linear and :sigmoid.")
  111.  
  112. (defvar *sigmoid-prime-offset* 0.1
  113.   "This is added to the derivative of the sigmoid function to prevent the
  114.   system from getting stuck at the points where sigmoid-prime goes to
  115.   zero.")
  116. (proclaim '(short-float *sigmoid-prime-offset*))
  117.  
  118. (defvar *weight-range* 1.0
  119.   "Input weights in the network get inital random values between plus and
  120.   minus *weight-range*.  This parameter also controls the initial weights
  121.   on direct input-to-output links.")
  122. (proclaim '(short-float *weight-range*))
  123.  
  124. (defvar *weight-multiplier* 1.0
  125.   "The output weights for cadidate units get an initial value that is the
  126.   negative of the correlation times this factor.")
  127. (proclaim '(short-float *weight-multiplier*))
  128.  
  129. (defvar *output-mu* 2.0
  130.   "Mu parmater used for quickprop training of output weights.  The
  131.   step size is limited to mu times the previous step.")
  132. (proclaim '(short-float *output-mu*))
  133.  
  134. (defvar *output-shrink-factor* (/ *output-mu* (+ 1.0 *output-mu*))
  135.   "Derived from *output-mu*.  Used in computing whether the proposed step is
  136.   too large.")
  137. (proclaim '(short-float *output-shrink-factor*))
  138.  
  139. (defvar *output-epsilon* 0.35
  140.   "Controls the amount of linear gradient descent to use in updating
  141.   output weights.")
  142. (proclaim '(short-float *output-epsilon*))
  143.  
  144. (defvar *output-decay* 0.0001
  145.   "This factor times the current weight is added to the slope at the
  146.   start of each output-training epoch.  Keeps weights from growing too big.")
  147. (proclaim '(short-float *output-decay*))
  148.  
  149. (defvar *output-patience* 12
  150.   "If we go for this many epochs with no significant change, it's time to
  151.   stop tuning.  If 0, go on forever.")
  152. (proclaim '(fixnum *output-patience*))
  153.  
  154. (defvar *output-change-threshold* 0.01
  155.   "The error must change by at least this fraction of its old value in
  156.   order to count as a significant change.")
  157. (proclaim '(short-float *output-change-threshold*))
  158.  
  159. (defvar *input-mu* 2.0
  160.   "Mu parmater used for quickprop training of input weights.  The
  161.   step size is limited to mu times the previous step.")
  162. (proclaim '(short-float *input-mu*))
  163.  
  164. (defvar *input-shrink-factor* (/ *input-mu* (+ 1.0 *input-mu*))
  165.   "Derived from *input-mu*.  Used in computing whether the proposed step is
  166.   too large.")
  167. (proclaim '(short-float *input-shrink-factor*))
  168.  
  169. (defvar *input-epsilon* 1.0
  170.   "Controls the amount of linear gradient descent to use in updating
  171.   unit input weights.")
  172. (proclaim '(short-float *input-epsilon*))
  173.  
  174. (defvar *input-decay* 0.0
  175.   "This factor times the current weight is added to the slope at the
  176.   start of each output-training epoch.  Keeps weights from growing too big.")
  177. (proclaim '(short-float *input-decay*))
  178.  
  179. (defvar *input-patience* 8
  180.   "If we go for this many epochs with no significant change, it's time to
  181.   stop tuning.  If 0, go on forever.")
  182. (proclaim '(fixnum *input-patience*))
  183.  
  184. (defvar *input-change-threshold* 0.03
  185.   "The correlation score for the best unit must change by at least
  186.   this fraction of its old value in order to count as a significant
  187.   change.")
  188. (proclaim '(short-float *input-change-threshold*))
  189.  
  190. ;;; Variables related to error and correlation.
  191.  
  192. (defvar *score-threshold* 0.4
  193.   "An output is counted as correct for a given case if the difference
  194.   between that output and the desired value is smaller in magnitude than
  195.   this value.")
  196. (proclaim '(short-float *score-threshold*))
  197.  
  198. (defvar *error-bits* 0
  199.   "Count number of bits in epoch that are wrong by more than
  200.   *SCORE-THRESHOLD*")
  201. (proclaim '(fixnum *error-bits*))
  202.  
  203. (defvar *true-error* 0.0
  204.   "The sum-squared error at the network outputs.  This is the value the
  205.   algorithm is ultimately trying to minimize.")
  206. (proclaim '(short-float *true-error*))
  207.  
  208. (defvar *sum-sq-error* 0.0
  209.   "Accumulate the sum of the squared error values after output
  210.   training phase.")
  211. (proclaim '(short-float *sum-sq-error*))
  212.  
  213. (defvar *best-candidate-score* 0.0
  214.   "The best correlation score found among all candidate units being
  215.   trained.")
  216. (proclaim '(short-float *best-candidate-score*))
  217.  
  218. (defvar *best-candidate* 0
  219.   "The index of the candidate unit whose correlation score is best
  220.   at present.")
  221. (proclaim '(fixnum *best-candidate*))
  222.  
  223. ;;; These variables and switches control the simulation.
  224.  
  225. (defvar *use-cache* t
  226.   "If T, cache the forward-pass values instead of repeatedly
  227.   computing them.  This can save a *lot* of time if all the cached values
  228.   fit into memory.")
  229.  
  230. (defparameter *epoch* 0
  231.   "Count of the number of times the entire training set has been presented.")
  232. (proclaim '(fixnum *epoch*))
  233.  
  234. (defvar *done* nil
  235.   "Set to T whenever some problem-specific test function wants to abort
  236.   processing.")
  237.  
  238. (defvar *test* t
  239.   "If T, run a test epoch every so often during output training.")
  240.  
  241. (defvar *test-interval* 0
  242.   "Run a test epoch every *test-interval* output training cycles.")
  243. (proclaim '(fixnum *test-interval*)) 
  244.  
  245. (defvar *single-pass* nil
  246.   "When on, pause after next forward/backward cycle.")
  247.  
  248. (defvar *single-epoch* nil
  249.   "When on, pause after next training epoch.")
  250.  
  251. (defparameter *step* nil
  252.   "Turned briefly to T in order to continue after a pause.")
  253.  
  254. ;;; The sets of training inputs and outputs are stored in parallel vectors.
  255. ;;; Each element is a SIMPLE-VECTOR holding short-float values, one for
  256. ;;; each input or output.  Note: this is a simple vector, not a specialized
  257. ;;; vector of element-type short-float.
  258.  
  259. (defvar *training-inputs* (make-array 0)
  260.   "Vector of input patterns for training the net.")
  261. (proclaim '(simple-vector *training-inputs*))
  262.  
  263. (defvar *training-outputs* (make-array 0)
  264.   "Vector of output patterns for training the net.")
  265. (proclaim '(simple-vector *training-outputs*))
  266.  
  267. (defvar *use-training-breaks* nil
  268.   "If true, use the training breaks vector.  Else, never break.")
  269.  
  270. (defvar *training-breaks* (make-array 0)
  271.   "If *use-training-breaks* is true, this must be a simple vector with
  272.   one entry, T or NIL, for each training case.  If T, zero all accumulated
  273.   state before processing this case.")
  274. (proclaim '(type simple-vector *training-breaks*))
  275.  
  276. ;;; Test inputs and outputs are just the same in form as training inputs
  277. ;;; and outputs.  If there is to be no distinct test set, just set
  278. ;;; *test-inputs* EQ to *training-inputs*.
  279.  
  280. (defvar *test-inputs* *training-inputs*
  281.   "Vector of input patterns for testing the net.")
  282. (proclaim '(simple-vector *test-inputs*))
  283.  
  284. (defvar *test-outputs* *training-outputs*
  285.   "Vector of output patterns for testing the net.")
  286. (proclaim '(simple-vector *test-outputs*))
  287.  
  288. (defvar *use-test-breaks* nil
  289.   "If true, use the test breaks vector.  Else, never break.")
  290.  
  291. (defvar *test-breaks* *training-breaks*
  292.   "If *use-test-breaks* is true, this must be a simple vector with
  293.   one entry, T or NIL, for each test case.  If T, zero all accumulated
  294.   state before processing this case.")
  295. (proclaim '(type simple-vector *test-breaks*))
  296.  
  297. ;;; Some other data structures and parameters that control training.
  298.  
  299. (defvar *max-cases* 0
  300.   "Maximum number of training cases that can be accommdated by the current
  301.   data structures.")
  302. (proclaim '(fixnum *max-cases*))
  303.  
  304. (defvar *ncases* 0
  305.   "Number of training cases currently in use.  Assume a contiguous block
  306.   beginning with *FIRST-CASE*.")
  307. (proclaim '(fixnum *ncases*))
  308.  
  309. (defvar *first-case* 0
  310.   "Address of the first training case in the currently active set.  Usually
  311.   zero, but may differ if we are training on different chunks of the training
  312.   set at different times.")
  313. (proclaim '(fixnum *first-case*))
  314.  
  315.  
  316. ;;;; Fundamental data structures.
  317.  
  318. ;;; Unit values and weights are short flonums.
  319.  
  320. ;;; Instead of representing each unit by a structure, we represent the
  321. ;;; unit by a fixnum.  This is used to index into various vectors that hold
  322. ;;; per-unit information, such as the activation value of each unit.
  323. ;;; So the information concerning a given unit is found in a slice of values
  324. ;;; across many vectors, all with the same unit-index.
  325.  
  326. ;;; Per-connection information for each connection COMING INTO unit is
  327. ;;; stored in a vector of vectors.  The outer vector is indexed by the unit
  328. ;;; number, and the inner vector is then indexed by connection number.
  329. ;;; This is a sleazy way of implementing a 2-D array, faster in most Lisp
  330. ;;; systems than multiplying to do the index arithmetic.
  331.  
  332. ;;; In this version, we assume that each unit gets input from all previous
  333. ;;; units, in order.  Unit 0, the "bias unit" is always at a maximum-on
  334. ;;; value.  Next come some input "units", then some hidden units.  The
  335. ;;; final incoming weight is the recurrent self-connection.
  336.  
  337. ;;; Output units have their own separate set of data structures and
  338. ;;; indices.  The units and outputs together form the "active" network.
  339. ;;; There are also separate data structures and indices for the "candidate"
  340. ;;; units that have not yet been added to the network.
  341.  
  342. (defvar *max-units* 100
  343.   "Maximum number of input values and hidden units in the network.")
  344. (proclaim '(fixnum *max-units*))
  345.  
  346. (defvar *ninputs* 0
  347.   "Number of inputs for this problem.")
  348. (proclaim '(fixnum *ninputs*))
  349.  
  350. (defvar *noutputs* 0
  351.   "Number of outputs for this problem.")
  352. (proclaim '(fixnum *noutputs*))
  353.  
  354. (defvar *nunits* 0
  355.   "Current number of active units in the network.  This count includes all
  356.   external inputs to the network and the bias unit.")
  357. (proclaim '(fixnum *nunits*))
  358.  
  359. (defvar *ncandidates* 8
  360.   "Number of candidate units whose inputs will be trained at once.")
  361. (proclaim '(fixnum *ncandidates*))
  362.  
  363. ;;; The following vectors hold values related to hidden units in the active
  364. ;;; net and their input weights.  The vectors are created by BUILD-NET, after
  365. ;;; the dimension variables have been set up.
  366.  
  367. (defvar *values* (make-array 0 :element-type 'short-float)
  368.   "Vector holding the current activation value for each unit and input in
  369.   the active net.")
  370. (proclaim '(type (vector short-float) *values*))
  371.  
  372. (defvar *values-cache* (make-array 0)
  373.   "Holds a distinct *VALUES* vector for each of the *MAX-CASES* training
  374.   cases.  Once we have computed the *VALUES* vector for each training case,
  375.   we can use it repeatedly until the weights or training cases change.")
  376. (proclaim '(simple-vector *values-cache*))
  377.  
  378. (defvar *extra-values* (make-array 0 :element-type 'short-float)
  379.   "Extra values vector to use when not using the cache.")
  380. (proclaim '(type (vector short-float) *extra-values*))
  381.  
  382. (defvar *weights* (make-array 0)
  383.   "Vector of vectors.  Each entry gives the weight associated with an
  384.   incoming connection.")
  385. (proclaim '(simple-vector *weights*))
  386.  
  387. ;;; The following vectors hold values for the outputs of the active
  388. ;;; network and the output-side weights.
  389.  
  390. (defvar *outputs* (make-array 0 :element-type 'short-float)
  391.   "Vector holding the network output values.")
  392. (proclaim '(type (vector short-float) *outputs*))
  393.  
  394. (defvar *errors* (make-array 0 :element-type 'short-float)
  395.   "Vector holding the current error value for each output.")
  396. (proclaim '(type (vector short-float) *errors*))
  397.  
  398. (defvar *errors-cache* (make-array 0)
  399.   "Holds a distinct *ERRORS* vector for each of the *MAX-CASES* training
  400.   cases.  Once we have computed the *ERRORS* vector for a given training
  401.   case, we can use it repeatedly until the weights of the training cases
  402.   change.")
  403. (proclaim '(simple-vector *errors-cache*))
  404.  
  405. (defvar *extra-errors* (make-array 0 :element-type 'short-float)
  406.   "Extra errors vector to use when not using the cache.")
  407. (proclaim '(type (vector short-float) *extra-errors*))
  408.  
  409. (defvar *sum-errors* (make-array 0 :element-type 'short-float)
  410.   "Accumulate for each output the sum of the error values over a whole
  411.   output training epoch.")
  412. (proclaim '(type (vector short-float) *sum-errors*))
  413.  
  414. (defvar *dummy-sum-errors* (make-array 0 :element-type 'short-float)
  415.   "Replace sum-errors with this during test epochs.")
  416. (proclaim '(type (vector short-float) *dummy-sum-errors*))
  417.  
  418. (defvar *output-weights* (make-array 0)
  419.   "Vector of vectors.  For each output, we have a vector of output weights
  420.   coming from the unit indicated by the index.")
  421. (proclaim '(simple-vector *output-weights*))
  422.  
  423. (defvar *output-deltas* (make-array 0)
  424.   "Vector of vectors, parallel with output weights.  Each entry is the
  425.   amount by which the corresponding output weight was changed last time.")
  426. (proclaim '(simple-vector *output-deltas*))
  427.  
  428. (defvar *output-slopes* (make-array 0)
  429.   "Vector of vectors, parallel with output weights.  Each entry is the
  430.   partial derivative of the total error with repsect to the corresponding
  431.   weight.")
  432. (proclaim '(simple-vector *output-slopes*))
  433.  
  434. (defvar *output-prev-slopes* (make-array 0)
  435.   "Vector of vectors, parallel with output weights.  Each entry is the
  436.   previous value of the corresponding *OUTPUT-SLOPES* entry.")
  437. (proclaim '(simple-vector *output-prev-slopes*))
  438.  
  439. (defvar *output-weights-record* (make-array 0)
  440.   "The vector of output weights is recorded here after each output-training
  441.   phase and just prior to the addition of the next unit.  This record
  442.   allows us to reconstruct the network's performance at each of these
  443.   points in time.")
  444. (proclaim '(simple-vector *output-weights-record*))
  445.  
  446.  
  447. ;;; The following vectors have one entry for each candidate unit in the
  448. ;;; pool of trainees.
  449.  
  450. (defvar *cand-scores* (make-array 0 :element-type 'short-float)
  451.   "A vector holding the correlation score for each candidate unit.")
  452. (proclaim '(type (vector short-float) *cand-scores*))
  453.  
  454. (defvar *cand-values* (make-array 0 :element-type 'short-float)
  455.   "A vector holding the most recent output value for each candidate unit.")
  456. (proclaim '(type (vector short-float) *cand-values*))
  457.  
  458. (defvar *cand-sum-values* (make-array 0 :element-type 'short-float)
  459.   "For each candidate unit, the sum of its values over an entire
  460.   training set.")
  461. (proclaim '(type (vector short-float) *cand-sum-values*))
  462.  
  463. (defvar *cand-cor* (make-array 0)
  464.   "A vector with one entry for each candidate unit.  This entry is a vector
  465.   that holds the correlation between this unit's value and the residual
  466.   error at each of the outputs, computed over a whole epoch.")
  467. (proclaim '(simple-vector *cand-cor*))
  468.  
  469. (defvar *cand-prev-cor* (make-array 0)
  470.   "Holds the *cand-cor* values computed in the previous candidate training
  471.   epoch.")
  472. (proclaim '(simple-vector *cand-cor*))
  473.  
  474. (defvar *cand-weights* (make-array 0)
  475.   "A vector with one entry for each candidate unit.  This entry is a vector
  476.   that holds the current input weights for that candidate unit.")
  477. (proclaim '(simple-vector *cand-weights*))
  478.  
  479. (defvar *cand-deltas* (make-array 0)
  480.   "A vector with one entry for each candidate unit.  This entry is a vector
  481.   that holds the input weights deltas for that candidate unit.")
  482. (proclaim '(simple-vector *cand-weights*))
  483.  
  484. (defvar *cand-slopes* (make-array 0)
  485.   "A vector with one entry for each candidate unit.  This entry is a vector
  486.   that holds the input weights slopes for that candidate unit.")
  487. (proclaim '(simple-vector *cand-slopes*))
  488.  
  489. (defvar *cand-prev-slopes* (make-array 0)
  490.   "A vector with one entry for each candidate unit.  This entry is a vector
  491.   that holds the previous values of the input weight slopes for that
  492.   candidate unit.")
  493. (proclaim '(simple-vector *cand-prev-slopes*))
  494.  
  495. (defvar *cand-derivs* (make-array 0)
  496.   "A vector of vectors, parallel in structure to the *cand-weights* vector.
  497.   For each weight wi, remember dV/dwi on the previous training case.")
  498. (proclaim '(simple-vector *cand-derivs*))
  499.  
  500.  
  501. ;;;; Network-building utilities.
  502.  
  503. (defun build-net (ninputs noutputs)
  504.   "Create the network data structures, given the number of input and output
  505.   connections.  Get *MAX-UNITS* and other dimensions from variables."
  506.   (declare (fixnum ninputs noutputs))
  507.   ;; Check to make sure *MAX-UNITS* is big enough.
  508.   (unless (> *max-units* (+ ninputs 1))
  509.     (error "*MAX-UNITS* must be greater than number of inputs plus 1."))
  510.   ;; Fill in assorted variables and create top-level vectors.
  511.   (setq *ninputs* ninputs
  512.     *noutputs* noutputs
  513.     *max-cases* (length *training-inputs*)
  514.     *ncases* *max-cases*
  515.     *first-case* 0
  516.     *nunits* (+ 1 *ninputs*)
  517.     *values-cache* (make-array *max-cases* :initial-element nil)
  518.     *extra-values* (make-array *max-units*
  519.                    :element-type 'short-float
  520.                    :initial-element 0.0)
  521.     *values* *extra-values*
  522.     *weights* (make-array *max-units* :initial-element nil)
  523.     *outputs* (make-array *noutputs*
  524.                   :element-type 'short-float
  525.                   :initial-element 0.0)
  526.     *errors-cache* (make-array *max-cases* :initial-element nil)
  527.     *extra-errors*     (make-array *noutputs*
  528.                     :element-type 'short-float
  529.                     :initial-element 0.0)
  530.     *errors* *extra-errors*
  531.     *sum-errors* (make-array *noutputs*
  532.                  :element-type 'short-float
  533.                  :initial-element 0.0)
  534.     *dummy-sum-errors* (make-array *noutputs*
  535.                        :element-type 'short-float
  536.                        :initial-element 0.0)
  537.     *output-weights* (make-array *noutputs* :initial-element nil)
  538.     *output-weights-record* (make-array *max-units* :initial-element nil)
  539.     *output-deltas* (make-array *noutputs* :initial-element nil)
  540.     *output-slopes* (make-array *noutputs* :initial-element nil)
  541.     *output-prev-slopes* (make-array *noutputs* :initial-element nil)
  542.     *cand-values* (make-array *ncandidates*
  543.                   :element-type 'short-float
  544.                   :initial-element 0.0)
  545.     *cand-sum-values* (make-array *ncandidates*
  546.                       :element-type 'short-float
  547.                       :initial-element 0.0)
  548.     *cand-scores* (make-array *ncandidates*
  549.                   :element-type 'short-float
  550.                   :initial-element 0.0)
  551.     *cand-cor* (make-array *ncandidates* :initial-element nil)
  552.     *cand-prev-cor* (make-array *ncandidates* :initial-element nil)
  553.     *cand-weights* (make-array *ncandidates* :initial-element nil)
  554.     *cand-deltas* (make-array *ncandidates* :initial-element nil)
  555.     *cand-slopes* (make-array *ncandidates* :initial-element nil)
  556.     *cand-prev-slopes* (make-array *ncandidates* :initial-element nil)
  557.     *cand-derivs* (make-array *ncandidates* :initial-element nil))
  558.   ;; Only create the caches if *USE-CACHE* is on -- may not always have room.
  559.   (when *use-cache*
  560.     (dotimes1 (i *max-cases*)
  561.       (setf (svref *values-cache* i)
  562.         (make-array *max-units*
  563.             :element-type 'short-float
  564.             :initial-element 0.0))
  565.       (setf (svref *errors-cache* i)
  566.         (make-array *noutputs*
  567.             :element-type 'short-float
  568.             :initial-element 0.0))))
  569.   ;; For each output, create the vectors holding per-weight information.
  570.   (dotimes1 (i *noutputs*)
  571.     (setf (svref *output-weights* i)
  572.       (make-array *max-units*
  573.               :element-type 'short-float
  574.               :initial-element 0.0))
  575.     (setf (svref *output-deltas* i)    
  576.       (make-array *max-units*
  577.               :element-type 'short-float
  578.               :initial-element 0.0))
  579.     (setf (svref *output-slopes* i)
  580.       (make-array *max-units*
  581.               :element-type 'short-float
  582.               :initial-element 0.0))
  583.     (setf (svref *output-prev-slopes* i)
  584.       (make-array *max-units*
  585.               :element-type 'short-float
  586.               :initial-element 0.0)))
  587.   ;; For each candidate unit, create the vectors holding the correlations,
  588.   ;; incoming weights, and other stats.
  589.   (dotimes1 (i *ncandidates*)
  590.     (setf (svref *cand-cor* i)
  591.       (make-array *noutputs*
  592.               :element-type 'short-float
  593.               :initial-element 0.0))
  594.     (setf (svref *cand-prev-cor* i)
  595.       (make-array *noutputs*
  596.               :element-type 'short-float
  597.               :initial-element 0.0))
  598.     (setf (svref *cand-weights* i)
  599.       (make-array (+ *max-units* 1)
  600.               :element-type 'short-float
  601.               :initial-element 0.0))
  602.     (setf (svref *cand-deltas* i)
  603.       (make-array (+ *max-units* 1)
  604.               :element-type 'short-float
  605.               :initial-element 0.0))
  606.     (setf (svref *cand-slopes* i)
  607.       (make-array (+ *max-units* 1)
  608.               :element-type 'short-float
  609.               :initial-element 0.0))
  610.     (setf (svref *cand-prev-slopes* i)
  611.       (make-array (+ *max-units* 1)
  612.               :element-type 'short-float
  613.               :initial-element 0.0))
  614.     (setf (svref *cand-derivs* i)
  615.       (make-array (+ *max-units* 1)
  616.               :element-type 'short-float
  617.               :initial-element 0.0))))
  618.  
  619. (defun random-weight ()
  620.   "Select a random weight, uniformly distributed over the
  621.   interval from minus to plus *weight-range*."
  622.   (-sf (random (*sf 2.0 *weight-range*)) *weight-range*))
  623.  
  624. (defun init-net ()
  625.   "Set up the network for a learning problem.  Clean up all the data
  626.   structures that may have become corrupted.  Initialize the output weights
  627.   to random values controlled by *weight-range*."
  628.   ;; Initialize the active unit data structures.
  629.   (dotimes1 (i *max-units*)
  630.     (setf (fvref *extra-values* i) 0.0)
  631.     (setf (svref *weights* i) nil)
  632.     (setf (svref *output-weights-record* i) nil))
  633.   (setq *nunits* (+ 1 *ninputs*))
  634.   ;; Initialize the per-output data structures.
  635.   (dotimes1 (i *noutputs*)
  636.     (setf (fvref *outputs* i) 0.0)
  637.     (setf (fvref *extra-errors* i) 0.0)
  638.     (setf (fvref *sum-errors* i) 0.0)
  639.     (setf (fvref *dummy-sum-errors* i) 0.0)
  640.     (let ((ow (svref *output-weights* i))
  641.       (od (svref *output-deltas* i))
  642.       (os (svref *output-slopes* i))
  643.       (op (svref *output-prev-slopes* i)))
  644.       (dotimes1 (j *max-units*)
  645.     (setf (fvref ow j) 0.0)
  646.     (setf (fvref od j) 0.0)
  647.     (setf (fvref os j) 0.0)
  648.     (setf (fvref op j) 0.0))
  649.       ;; Set up initial random weights for the input-to-output connections.
  650.       (dotimes1 (j (1+ *ninputs*))
  651.     (setf (fvref ow j) (random-weight)))))
  652.   ;; Initialize the caches if they are in use.
  653.   (when *use-cache*
  654.     (dotimes1 (j *max-cases*)
  655.       (let ((v (svref *values-cache* j))
  656.         (e (svref *errors-cache* j)))
  657.     (dotimes1 (i *max-units*)
  658.       (setf (fvref v i) 0.0))
  659.     (dotimes1 (i *noutputs*)
  660.       (setf (fvref e i) 0.0)))))    
  661.   ;; Candidate units get initialized in a separate routine.
  662.   (init-candidates)
  663.   ;; Do some other assorted housekeeping.
  664.   (setf (fvref *extra-values* 0) 1.0)
  665.   (setq *epoch* 0)
  666.   (setq *nunits* (+ 1 *ninputs*))
  667.   (setq *error-bits* 0)
  668.   (setq *true-error* 0.0)
  669.   (setq *sum-sq-error* 0.0)
  670.   (setq *best-candidate-score* 0.0)
  671.   (setq *best-candidate* 0))
  672.  
  673. (defun changed-training-set ()
  674.   "Call this instead of BUILD-NET and INIT-NET if you want to leave
  675.   existing hidden units in place and start from here with new training
  676.   examples.  Assumes that the number of net inputs and outputs remains the
  677.   same, but the number of cases may have changed.  Rebuilds the caches."
  678.   (setq *max-cases* (length *training-inputs*)
  679.     *ncases* *max-cases*
  680.     *first-case* 0
  681.     *values-cache* (make-array *max-cases* :initial-element nil)
  682.     *errors-cache* (make-array *max-cases* :initial-element nil))
  683.   ;; Only create the caches if *USE-CACHE* is on -- may not always have room.
  684.   (when *use-cache*
  685.     (let ((prev-values (make-array *max-units*
  686.                    :element-type 'short-float
  687.                    :initial-element 0.0)))
  688.       (dotimes1 (i *max-cases*)
  689.     (setf (svref *errors-cache* i)
  690.           (make-array *noutputs*
  691.               :element-type 'short-float
  692.               :initial-element 0.0))
  693.     (setq *values* (make-array *max-units*
  694.                    :element-type 'short-float
  695.                    :initial-element 0.0))
  696.     (setf (svref *values-cache* i) *values*)
  697.     (set-up-inputs (svref *training-inputs* i))
  698.     (do ((j (1+ *ninputs*) (1+ j)))
  699.         ((= j *nunits*))
  700.       (declare (fixnum j))
  701.       (compute-unit-value
  702.        j
  703.        (if (and *use-training-breaks*
  704.             (svref *training-breaks* i))
  705.              0.0
  706.              (fvref prev-values j))))
  707.     (setq prev-values *values*)))))
  708.  
  709.  
  710. ;;;; Utilities for learning.
  711.  
  712. (proclaim '(inline activation activation-prime))
  713.  
  714. (defun activation (sum)
  715.   (declare (short-float sum))
  716.   "Given the sum of weighted inputs, compute the unit's activation value.
  717.   Defined unit types are :sigmoid, :asigmoid, and :gaussian."
  718.   (ecase *unit-type*
  719.     (:sigmoid
  720.      ;; Symmetric sigmoid function in range -0.5 to +0.5.
  721.      (cond ((< sum -15.0) -0.5)
  722.        ((> sum 15.0) +0.5)
  723.        (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5))))
  724.     (:asigmoid
  725.      ;; Asymmetric sigmoid in range 0.0 to 1.0.
  726.      (cond ((< sum -15.0) 0.0)
  727.        ((> sum 15.0) 1.0)
  728.        (t (/sf 1.0 (+sf 1.0 (exp (-sf sum)))))))
  729.     (:gaussian
  730.      ;; Gaussian activation function in range 0.0 to 1.0.
  731.      (let ((x (*sf -0.5 sum sum)))
  732.        (if (< x -75.0) 0.0 (exp x))))))
  733.  
  734. ;;; Note: do not use *SIGMOID-PRIME-OFFSET* here, as it confuses the
  735. ;;; correlation machinery.  But do use it in output-prime, since it does no
  736. ;;; harm there and the output units often get stuck at extreme values.
  737.  
  738. (defun activation-prime (value sum)
  739.   "Given the unit's activation value and sum of weighted inputs, compute
  740.   the derivative of the activation with respect to the sum.  Defined unit
  741.   types are :sigmoid, :asigmoid, and :gaussian."
  742.   (declare (short-float value sum))
  743.   (ecase *unit-type*
  744.     (:sigmoid
  745.      (-sf 0.25 (*sf value value)))
  746.     (:asigmoid
  747.      (*sf value (-sf 1.0 value)))
  748.     (:gaussian
  749.      (*sf (-sf value) sum))))
  750.  
  751. (proclaim '(inline output-function output-prime))
  752.  
  753. (defun output-function (sum)
  754.   "Compute the value of an output, given the weighted sum of incoming values.
  755.   Defined output types are :sigmoid and :linear."
  756.   (declare (short-float sum))
  757.   (ecase *output-type*
  758.     (:sigmoid (cond ((< sum -15.0) -0.5)
  759.             ((> sum 15.0) +0.5)
  760.             (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5))))
  761.     (:linear sum)))
  762.  
  763. (defun output-prime (output)
  764.   "Compute the derivative of an output with respect to the weighted sum of
  765.   incoming values.  Defined output types are :sigmoid and :linear."
  766.   (declare (short-float output))
  767.   (ecase *output-type*
  768.     (:sigmoid 
  769.      (+sf *sigmoid-prime-offset* (-sf 0.25 (*sf output output))))
  770.     (:linear 1.0)))
  771.  
  772.  
  773. ;;; The basic routine for doing Quickprop-style update of weights.
  774. ;;; Distilled essence of a year's work...
  775.  
  776. (proclaim '(inline quickprop-update))
  777.  
  778. (defun quickprop-update (i weights deltas slopes prevs
  779.                epsilon decay mu shrink-factor)
  780.   "Given vectors holding weights, deltas, slopes, and previous slopes,
  781.   and an index i, update weight(i) and delta(i) appropriately.  Move
  782.   slope(i) to prev(i) and zero out slope(i).  Add weight decay term to
  783.   each slope before doing the update."
  784.   (let* ((w (fvref weights i))
  785.      (d (fvref deltas i))
  786.      (s (+sf (fvref slopes i) (*sf decay w)))
  787.      (p (fvref prevs i))
  788.      (next-step 0.0))
  789.     (declare (short-float w p s d next-step)) 
  790.     ;; The step must always be downhill.
  791.     (cond
  792.      ;; If last step was negative...
  793.      ((minusp d)
  794.       ;; First, add in linear term if current slope is still positive.
  795.       (when (plusp s)
  796.     (decf-sf next-step (*sf epsilon s)))
  797.       (cond
  798.        ;; If current slope is close to or larger than prev slope...
  799.        ((>= s (*sf shrink-factor p))
  800.     ;; Take maximum size negative step.
  801.     (incf-sf next-step (*sf mu d)))
  802.        ;; Else, use quadratic estimate.
  803.        (t (incf-sf next-step (*sf d (/sf s (-sf p s)))))))
  804.      ;; If last step was positive...
  805.      ((plusp d)
  806.       ;; First, add in linear term if current slope is still negative.
  807.       (when (minusp s)
  808.     (decf-sf next-step (*sf epsilon s)))
  809.       (cond
  810.        ;; If current slope is close to or more neg than prev slope...
  811.        ((<= s (*sf shrink-factor p))
  812.     ;; Take maximum size positive step.
  813.     (incf-sf next-step (*sf mu d)))
  814.        ;; Else, use quadratic estimate.
  815.        (t (incf-sf next-step (*sf d (/sf s (-sf p s)))))))
  816.      ;; Last step was zero, so use only linear term.
  817.      (t (decf-sf next-step (*sf epsilon s))))
  818.     ;; Having computed the next step, update the data vectors.
  819.     (setf (fvref deltas i) next-step)
  820.     (setf (fvref weights i) (+sf w next-step))
  821.     (setf (fvref prevs i) s)
  822.     (setf (fvref slopes i) 0.0)
  823.     nil))
  824.  
  825.  
  826. ;;;; Machinery for training output weights.
  827.  
  828. (defun set-up-inputs (input)
  829.   "Set up all the inputs from the INPUT vector as the first few entries in
  830.   in the values vector."
  831.   (setf (fvref *values* 0) 1.0)
  832.   (dotimes1 (i *ninputs*)
  833.     (setf (fvref *values* (1+ i))
  834.       (the short-float (svref input i)))))
  835.  
  836. (defun output-forward-pass ()
  837.   "Assume the *VALUES* vector has been set up.  Just compute the network's
  838.   outputs."
  839.   (dotimes1 (j *noutputs*)
  840.     (let ((ow (svref *output-weights* j))
  841.       (sum 0.0))
  842.       (declare (short-float sum))
  843.       (dotimes1 (i *nunits*)
  844.     (incf-sf sum (*sf (fvref *values* i) (fvref ow i))))
  845.       (setf (fvref *outputs* j)
  846.         (output-function sum)))))
  847.  
  848. (proclaim '(inline compute-unit-value))
  849.  
  850. (defun compute-unit-value (j prev-value)
  851.   "Assume that *VALUES* vector has correct current values for all units
  852.   with index less than J.  Compute, record, and return the value for unit
  853.   J.  PREV-VALUE is is the previous value of unit J."
  854.   (declare (fixnum j) (short-float prev-value))
  855.   (let* ((w (svref *weights* j))
  856.      (sum 0.0))
  857.     (declare (short-float sum))
  858.     (dotimes1 (i j)
  859.       (incf-sf sum (*sf (fvref *values* i)
  860.             (fvref w i))))
  861.     (incf-sf sum (*sf prev-value (fvref w j)))
  862.     (setf (fvref *values* j) (activation sum))))
  863.  
  864. (defun full-forward-pass (input no-memory)
  865.   "This is called only when not using the cache.  Set up the inputs from
  866.   the INPUT vector, then propagate activation values forward through all
  867.   hidden units and output units.  If no-memory is T, assume the previous
  868.   unit values are all zero."
  869.   (set-up-inputs input)
  870.   ;; For each hidden unit J, compute the activation value.  Assume that the
  871.   ;; *values* vector is full of values from the previous training pattern.
  872.   (do ((j (1+ *ninputs*) (1+ j)))
  873.       ((= j *nunits*))
  874.     (declare (fixnum j))
  875.     (compute-unit-value j (if no-memory 0.0 (fvref *values* j))))
  876.   ;; Now compute outputs.
  877.   (output-forward-pass))
  878.  
  879. (defmacro compute-errors (goal err-bits true-err sum-sq-err slopes-p)
  880.   "GOAL is a vector of desired outputs.  Compute and record the error
  881.   statistics, incrementing the ERR-BITS, TRUE-ERR, and SUM-SQ-ERR variables,
  882.   and the proper entry in *SUM-ERRORS*.  If SLOPES-P is true, also compute
  883.   and record the slopes for output weights." 
  884.   `(dotimes1 (j *noutputs*)
  885.      (let* ((out (fvref *outputs* j))
  886.         (dif (-sf out (svref ,goal j)))
  887.         (err-prime (*sf dif (output-prime out)))
  888.         ,@(when slopes-p
  889.         '((os (svref *output-slopes* j)))))
  890.        (declare (short-float dif err-prime))
  891.        (unless (< (abs dif) *score-threshold*)
  892.      (incf ,err-bits))
  893.        (incf-sf ,true-err (*sf dif dif))
  894.        (setf (fvref *errors* j) err-prime)      
  895.        (incf-sf (fvref *sum-errors* j) err-prime)
  896.        (incf-sf ,sum-sq-err (*sf err-prime err-prime))
  897.        ,@(when slopes-p
  898.        '((dotimes1 (i *nunits*)
  899.            (incf-sf (fvref os i) (*sf err-prime (fvref *values* i)))))))))
  900.  
  901. (defmacro recompute-errors (goal)
  902.   "Like compute errors, but don't bother updating slopes and statistics."
  903.   `(dotimes1 (j *noutputs*)
  904.      (let* ((out (fvref *outputs* j))
  905.         (dif (-sf out (svref ,goal j)))
  906.         (err-prime (*sf dif (output-prime out))))
  907.        (declare (short-float dif err-prime))
  908.        (setf (fvref *errors* j) err-prime))))
  909.  
  910. ;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the
  911. ;;; quickprop update in a good range across many different-sized training
  912. ;;; sets, but it's something of a hack.  Choosing good epsilon values
  913. ;;; still requires some trial and error.
  914.  
  915. (defun update-output-weights ()
  916.   "Update the output weights, using the pre-computed slopes, prev-slopes,
  917.   and delta values.  Uses the quickprop update function."
  918.   (let ((eps (/ *output-epsilon* *ncases*)))
  919.     (dotimes1 (j *noutputs*)
  920.       (let ((ow (svref *output-weights* j))
  921.         (od (svref *output-deltas* j))
  922.         (os (svref *output-slopes* j))
  923.         (op (svref *output-prev-slopes* j)))
  924.     (dotimes1 (i *nunits*)
  925.       (quickprop-update i ow od os op eps *output-decay*
  926.                 *output-mu* *output-shrink-factor*))))))
  927.  
  928.  
  929. ;;;; Outer loops for training output weights.
  930.  
  931. (defun train-outputs-epoch ()
  932.   "Perform forward propagation once for each set of weights in the
  933.   training vectors, computing errors and slopes.  Then update the output
  934.   weights."
  935.   (let ((err-bits 0)
  936.     (true-err 0.0)
  937.     (sum-sq-err 0.0))
  938.     (declare (fixnum err-bits) (short-float true-err sum-sq-err))
  939.     (dotimes1 (o *noutputs*)
  940.       (setf (fvref *sum-errors* o) 0.0))
  941.     ;; User may have changed mu between epochs, so fix shrink-factor.
  942.     (setq *output-shrink-factor*
  943.       (/sf *output-mu* (+sf 1.0 *output-mu*)))
  944.     ;; Initialize values vector.
  945.     (unless *use-cache*
  946.       (setq *values* *extra-values*)
  947.       (setq *errors* *extra-errors*)
  948.       (do ((j (1+ *ninputs*) (1+ j)))
  949.       ((= j *nunits*))
  950.     (declare (fixnum j))
  951.     (setf (fvref *values* j) 0.0)))
  952.     ;; Now run through the training examples.
  953.     (do ((i *first-case* (1+ i)))
  954.     ((= i (the fixnum (+ *first-case* *ncases*))))
  955.       (declare (fixnum i))
  956.       (cond (*use-cache*
  957.          (setq *values* (svref *values-cache* i))
  958.          (setq *errors* (svref *errors-cache* i))
  959.          (output-forward-pass))
  960.         (t (full-forward-pass (svref *training-inputs* i)
  961.                   (and *use-training-breaks*
  962.                    (svref *training-breaks* i)))))
  963.       (compute-errors (svref *training-outputs* i)
  964.               err-bits true-err sum-sq-err t))
  965.     (setq *error-bits* err-bits)
  966.     (setq *true-error* (+sf 0.0 true-err))
  967.     (setq *sum-sq-error* (+sf 0.0 sum-sq-err))
  968.     ;; Do not change weights or count epoch if this run was perfect.
  969.     (unless (= 0 *error-bits*)
  970.       (update-output-weights)
  971.       (incf *epoch*))))
  972.  
  973. (defun record-output-weights ()
  974.   "Store the output weights developed after each output-training phase
  975.   in the *output-weights-record* vector."
  976.   (let ((record (make-array *noutputs* :initial-element nil)))
  977.     (dotimes1 (o *noutputs*)
  978.       (let ((original (svref *output-weights* o))
  979.         (copy (make-array *nunits* :element-type 'short-float
  980.                   :initial-element 0.0)))
  981.     (dotimes1 (u *nunits*)
  982.       (setf (fvref copy u) (fvref original u)))
  983.     (setf (svref record o) copy)))
  984.     (setf (svref *output-weights-record* (1- *nunits*)) record)))
  985.  
  986. (defun train-outputs (max-epochs)
  987.   "Train the output weights.  If we exhaust MAX-EPOCHS, stop with value
  988.   :TIMEOUT.  If there are zero error bits, stop with value :WIN.  Else,
  989.   keep going until the true error has not changed by a significant amount
  990.   for *OUTPUT-PATIENCE* epochs.  Then return :STAGNANT.  If
  991.   *OUTPUT-PATIENCE* is zero, we do not stop until victory or until
  992.   MAX-EPOCHS is used up."
  993.   (declare (fixnum max-epochs))
  994.   (let ((last-error 0.0)
  995.     (quit-epoch (+ *epoch* *output-patience*))
  996.     (first-time t))
  997.     (declare (fixnum quit-epoch)
  998.          (short-float last-error))
  999.     (dotimes1 (i max-epochs (progn
  1000.                  (record-output-weights)
  1001.                  :timeout))
  1002.       ;; Maybe run a test epoch to see how we're doing.
  1003.       (when (and *test*
  1004.          (not (= 0 *test-interval*))
  1005.          (= 0 (mod i *test-interval*)))
  1006.        (test-epoch))
  1007.       (train-outputs-epoch)
  1008.       (cond ((zerop *error-bits*)
  1009.          (record-output-weights)
  1010.          (return :win))
  1011.         ((zerop *output-patience*))
  1012.         (first-time
  1013.          (setq first-time nil)
  1014.          (setq last-error *true-error*))
  1015.         ((> (abs (- *true-error* last-error))
  1016.         (* last-error *output-change-threshold*))
  1017.          (setq last-error *true-error*)
  1018.          (setq quit-epoch (+ *epoch* *output-patience*)))
  1019.         ((>= *epoch* quit-epoch)
  1020.          (record-output-weights)
  1021.          (return :stagnant))))))
  1022.  
  1023.  
  1024. ;;;; Machinery for Training, Selecting, and Installing Candidate Units.
  1025.  
  1026. (defun init-candidates ()
  1027.   "Give new random weights to all of the candidate units.  Zero the other
  1028.   candidate-unit statistics."
  1029.   (dotimes1 (i *ncandidates*)
  1030.     (setf (fvref *cand-values* i) 0.0)
  1031.     (setf (fvref *cand-sum-values* i) 0.0)
  1032.     (setf (fvref *cand-scores* i) 0.0)
  1033.     (let ((cw (svref *cand-weights* i))
  1034.       (cd (svref *cand-deltas* i))
  1035.       (cs (svref *cand-slopes* i))
  1036.       (cp (svref *cand-prev-slopes* i))
  1037.       (cc (svref *cand-cor* i))
  1038.       (cpc (svref *cand-prev-cor* i))
  1039.       (cdv (svref *cand-derivs* i)))
  1040.       (dotimes1 (j (+ *nunits* 1))
  1041.     (setf (fvref cw j) (random-weight))
  1042.     (setf (fvref cd j) 0.0)
  1043.     (setf (fvref cs j) 0.0)
  1044.     (setf (fvref cp j) 0.0)
  1045.     (setf (fvref cdv j) 0.0))
  1046.       (dotimes1 (o *noutputs*)
  1047.     (setf (fvref cc o) 0.0)
  1048.     (setf (fvref cpc o) 0.0)))))
  1049.  
  1050. (defun install-new-unit ()
  1051.   "Add the candidate-unit with the best correlation score to the active
  1052.   network.  Then reinitialize the candidate pool."
  1053.   (when (>= *nunits* *max-units*)
  1054.     (error "Cannot add any more units."))
  1055.   ;; Copy the weight vector for the new unit.
  1056.   (let ((w (make-array (+ *nunits* 1) :element-type 'short-float))
  1057.     (cw (svref *cand-weights* *best-candidate*)))
  1058.     (dotimes1 (i (+ *nunits* 1))
  1059.       (setf (fvref w i) (fvref cw i)))
  1060.     (setf (svref *weights* *nunits*) w)
  1061.     ;; Tell user about the new unit.
  1062.     (format t "  Add unit ~S: ~S~%"
  1063.         (+ 1 *nunits*) w))
  1064.   ;; Fix up output weights for candidate unit.
  1065.   ;; Use minus the correlation times the *weight-multiplier* as an
  1066.   ;; initial guess.  At least the sign should be right.
  1067.   (dotimes1 (o *noutputs*)
  1068.     (setf (fvref (svref *output-weights* o) *nunits*)
  1069.       (*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o))
  1070.            *weight-multiplier*)))
  1071.   ;; If using cache, run an epoch to compute this unit's values.
  1072.   (when *use-cache*
  1073.     (let ((prev-value 0.0))
  1074.       (dotimes1 (i *max-cases*)
  1075.     (setq *values* (svref *values-cache* i))
  1076.     (setq prev-value 
  1077.           (compute-unit-value
  1078.            *nunits*
  1079.            (if (and *use-training-breaks*
  1080.             (svref *training-breaks* i))
  1081.            0.0
  1082.            prev-value))))))
  1083.   ;; Reinitialize candidate units with random weights.
  1084.   (incf *nunits*)
  1085.   (init-candidates))
  1086.  
  1087. ;;; Note: Ideally, after each adjustment of the candidate weights, we would
  1088. ;;; run two epochs.  The first would just determine the correlations
  1089. ;;; between the candidate unit outputs and the residual error.  Then, in a
  1090. ;;; second pass, we would adjust each candidate's input weights so as to
  1091. ;;; maximize the absolute value of the correlation.  We need to know the
  1092. ;;; sign of the correlation for each candidate-output pair so that we know
  1093. ;;; which direction to tune the input weights.
  1094.  
  1095. ;;; Since this ideal method doubles the number of epochs required for
  1096. ;;; training candidates, we cheat slightly and use the correlation values
  1097. ;;; computed BEFORE the most recent weight update.  This combines the two
  1098. ;;; epochs, saving us almost a factor of two.  To bootstrap the process, we
  1099. ;;; begin with a single epoch that computes only the correlation.
  1100.  
  1101. ;;; Since we look only at the sign of the correlation and since that sign
  1102. ;;; should change very infrequently, this probably is OK.  But keep a
  1103. ;;; lookout for pathological situations in which this might cause
  1104. ;;; oscillation.
  1105.  
  1106.  
  1107. ;;; This function is used only once at the start of each output-training
  1108. ;;; phase to prime the pump.  After that, each call to compute-slopes also
  1109. ;;; computes the error-value products for the next epoch.
  1110.  
  1111. (defun compute-correlations (no-memory)
  1112.   "For the current training pattern, compute the value of each candidate
  1113.   unit and begin to compute the correlation between that unit's value and
  1114.   the error at each output.  We have already done a forward-prop and
  1115.   computed the error values for active units."
  1116.   (dotimes1 (u *ncandidates*)
  1117.     (let ((sum 0.0)
  1118.       (v 0.0)
  1119.       (cw (svref *cand-weights* u))
  1120.       (cc (svref *cand-cor* u)))
  1121.       (declare (short-float sum v))
  1122.       ;; Determine activation value of each candidate unit.
  1123.       (dotimes1 (i *nunits*)
  1124.     (incf-sf sum (*sf (fvref cw i)
  1125.               (fvref *values* i))))
  1126.       ;; Maybe add in the activation from the auto-recursive weight.
  1127.       (unless no-memory
  1128.     (incf-sf sum (*sf (fvref cw *nunits*)
  1129.               (fvref *cand-values* u))))
  1130.       (setq v (activation sum))
  1131.       (setf (fvref *cand-values* u) v)
  1132.       (incf-sf (fvref *cand-sum-values* u) v)
  1133.       ;; Accumulate value of each unit times error at each output.
  1134.       (dotimes1 (o *noutputs*)
  1135.     (incf-sf (fvref cc o) (*sf v (fvref *errors* o)))))))
  1136.  
  1137. ;;; Note: When we were computing true correlations between candidates and
  1138. ;;; outputs, this is where the normalization factors went in.  Currently we
  1139. ;;; are just using covariances, as explained in the tech report.  So we
  1140. ;;; make only two adjustments here.  First, we subtract out the product of
  1141. ;;; the mean error and the mean candidate value to keep things from
  1142. ;;; exploding when the error has a non-zero mean.  Second, we effectively
  1143. ;;; scale the error values by the sum-squared error over all training
  1144. ;;; cases.  This just keeps us from having to adjust *input-epsilon*
  1145. ;;; repeatedly as the error is gradually reduced to a small fraction of its
  1146. ;;; initial size.
  1147.  
  1148. (defun adjust-correlations ()
  1149.   "Normalize each accumulated correlation value, and stuff the normalized
  1150.   form into the *cand-prev-cor* data structure.  Then zero *cand-cor* to
  1151.   prepare for the next round.  Note the unit with the best total
  1152.   correlation score."
  1153.   (setq *best-candidate* 0)
  1154.   (setq *best-candidate-score* 0.0)
  1155.   (dotimes1 (u *ncandidates*)
  1156.     (let* ((cc (svref *cand-cor* u))
  1157.        (cpc (svref *cand-prev-cor* u))
  1158.        (avg-value (/ (fvref *cand-sum-values* u) *ncases*))
  1159.        (cor 0.0)
  1160.        (score 0.0))
  1161.       (declare (short-float avg-value cor score))
  1162.       (dotimes1 (o *noutputs*)
  1163.     (setq cor (/sf (-sf (fvref cc o)
  1164.                 (*sf avg-value (fvref *sum-errors* o)))
  1165.                *sum-sq-error*))
  1166.     (setf (fvref cpc o) cor)
  1167.     (setf (fvref cc o) 0.0)
  1168.     (incf-sf score (abs cor)))
  1169.       ;; Keep track of the candidate with the best overall correlation.
  1170.       (setf (fvref *cand-scores* u) score)
  1171.       (when (> score *best-candidate-score*)
  1172.     (setq *best-candidate-score* (+sf 0.0 score))
  1173.     (setq *best-candidate* u)))))
  1174.  
  1175. ;;; This is the key function in the candidate training process.
  1176.  
  1177. (defun compute-slopes (no-memory)
  1178.   "Given the correlation values for each candidate-output pair, compute
  1179.   the derivative of the candidate's score with respect to each incoming
  1180.   weight."
  1181.   (dotimes1 (u *ncandidates*)
  1182.     (let* ((sum 0.0)
  1183.        (value 0.0)
  1184.        (actprime 0.0)
  1185.        (direction 0.0)
  1186.        (dsum 0.0)
  1187.        (cw (svref *cand-weights* u))
  1188.        (cs (svref *cand-slopes* u))
  1189.        (cc (svref *cand-cor* u))
  1190.        (cpc (svref *cand-prev-cor* u))
  1191.        (cdv (svref *cand-derivs* u))
  1192.        (ws (fvref cw *nunits*)))
  1193.       (declare (short-float sum value actprime direction dsum ws))
  1194.       ;; Forward pass through each candidate unit to compute activation-prime.
  1195.       (dotimes1 (i *nunits*)
  1196.     (incf-sf sum (*sf (fvref cw i)
  1197.               (fvref *values* i))))
  1198.       ;; Maybe add in the activation from the auto-recursive weight.
  1199.       (unless no-memory
  1200.     (incf-sf sum (*sf ws (fvref *cand-values* u))))
  1201.       (setq value (activation sum))
  1202.       (setq actprime (activation-prime value sum))
  1203.       ;; Now compute which way we want to adjust each unit's incoming
  1204.       ;; activation sum, and how much.
  1205.       (dotimes1 (o *noutputs*)
  1206.     (let ((error (fvref *errors* o)))
  1207.       (decf-sf direction
  1208.            (*sf (if (minusp (fvref cpc o)) -1.0 1.0)
  1209.             (/sf (-sf error (fvref *sum-errors* o))
  1210.                  *sum-sq-error*)))
  1211.       ;; Also accumulate the error-value products for use next epoch.
  1212.       (incf-sf (fvref cc o) (*sf error value))))
  1213.       ;; Given the direction we want to push the unit's sum, compute
  1214.       ;; which way we want to tweak each incoming weight.
  1215.       (dotimes1 (i *nunits*)
  1216.     (setq dsum (*sf actprime 
  1217.             (+sf (fvref *values* i)
  1218.                  (if no-memory 0.0
  1219.                  (*sf ws (fvref cdv i))))))                 
  1220.     (incf-sf (fvref cs i)
  1221.          (*sf direction dsum))
  1222.     (setf (fvref cdv i) dsum))
  1223.       (unless no-memory
  1224.     ;; Compute derivative of activation sum with respect to the unit's
  1225.     ;; auto-recurrent weight.
  1226.     (setq dsum (*sf actprime
  1227.             (+sf (fvref *cand-values* u)
  1228.                  (*sf ws (fvref cdv *nunits*)))))
  1229.     (incf-sf (fvref cs *nunits*)
  1230.          (*sf direction dsum))
  1231.     (setf (fvref cdv *nunits*) dsum))
  1232.       ;; Save unit value for use in next training case.
  1233.       (setf (fvref *cand-values* u) value)
  1234.       (incf-sf (fvref *cand-sum-values* u) value))))
  1235.  
  1236. ;;; Note: Scaling *INPUT-EPSILON* by the number of cases and number of
  1237. ;;; inputs to each unit seems to keep the quickprop update in a good range,
  1238. ;;; as the network goes from small to large, and across many
  1239. ;;; different-sized training sets.  Still, choosing a good epsilon value
  1240. ;;; requires some trial and error.
  1241.  
  1242. (defun update-input-weights ()
  1243.   "Update the input weights, using the pre-computed slopes, prev-slopes,
  1244.   and delta values.  Uses the quickprop update function."
  1245.   (let ((eps (/ *input-epsilon* (* *ncases* *nunits*))))
  1246.     (dotimes1 (u *ncandidates*)
  1247.       (let ((cw (svref *cand-weights* u))
  1248.         (cd (svref *cand-deltas* u))
  1249.         (cs (svref *cand-slopes* u))
  1250.         (cp (svref *cand-prev-slopes* u)))
  1251.     (dotimes1 (i (+ *nunits* 1))
  1252.       (quickprop-update i cw cd cs cp eps *input-decay*
  1253.                 *input-mu* *input-shrink-factor*))))))
  1254.  
  1255. ;;; Outer loop for training the candidate unit(s).
  1256.  
  1257. (defun train-inputs-epoch ()
  1258.   "For each training pattern, perform a forward pass.  Tune the candidate units'
  1259.   weights to maximize the correlation score of each."
  1260.   ;; Initialize some things.
  1261.   (dotimes1 (u *ncandidates*)
  1262.     (setf (fvref *cand-values* u) 0.0)
  1263.     (setf (fvref *cand-sum-values* u) 0.0))
  1264.   (unless *use-cache*
  1265.     (setq *values* *extra-values*)
  1266.     (setq *errors* *extra-errors*)
  1267.     (do ((j (1+ *ninputs*) (1+ j)))
  1268.     ((= j *nunits*))
  1269.       (declare (fixnum j))
  1270.       (setf (fvref *values* j) 0.0)))
  1271.   ;; Now run through all the training examples.
  1272.   (do ((i *first-case* (1+ i)))
  1273.       ((= i (+ *first-case* *ncases*)))
  1274.     (declare (fixnum i))
  1275.     (let ((no-memory (and *use-training-breaks*
  1276.               (svref *training-breaks* i))))
  1277.       ;; Compute values and errors, or recall cached values.
  1278.       (cond (*use-cache*
  1279.          (setq *values* (svref *values-cache* i))
  1280.          (setq *errors* (svref *errors-cache* i)))
  1281.         (t (full-forward-pass (svref *training-inputs* i)
  1282.                   no-memory)
  1283.            (recompute-errors (svref *training-outputs* i))))
  1284.       ;; Compute the slopes we will use to adjust candidate weights.
  1285.       (compute-slopes no-memory)))
  1286.   ;; User may have changed mu between epochs, so fix shrink-factor.
  1287.   (setq *input-shrink-factor* (/sf *input-mu*
  1288.                    (+sf 1.0 *input-mu*)))
  1289.   ;; Now adjust the candidate unit input weights using quickprop.
  1290.   (update-input-weights)
  1291.   ;; Fix up the correlation values for the next epoch.
  1292.   (adjust-correlations)
  1293.   (incf *epoch*))
  1294.  
  1295. (defun correlations-epoch ()
  1296.   "Do an epoch through all active training patterns just to compute the
  1297.   initial correlations.  After this one pass, we will update the
  1298.   correlations as we train."
  1299.   ;; Initialize some things.
  1300.   (dotimes1 (u *ncandidates*)
  1301.     (setf (fvref *cand-values* u) 0.0)
  1302.     (setf (fvref *cand-sum-values* u) 0.0))
  1303.   (unless *use-cache*
  1304.     (setq *values* *extra-values*)
  1305.     (setq *errors* *extra-errors*)
  1306.     (do ((j (1+ *ninputs*) (1+ j)))
  1307.     ((= j *nunits*))
  1308.       (declare (fixnum j))
  1309.       (setf (fvref *values* j) 0.0)))
  1310.   ;; Now run through all the training examples.
  1311.   (do ((i *first-case* (1+ i)))
  1312.       ((= i (+ *first-case* *ncases*)))
  1313.     (declare (fixnum i))
  1314.     (let ((no-memory (and *use-training-breaks*
  1315.               (svref *training-breaks* i))))
  1316.       (cond (*use-cache*
  1317.          (setq *values* (svref *values-cache* i))
  1318.          (setq *errors* (svref *errors-cache* i)))
  1319.         (t 
  1320.          (full-forward-pass (svref *training-inputs* i)
  1321.                 no-memory)
  1322.          (recompute-errors (svref *training-outputs* i))))
  1323.       (compute-correlations no-memory)))
  1324.   (adjust-correlations)
  1325.   (incf *epoch*))
  1326.  
  1327. (defun train-inputs (max-epochs)
  1328.   "Train the input weights of all candidates.  If we exhaust MAX-EPOCHS,
  1329.   stop with value :TIMEOUT.  Else, keep going until the best candidate
  1330.   unit's score has changed by a significant amount, and then until it does
  1331.   not change significantly for PATIENCE epochs.  Then return :STAGNANT.  If
  1332.   PATIENCE is zero, we do not stop until victory or until MAX-EPOCHS is
  1333.   used up."
  1334.   (declare (fixnum max-epochs))
  1335.   ;; Turn sum-errors into average errors.
  1336.   (dotimes1 (o *noutputs*)
  1337.     (setf (fvref *sum-errors* o)
  1338.       (/ (fvref *sum-errors* o) *ncases*)))
  1339.   (correlations-epoch)
  1340.   (let ((last-score 0.0)
  1341.     (quit max-epochs)
  1342.     (first-time t))
  1343.     (declare (fixnum quit)
  1344.          (short-float last-score))
  1345.     (dotimes1 (i max-epochs :timeout)
  1346.       (train-inputs-epoch)
  1347.       (cond ((zerop *input-patience*))
  1348.         (first-time
  1349.          (setq first-time nil)
  1350.          (setq last-score *best-candidate-score*))
  1351.         ((> (abs (-sf *best-candidate-score* last-score))
  1352.         (* last-score *input-change-threshold*))
  1353.          (setq last-score *best-candidate-score*)
  1354.          (setq quit (+ i *input-patience*)))
  1355.         ((>= i quit)
  1356.          (return :stagnant))))))
  1357.  
  1358. ;;;; Outer Loop.
  1359.  
  1360. (defun list-parameters ()
  1361.   "Print out the current training parameters in abbreviated form."
  1362.   (format t "SigOff ~,2F, WtRng ~,2F, WtMul ~,2F~%"
  1363.       *sigmoid-prime-offset* *weight-range* *weight-multiplier*)
  1364.   (format t "OMu ~,2F, OEps ~,2F, ODcy ~,4F, OPat ~D, OChange ~,3F~%"
  1365.       *output-mu* *output-epsilon* *output-decay* *output-patience*
  1366.       *output-change-threshold*)
  1367.   (format t "IMu ~,2F, IEps ~,2F, IDcy ~,4F, IPat ~D, IChange ~,3F~%"
  1368.       *input-mu* *input-epsilon* *input-decay* *input-patience*
  1369.       *input-change-threshold*)
  1370.   (format t "Utype ~S, Otype ~S, Pool ~D~%"
  1371.       *unit-type* *output-type* *ncandidates*))
  1372.  
  1373. (defun train (outlimit inlimit rounds &optional (restart nil))
  1374.   "Train the output weights until stagnation or victory is reached.  Then
  1375.   train the input weights to stagnation or victory.  Then install the best
  1376.   candidate unit and repeat.  OUTLIMIT and INLIMIT are upper limits on the number
  1377.   of cycles in each output and input phase.  ROUNDS is an upper limit on
  1378.   the number of unit-installation cycles.  If RESTART is non-nil, we are
  1379.   restarting training from the current point -- do not reinitialize the net."
  1380.   (declare (fixnum outlimit inlimit rounds))
  1381.   (unless restart (init-net))
  1382.   (list-parameters)
  1383.   (when *use-cache*
  1384.     (dotimes1 (i *max-cases*)
  1385.       (setq *values* (svref *values-cache* i))
  1386.       (set-up-inputs (svref *training-inputs* i))))
  1387.   (setq *done* nil)
  1388.   (dotimes1 (r rounds  :lose)
  1389.     (case (train-outputs outlimit)
  1390.       (:win
  1391.        (list-parameters)
  1392.        (format t "Victory at ~S epochs, ~S units, ~S hidden, Error ~S.~%"
  1393.            *epoch* *nunits* (- *nunits* *ninputs* 1) *true-error*)
  1394.        (return nil))
  1395.       (:timeout
  1396.        (format t "Epoch ~D: Out Timeout  ~D bits wrong, error ~S.~2%"
  1397.            *epoch* *error-bits* *true-error*))
  1398.       (:stagnant
  1399.        (format t "Epoch ~D: Out Stagnant ~D bits wrong, error ~S.~2%"
  1400.            *epoch* *error-bits* *true-error*)))
  1401.     (when *test* (test-epoch))
  1402.     (when *done* (return nil))
  1403.     (case (train-inputs inlimit)
  1404.       (:timeout
  1405.        (format t "Epoch ~D: In Timeout.  Cor: ~D~%"
  1406.            *epoch* *best-candidate-score*))
  1407.       (:stagnant
  1408.        (format t "Epoch ~D: In Stagnant.  Cor: ~D~%"
  1409.            *epoch* *best-candidate-score*)))
  1410.     (install-new-unit)))
  1411.  
  1412. (defun test-epoch (&optional (*score-threshold* 0.49999))
  1413.   "Perform forward propagation once for each set of weights in the training
  1414.   and testing vectors.  Reporting the performance.  Do not change any
  1415.   weights.  Do not use the caches."
  1416.   (let ((*use-cache* nil)
  1417.     (*values* *extra-values*)
  1418.     (*errors* *extra-errors*)
  1419.     (*sum-errors* *dummy-sum-errors*)
  1420.     (train-err-bits 0)
  1421.     (test-err-bits 0)
  1422.     (train-true-err 0.0)
  1423.     (test-true-err 0.0)
  1424.     (sum-sq-err 0.0))
  1425.     (declare (fixnum train-err-bits test-err-bits)
  1426.          (short-float train-true-err test-true-err sum-sq-err))
  1427.     ;; Zero context at the start of the training set.
  1428.     (do ((j (1+ *ninputs*) (1+ j)))
  1429.     ((= j *nunits*))
  1430.       (declare (fixnum j))
  1431.       (setf (fvref *values* j) 0.0))
  1432.     ;; Run all training patterns and count errors.
  1433.     (dotimes1 (i (length *training-inputs*))
  1434.       (full-forward-pass (svref *training-inputs* i)
  1435.              (and *use-training-breaks*
  1436.                   (svref *training-breaks* i)))
  1437.       (compute-errors (svref *training-outputs* i)
  1438.               train-err-bits train-true-err sum-sq-err nil))
  1439.     (format t "Training: ~D of ~D wrong, error ~S."
  1440.         train-err-bits (length *training-inputs*) train-true-err)
  1441.     ;; Zero context at the start of the test set.
  1442.     (do ((j (1+ *ninputs*) (1+ j)))
  1443.     ((= j *nunits*))
  1444.       (declare (fixnum j))
  1445.       (setf (fvref *values* j) 0.0))
  1446.     ;; Now run all test patterns and report the results.
  1447.     (when *test-inputs*
  1448.       (dotimes1 (i (length *test-inputs*))
  1449.     (full-forward-pass (svref *test-inputs* i)
  1450.                (and *use-test-breaks*
  1451.                 (svref *test-breaks* i)))
  1452.     (compute-errors (svref *test-outputs* i)
  1453.             test-err-bits test-true-err sum-sq-err nil)))
  1454.     (format t "  Test: ~D of ~D wrong, error ~S.~%"
  1455.         test-err-bits (length *test-inputs*) test-true-err)))
  1456.  
  1457.  
  1458. ;;; ***************************************************************************
  1459. ;;; Example of  usage: code to create morse code test described in the paper.
  1460. ;;; ***************************************************************************
  1461.  
  1462. (proclaim '(optimize (speed 1) (safety 3)))
  1463.  
  1464. (defvar *nletters* 26
  1465.   "Number of letters we will ultimately train the current network on.
  1466.   This controls number of outputs, etc.")
  1467. (proclaim '(fixnum *nletters*))
  1468.  
  1469. (defvar *code-conversions* (make-array 27)
  1470.   "Given index of the desired letter (A is 1, etc.), get the code string
  1471.   in dots and dashes.  Reserve ouptput zero for the strobe.")
  1472. (proclaim '(simple-vector *code-conversions*))
  1473.  
  1474. ;;; Set up the codes.                      Letter
  1475.  
  1476. (setf (aref *code-conversions* 1)  ".-"  )   ; A
  1477. (setf (aref *code-conversions* 2)  "-...")   ; B
  1478. (setf (aref *code-conversions* 3)  "-.-.")   ; C
  1479. (setf (aref *code-conversions* 4)  "-.." )   ; D
  1480. (setf (aref *code-conversions* 5)  "."   )   ; E
  1481. (setf (aref *code-conversions* 6)  "..-.")   ; F
  1482. (setf (aref *code-conversions* 7)  "--." )   ; G
  1483. (setf (aref *code-conversions* 8)  "....")   ; H
  1484. (setf (aref *code-conversions* 9)  ".."  )   ; I
  1485. (setf (aref *code-conversions* 10) ".---")   ; J
  1486. (setf (aref *code-conversions* 11) "-.-" )   ; K
  1487. (setf (aref *code-conversions* 12) ".-..")   ; L
  1488. (setf (aref *code-conversions* 13) "--"  )   ; M
  1489. (setf (aref *code-conversions* 14) "-."  )   ; N
  1490. (setf (aref *code-conversions* 15) "---" )   ; O
  1491. (setf (aref *code-conversions* 16) ".--.")   ; P
  1492. (setf (aref *code-conversions* 17) "--.-")   ; Q
  1493. (setf (aref *code-conversions* 18) ".-." )   ; R
  1494. (setf (aref *code-conversions* 19) "..." )   ; S
  1495. (setf (aref *code-conversions* 20) "-"   )   ; T
  1496. (setf (aref *code-conversions* 21) "..-" )   ; U
  1497. (setf (aref *code-conversions* 22) "...-")   ; V
  1498. (setf (aref *code-conversions* 23) ".--" )   ; W
  1499. (setf (aref *code-conversions* 24) "-..-")   ; X
  1500. (setf (aref *code-conversions* 25) "-.--")   ; Y
  1501. (setf (aref *code-conversions* 26) "--..")   ; Z
  1502.  
  1503. (defun string-to-code (string)
  1504.   "Given a string of characters, returns three values: a vector of input
  1505.   patterns in the proper morse-code representation, a corresponding vector
  1506.   of output patterns, and a vector of break values with a T at the start of
  1507.   each new character."
  1508.   (setq string (string-upcase string))
  1509.   (let* ((inlist nil)
  1510.      (outlist nil)
  1511.      (breaklist nil))
  1512.     (dotimes (i (length string))
  1513.       (let* ((char (- (char-code (char string i)) 64))
  1514.          (morse (aref *code-conversions* char))
  1515.          (outpat (make-array (+ *nletters* 1)
  1516.                  :initial-element -0.5))
  1517.          (strobepat (make-array (+ *nletters* 1)
  1518.                     :initial-element -0.5)))
  1519.     (setf (aref strobepat 0) +0.5)
  1520.     (setf (aref strobepat char) +0.5)
  1521.     (dotimes (j (length morse))
  1522.       ;; Push out the dot-dash patterns.
  1523.       (if (eql (aref morse j) #\.)
  1524.         (progn
  1525.           (push '#(+0.5) inlist)
  1526.           (push '#(-0.5) inlist)
  1527.           (push outpat outlist)
  1528.           (push outpat outlist)
  1529.           (push (= j 0) breaklist)
  1530.           (push nil breaklist))
  1531.         (progn
  1532.           (push '#(+0.5) inlist)
  1533.           (push '#(+0.5) inlist)
  1534.           (push '#(-0.5) inlist)
  1535.           (push outpat outlist)
  1536.           (push outpat outlist)
  1537.           (push outpat outlist)
  1538.           (push (= j 0) breaklist)
  1539.           (push nil breaklist)
  1540.           (push nil breaklist))))
  1541.     ;; Push the separating space and the strobe output.
  1542.     (push strobepat outlist)
  1543.     (push '#(-0.5) inlist)
  1544.     (push nil breaklist)))
  1545.     ;; Return the three values.
  1546.     (values (coerce (nreverse inlist) 'simple-vector)
  1547.         (coerce (nreverse outlist) 'simple-vector)
  1548.         (coerce (nreverse breaklist) 'simple-vector))))
  1549.  
  1550. (defvar *training-string* nil
  1551.   "Save the string used for training cases here.")
  1552.  
  1553. (defvar *test-string* nil
  1554.   "Save the string used for testing cases here.")
  1555.  
  1556. (defun build-morse (string &optional (continue nil))
  1557.   "Given a string of characters, create a training set for the morse code
  1558.   representation of the string.  There is no test set.  If CONTINUE is on,
  1559.   make use of pre-existing hidden units."
  1560.   (setq *training-string* string)
  1561.   (multiple-value-bind (in out breaks)
  1562.                (string-to-code string)
  1563.     (setq *training-inputs* in)
  1564.     (setq *training-outputs* out)
  1565.     (setq *training-breaks* breaks)
  1566.     (setq *use-training-breaks* t))
  1567.   (setq *test-inputs* *training-inputs*)
  1568.   (setq *test-outputs* *training-outputs*)
  1569.   (setq *test-breaks* *training-breaks*)
  1570.   (setq *test-string* nil)
  1571.   (setq *use-test-breaks* t)
  1572.   (setq *ninputs* 1)
  1573.   (setq *noutputs* (+ *nletters* 1))
  1574.   (if continue
  1575.       (changed-training-set)
  1576.       (progn 
  1577.     (build-net *ninputs* *noutputs*)
  1578.     (init-net)))
  1579.   (format t "~%Training on ~S:~%" string))
  1580.  
  1581. ;;; To run this, do something like the following:
  1582. ;;;    (build-morse "abcdefghijklmnopqrstuvwxyz")
  1583. ;;;    (train 150 150  25)
  1584. ;;;
  1585. ;;; Suggested parameters:
  1586. ;;; SigOff 0.10, WtRng 1.00, WtMul 1.00
  1587. ;;; OMu 2.00, OEps 0.01, ODcy 0.0001, OPat 15, OChange 0.010
  1588. ;;; IMu 2.00, IEps 0.10, IDcy 0.0001, IPat 15, IChange 0.030
  1589. ;;; Utype :SIGMOID, Otype :SIGMOID, Pool 32
  1590. ;;;
  1591. ;;; To train incrementally, do something like this:
  1592. ;;;    (build-morse "abcde")
  1593. ;;;    (train 150 150 25)
  1594. ;;;    (build-morse "fghij" t)    ; The T here prevents re-initialization.
  1595. ;;;    (train 150 150 25 t)       ; Ditto.
  1596. ;;;
  1597. ;;; THE END
  1598.