path: root/algo1.lisp

;;;; ==========================================================================
;;;; SYMBOLIC FEED-FORWARD NEURAL NETWORK (ASSOCIATIVE MEMORY)
;;;; ==========================================================================
;;;;
;;;; OVERVIEW: This module implements a neural network designed for
;;;; pattern recognition within symbolic grids. Instead of using
;;;; traditional "Dense" layers of floating-point weights, it uses
;;;; "Memory Blocks".
;;;;
;;;; HOW IT WORKS:
;;;; 1. WINDOWING: The system slides a "lens" (the memory block size) over 
;;;;    the input data (the input grid).
;;;; 
;;;; 2. CORRELATION: It performs a symbolic comparison between the memory 
;;;;    and the input. It checks for "Co-occurrence":
;;;;    - If the feature is present in BOTH, it's a positive match.
;;;;    - If the feature is absent in BOTH, it's also a positive match.
;;;;    - Mismatches generate negative signals.
;;;;
;;;; 3. NON-LINEAR ACTIVATION: The resulting sums are passed through a 
;;;;    "Rectified Polynomial." This is the "secret sauce" of Deep Learning. 
;;;;    By squaring or cubing the positive signals (the pluses), we amplify 
;;;;    strong patterns and suppress weak noise.
;;;;
;;;; 4. INFERENCE: The system aggregates the "votes" of all memories. If the 
;;;;    net signal is positive, the network confirms the presence of the 
;;;;    requested item (T); otherwise, it rejects it (NIL).
;;;;
;;;; PERSPECTIVE:
;;;; Think of this as a "Fuzzy Grep" for 2D grids. It doesn't look for 
;;;; exact matches, but rather "statistical resonance" between a known 
;;;; template and a raw input patch.
;;;; ==========================================================================



