;;;FILE: hopfield.ss
;;;
;;; kyle wagner
;;; q351
;;; 3-4-1997
;;;
;;; Implementation of a hopfield net.  Used for a visual autoassociation task.
;;;
;;; This net consists of a bunch of McCulloch-Pitts neurons (linear threshold) 
;;;   which are fully recurrent (except they are not connected to themselves).
;;;   "Training" is done by using the outer product rule.
;;;   RUnning the net consists of presenting a pattern to the net (turning all
;;;   units either on or off: +1 or -1).  The net is then allowed to settle.
;;;   When units cease to cause each other to change, the net has "settled".
;;;   Hopefully, this net can autoassociate even noisy inputs.
;;;
;;;
;;; Patterns are simply vectors.  (init wd ht) sets up the activation vector
;;;   and the weight matrix for use on "2d" patterns (such as images) of 
;;;   dimensions wd X ht
;;;   
;;; Activations of units
;;;   vector
;;;   activs are +1 or -1
;;; Weights of net
;;;   reciprocal conn's, so symmetric matrix
;;;   diagonal is all 0s (no unit conn's to itself)
;;;   row# is sender, col# is receiver (although for symm. wts, doesn't matter)
;;;
;;;
;;; To initialize things:
;;;   (init 7 7)
;;;
;;;   this gives a 7x7 "image" input (49 nodes).  The net thus has 49 nodes.
;;;   The net doesn't know they're 2D (7x7), but routines exist to view the
;;;   net in this way.
;;;
;;; To "train" the net on a pattern:
;;;
;;;   (learn-pattern ptrn)
;;;
;;;   for a list of patterns:
;;;
;;;   (learn ptrns)
;;;
;;; To run the net on a pattern and see if it settles:
;;;
;;;   (run ptrn)
;;;


;;;
;;; GLOBAL VARS
;;;
;;; activation vector and weights matrix are global.  They are set to junk
;;; right now and will be properly initialized by init.
;;;
;;; *rows* and *cols* are maintained for printing purposes: they are
;;;   the rows and cols in an image, not in the weights matrix.
;;;
(define *activs* 'please-initialize-me)
(define *weights* 'me-too)
(define *cols* 'init-me)
(define *rows* 'init-me)



;;;
;;; get-num-units
;;;
;;; Returns # units in the net.
;;;
(define get-num-units 
  (lambda ()
    (vector-length *activs*)))




;;;
;;; init
;;;
;;; INPUT
;;;   wd, ht : the width and height of pattern "images"
;;; OUTPUT
;;;   no return value
;;; OPERATION
;;;   Sets up a hopfield net with an activation vector of length wd * ht.
;;;   Then, it sets up a weights matrix that is (wd * ht) X (wd * ht)
;;;   in dimension.
;;;
(define init
  (lambda (ht wd)
    (let ([num-units (* wd ht)])

      ;; Set cols and rows for output purposes
      (set! *cols* wd)
      (set! *rows* ht)

      ;; Make the weights matrix
      (set! *weights* (make-matrix num-units num-units 0.0))

      ;; Make the activation vector
      ;;   First make a vector with 0s and 1s of the proper length.
      ;;   Then, use vector-map to replace the 0s with -1s.
      ;;   The second arg to vector-map will be ignored
      (let* ([activs (random-vector num-units 0 1)]
	     [activs2 (vector-map (lambda (x y) (if (zero? x) -1 1))
				  activs
				  activs)])
	(set! *activs* activs2))

      (printf "Done.~%"))))




;;;
;;; get and set routines for activs and weights
;;;
;;; set-weight! has to worry about reciprocal conn's 
;;;
;;;
(define get-activ
  (lambda (unit)
    (vector-ref *activs* unit)))
(define set-activ!
  (lambda (unit new-activ)
    (vector-set! *activs* unit new-activ)))
(define get-weight
  (lambda (from-unit to-unit)
    (matrix-ref *weights* from-unit to-unit)))
(define set-weight!
  (lambda (from-unit to-unit new-wt)
    ;; Set the weights for both directions (units have symm. conn's)
    (matrix-set! *weights* to-unit from-unit new-wt)
    (matrix-set! *weights* from-unit to-unit new-wt)))




;;;
;;; output procedures
;;;

;;;
;;; print-image
;;;
;;; INPUT: image is a vector, with virtual dim's of *width* X *height*
;;;
(define print-image
  (lambda (image)
    (let row-loop ([row 0])
      (let col-loop ([col 0])
	(cond 

	 ;; Done
	 [(>= row *rows*) (newline)]

	 ;; Go to next line for outputting next row
	 [(>= col *cols*)
	  (newline)
	  (row-loop (add1 row))]

	 ;; Depending on image value, show some symbol for what's there
	 [else
	  (let* ([index (+ col (* row *cols*))]
		 [val (vector-ref image index)])
	    (cond
	     [(< val 0)	(printf ".")]
	     [(> val 0) (printf "#")]
	     [else (printf "0")])
	    (col-loop (add1 col)))])))))



;;;
;;; print-activs
;;;
(define print-activs
  (lambda ()
    (print-image *activs*)))


;;;
;;; print-pattern
;;;
(define print-pattern print-image)




;;;
;;; print-weights
;;;
(define print-weights
  (lambda ()
    (let ([max-index (get-num-units)])
      (let row-print-loop ([row 0])
	(let col-print-loop ([col 0])
	  (cond
	   [(>= row max-index) (newline)]
	   [(>= col max-index)
	    (begin
	      (newline)
	      (row-print-loop (add1 row)))]
	   [else
	    (begin
	      (printf (format "~a " (get-weight row col)))
	      (col-print-loop (add1 col)))]))))))




;;;
;;; input-to-unit
;;;
;;; INPUT
;;;   unit : an index for input
;;; OUTPUT
;;;   none
;;; OPERATION
;;;   Use inner product.  Take the activations of the units, find their weights
;;;   coming into the unit in question, and get the input sum.  This is
;;;   simply the inner product of the activations with row[unit] of the matrix.
;;;   Assumes that the weight matrix is symmetrical.
;;;
(define input-to-unit
  (lambda (unit)
    (let ([unit-weights (matrix-row-ref *weights* unit)])
      (inner-product unit-weights *activs*))))




;;;
;;; update-unit!
;;;
;;; INPUT
;;;   unit : an index for input
;;; OUTPUT
;;;   #t if activ changed, #f if didn't
;;; OPERATION
;;;   Calls input-to-unit.  If input >= 0.0, set unit's activ to +1,
;;;   else set it to -1.
;;; 
(define update-unit!
  (lambda (unit)
    (let* ([unit-activ (get-activ unit)]
	   [input (input-to-unit unit)]
	   [new-activ (if (>= input 0.0) +1 -1)])
      ;; Set the weight
      (set-activ! unit new-activ)

      ;; Did the activ change?
      (not (= unit-activ new-activ)))))



;;;
;;; update!
;;;
;;; INPUT
;;;   none
;;; OUTPUT
;;;   #t if any unit changed at all, #f otherwise
;;; OPERATION
;;;   Randomly select a unit.  Update it with update-unit!. 
;;;   Do this 2 X #units.  Keep track of changes to units with any-changed?
;;;   If any unit changes, set it to #t.
;;;
(define update!
  (lambda ()
    (let* ([num-units (get-num-units)]
	   [num-updates (* 2 num-units)])
      (let update-loop ([counter 0]
			[any-changed? #f])
	(if (>= counter num-updates)
	    
	    ;; Did any units get changed?
	    any-changed?
	    
	    ;; update a unit
	    (let* ([unit (random num-units)]
		   [change? (update-unit! unit)])
	      (update-loop (add1 counter) (or change? any-changed?))))))))



;;;
;;; input-pattern!
;;;
;;; INPUT
;;;   ptrn : a vector that is an "image" (an input to net)
;;; OUTPUT
;;;   none
;;; OPERATION
;;;   ptrn may contain +1s, -1s or 0s.  Set *activs* to the values
;;;   in ptrn unless it's a 0.  In that case, randomly set it.
;;;
(define input-pattern!
  (lambda (ptrn)
    (let ([max-index (get-num-units)]
	  [random-activ
	   (lambda ()
	     (if (zero? (random 2))
		 +1
		 -1))])

      ;; Set each unit
      (let loop ([index 0])
	(if (< index max-index)
	    (let ([new-activ (vector-ref ptrn index)])
	      ;; For 0s, choose random activation, otherwise same one.
	      (if (zero? new-activ)
		  (set-activ! index (random-activ))
		  (set-activ! index new-activ))
	      (loop (add1 index)))
	    'done)))))



;;;
;;; run
;;;
;;; INPUT
;;;   ptrn : a vector that is an "image" (input to net)
;;; OUTPUT
;;;   none
;;; OPERATION
;;;   call input-pattern! once.
;;;   Repeatedly call update until update returns #f
;;;
(define run
  (lambda (ptrn)

    ;; Setup the activations
    (input-pattern! ptrn)
    
    ;; Loop, calling update!, until it returns #f
    (let settle-loop ()

      ;; Show net outputs
      (print-activs)

      ;; Did the net settle?
      (if (update!)
	  (settle-loop)
	  (printf "The net has settled!~%")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; "Learning" routines
;;;


;;;
;;; learn-pattern
;;;
;;; INPUT 
;;;   ptrn : a pattern to be learned (a vector)
;;; OUTPUT
;;;   none
;;; OPERATION
;;;   Take ptrn, determine its outer-product with itself.  Then,
;;;   add this resulting matrix to *weights*.
;;;
(define learn-pattern
  (lambda (ptrn)
    (let ([result (outer-product ptrn ptrn)])
      (set! *weights* (matrix+ result *weights*)))))



;;;
;;; learn
;;;
;;; INPUT 
;;;   ptrns : a list of patterns to be learned by the net
;;; OUTPUT
;;;   none
;;; OPERATION
;;;   Call learn-pattern on each pattern in ptrns.
;;;   Normalize the *weights* matrix.  Zero the diagonal.
;;;
(define learn
  (lambda (ptrns)
    (let* ([num-ptrns (length ptrns)]
	   [normalizer (/ 1.0 num-ptrns)])

      ;; Call learn-pattern on each pattern in ptrns
      (for-each learn-pattern ptrns)
      
      ;; Normalize this matrix
      (set! *weights* (scalar*matrix normalizer *weights*))
      
      ;; Zero the diagonal
      (zero-weights-diag!))))



;;;
;;; zero-weights-diag!
;;;
;;; Puts all 0s on the *weights* matrix diagonal
;;;
(define zero-weights-diag!
  (lambda ()
    (let ([max-index (matrix-num-rows *weights*)])
      (let loop ([index 0])
	(if (< index max-index)
	    (begin
	      (matrix-set! *weights* index index 0.0)
	      (loop (add1 index))))))))





;;;
;;; noisify
;;;
;;; INPUT
;;;   ptrn : a pattern ( a vector)
;;;   flip-chance : chance that pattern's value will flip [0.0, 1.0]
;;; OUTPUT 
;;;   a noisy pattern
;;; OPERATION
;;;   "Flip a coin" between 0 and 1.0.  If < flip-chance, change the pattern
;;;   member, otherwise keep it the same.  Values are either +1 or -1.
;;;
(define noisify
  (lambda (ptrn flip-chance)
    (let ([noisy-ptrn (vector-copy ptrn)]
	  [max-index (vector-length ptrn)]
	  [flip (lambda (bit)
		  (if (= bit -1)
		      1
		      -1))])

      ;; For each bit in ptrn, see if it should be flipped
      (let tweak-loop ([index 0])
	(if (< index max-index)
	    (let ([bit (vector-ref ptrn index)])
	      (if (< (random 1.0) flip-chance)
		  (vector-set! noisy-ptrn index (flip bit)))
	      (tweak-loop (add1 index)))
	    noisy-ptrn)))))





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Testing patterns
;;;	    

;;;
;;; *p1* and *p2* are 2 patrns of 2x2 size that can be used to test 
;;; the hopfield net.
;;;
(define *p1*
  '#(0 0 1 1))
(define *p2*
  '#(1 1 0 0))
(define *wts* (make-matrix 2 2 0.0))


;;;;
;;;; Training on various patterns
;;;;

;; This one creates mirror images when presented with *m* and *w*
(define ptrns1 (list *a* *b* *y*))

(define ptrns2 (list *a* *e* *w* *y*))

(define ptrns3 (list *b* *e* *s* *m* *w*))

(define ptrns4 (list *a* *b* *m* *s* *y*))

;;;
;;; Noisy patterns
;;;
(define *a1* (noisify *a* 0.1))
(define *a2* (noisify *a* 0.2))

(define *b1* (noisify *b* 0.1))
(define *b2* (noisify *b* 0.2))

(define *e1* (noisify *e* 0.1))
(define *e2* (noisify *e* 0.2))

(define *m1* (noisify *m* 0.1))
(define *m2* (noisify *m* 0.2))

(define *s1* (noisify *s* 0.1))
(define *s2* (noisify *s* 0.2))

(define *w1* (noisify *w* 0.1))
(define *w2* (noisify *w* 0.2))

(define *y1* (noisify *y* 0.1))
(define *y2* (noisify *y* 0.2))

(define *trash* (noisify *w* 0.5))


;;;
;;; Preparation for learning and running 7x7 images.
;;;
(define prepare-net
  (lambda (ptrns)
    (begin
      (init 7 7)
      (learn ptrns))))