;;; --- 1. THE ACTIVATION FUNCTION ---
;;;
;;; This defines how a "neuron" scales its output. By squaring the
;;; result (degree 2), we make strong matches significantly more
;;; influential than weak ones. The DEGREE is the knob that can be
;;; cranked to 11 to control how the NN behaves.
(defun make-rectified-polynomial (degree)
  (lambda (x)
    ;; "Rectified": Only positive values pass.
    (cond ((plusp x) (expt x degree))
	  ;; Negative or zero signals are killed.
          ((not (plusp x)) '0))))    

;;; --- 2. THE MAGNITUDE CALCULATOR ---
;;;
;;; This compares a row of input to a row of memory. It's essentially
;;; calculating "Overlap" and "Divergence."
(defun sum-one-row
    (item row-in mem-in idx
     &key (predicate 'member) predicate-keys &allow-other-keys)
  (loop :for me :in mem-in	; Walk the memory column-to-column and
        :for ro :in row-in	; row-to-row, _simultaneously_!
        :for count :from 0
        ;; Transform presence of 'item' into +1 or -1
        :for m := (if (apply predicate item me predicate-keys) +1 -1)
        :for c := (if (apply predicate item ro predicate-keys) +1 -1)
        
        ;; CASE A: We are at the 'Target'
        ;; If it matches, we sum the memory signal (+m or -m) directly.
        :when (and idx (= count idx))
          :sum (* +1 m) :into pluses
        :when (and idx (= count idx))
          :sum (* -1 m) :into minuses
          
        ;; CASE B: We are at any other column (The context)
	;;
	;; Multiply the input (c) by the memory (m). If both match (+1
        ;; * +1) or both lack the item (-1 * -1), result is +1. This
        ;; is the "correlation" or "weighting" step.
        :unless (and idx (= count idx))
          :sum (* c m) :into pluses
        :unless (and idx (= count idx))
          :sum (* c m) :into minuses
        :finally
           ;; Returns the total "evidence" for and against this row.
           (return (list pluses minuses))))

(when nil
  ;; Test to understand how sum-one-row works. A plus is added when
  ;; the symbol is in the memory row, if the symbol occurs on the
  ;; index, 2 pluses are added. Eval with SLIME (C-x C-e at the
  ;; closing brace.)
  (sum-one-row 'foo
	       '((foo) () (bar))
	       '((foo) (foo) (bar))
	       1) ; (3 1) - strong sign that foo belongs there
  (sum-one-row 'foo
	       '((bar) () (bar))
	       '((bar) (bar) (foo))
	       1) ; (-1 1) - undecided?
  (sum-one-row 'foo
	       '((bar) () (bar))
	       '((bar) (bar) (bar))
	       1) ; (1 3) - allergy!
  (sum-one-row 'foo
	       '((foo) () (bar))
	       '((foo) (foo) (bar))
	       nil) ; (3 1) - strong sign that foo belongs there
  )

;;; --- 3. THE SPATIAL AGGREGATOR ---
;;;
;;; This loops through the rows of a single memory "block." Think of a
;;; memory block.
(defun sum-one-memory
    (item input memory
     &rest keys
     &key target-row target-col
       start-row start-col
       rectified-polynomial &allow-other-keys)
  (loop :for mem-row :in memory
        :for count :from 0
        ;; 'nthcdr' is used to offset into the input matrix, 
        ;; allowing the network to look at specific "patches" of data.
        :for whole-input-row :in (nthcdr start-row input)
        :for input-row := (nthcdr start-col whole-input-row)
        
        ;; If the current row matches the row we are predicting, 
        ;; pass that column index down to sum-one-row.
        :for idx := (when (= count target-row) target-col)
        
        ;; Execute the row-level comparison.
        :for (row-plus row-minus)
          := (apply 'sum-one-row item input-row mem-row idx keys)
        
        ;; Accumulate the results for the entire memory block.
        :summing row-plus :into row-pluses
        :summing row-minus :into row-minuses
        :finally
           ;; Apply the "Polynomial" to amp up strong signals, 
           ;; then subtract the 'negative evidence' from the 'positive evidence'.
           (return
             (- (funcall rectified-polynomial row-pluses)
                (funcall rectified-polynomial row-minuses)))))

(when nil
  ;;; Tests for sum-one-memory
  (sum-one-memory 'foo
		  '(((foo) (foo))
		    ((bar) (bar))) ;; Input
		  '(((foo) (foo))
		    ((bar) (bar))) ;; Memory
		  :rectified-polynomial (make-rectified-polynomial 2)
		  :target-row 0 :target-col 0
		  :start-row 0 :start-col 0)

  ;; The above is like calling (you can try!):
  ;; This outputs (2 0)
  (sum-one-row 'foo
	       '((foo) (foo))
	       '((foo) (foo))
	       0)
  ;; This outputs (2 2)
  (sum-one-row 'foo
	       '((bar) (bar))
	       '((bar) (bar))
	       nil)
  ;; final output: 12
  (- (funcall (make-rectified-polynomial 2) 4)
     (funcall (make-rectified-polynomial 2) 2))
  

  (sum-one-memory 'foo
		  '(((foo) (foo))
		    ((baz) (baz)))
		  '(((foo) (foo))
		    ((foo) (foo)))
		  :rectified-polynomial (make-rectified-polynomial 2)
		  :target-row 0 :target-col 0
		  :start-row 0 :start-col 0)
  )

;;; --- 4. Decision making ---
;;; 
;;; This is the final layer. It asks every memory block for its
;;; opinion on the input and combines them into a binary T/NIL.
(defun sum-memories (item input memories
                     &rest keys &key &allow-other-keys)
  ;; Identify the 'old' value that currently exists at the target coordinates.
  (loop :with old := (elt (elt input
                               (+ (getf keys :start-row)
				  (getf keys :target-row)))
                          (+ (getf keys :start-col)
                             (getf keys :target-col)))
        :for memory :in memories
        ;; Sum up the scores from every memory block in the "brain".
        :sum (apply 'sum-one-memory item input memory keys)
          :into best-memory-yes
        ;; Final threshold: If the total signal is positive, return True (T).
        :finally (return (if (minusp best-memory-yes)
                             (values NIL old)
                             (values t old)))))

(when nil
  ;;; Test cases for sum-memories, eval the defparameters first!
  
  (defparameter *memories*
    '((((foo) (foo)) ((bar) (bar)))
      (((baz) (baz)) ((foo) (foo)))
      (((qux) (qux)) ((qux) (qux)))))

  (defparameter *poly-2* (make-rectified-polynomial 2))

  ;; Return T
  (sum-memories 'foo
		'(((foo) (foo)) ((bar) (bar))) ;; Input
		*memories* ;; The Library of templates
		:rectified-polynomial *poly-2*
		:start-row 0  :start-col 0
		:target-row 0 :target-col 0)

  ;; Returns NIL
  (sum-memories 'foo
		'(((qux) (qux)) ((qux) (qux))) 
		*memories*
		:rectified-polynomial *poly-2*
		:start-row 0  :start-col 0
		:target-row 0 :target-col 0)
  ;; returns NIL
  (sum-memories 'foo
		'(((baz) (baz)) ((foo) (foo))) 
		*memories*
		:rectified-polynomial *poly-2*
		:start-row 0  :start-col 0
		:target-row 0 :target-col 0)
  ;; returns T (targetting second row)
  (sum-memories 'foo
		'(((baz) (baz)) ((foo) (foo))) 
		*memories*
		:rectified-polynomial *poly-2*
		:start-row 0  :start-col 0
		:target-row 1 :target-col 0)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Game AI for a tic-tac-toe board! ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun ttt-candidates (board training-data)
  (loop :for r :from 0 :to 2
	:append (loop 
		  :for c :from 0 :to 2
		  :when (null (elt (elt *current-board* r) c)) ;; If the spot is empty
		    :collect
		    (list r c (sum-memories
			       'foo
			       board
			       training-data
			       :rectified-polynomial (make-rectified-polynomial 2)
			       :start-row 0 :start-col 0
			       :target-row r :target-col c)))))

(defun play-ttt (board training-data)
  (let* ((rated-positions (ttt-candidates board training-data))
	 (candidates (remove-if-not (lambda (x) (nth 2 x)) rated-positions)))
    (loop :for candidate :in candidates
	  :collect (cons (car candidate) (cadr candidate)))))

(when nil
  (let ((training-data
	  '(;; 1. Horizontal Win (Top Row)
	    (((foo) (foo) (foo))
	     (( )   ( )   ( ))
	     (( )   ( )   ( )))

	    ;; 2. Vertical Win (Left Column)
	    (((foo) ( )   ( ))
	     ((foo) ( )   ( ))
	     ((foo) ( )   ( )))

	    ;; 3. Diagonal Win (Top-Left to Bottom-Right)
	    (((foo) ( )   ( ))
	     (( )   (foo) ( ))
	     (( )   ( )   (foo)))

	    ;; 4. Diagonal Win (Top-Right to Bottom-Left)
	    ((( )   ( )   (foo))
	     (( )   (foo) ( ))
	     ((foo) ( )   ( )))))
	(board
	  '(((foo) (foo) ( )) ;; Potential win at (0, 2)
	    ((bar) ( )   ( ))
	    (( )   (bar) ( )))))
    (play-ttt board training-data))
  ;; Output: '((0 . 2))
  )