Implement 2-layers ffnnHEADmaster

2 files changed, 344 insertions, 0 deletions

diff --git a/src/algo2.lisp b/src/algo2.lisp
new file mode 100644
index 0000000..e1dc0b7
--- /dev/null
+++ b/src/algo2.lisp
@@ -0,0 +1,252 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; SYMBOLIC FEED-FORWARD NEURAL NETWORK ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; (C) 2026 Screwlisp, CC-By-SA
+;;;;
+;;;; Originally published on https://screwlisp.small-web.org/fundamental/a-better-deep-learning-algorithm/
+;;;;
+;;;; OVERVIEW: This 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.
+;;;; ==========================================================================
+
+(defpackage ffnn.algo2
+  (:use :cl)
+  (:export #:scan-all-memories))
+(in-package :ffnn.algo2)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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)
+  "Iterate over each place of one input row and return a number of pluses and minuses
+ for the proposed item to fit based on one row of memory."
+  (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 0) (target-col 0)
+			 (start-row 0) (start-col 0)
+			 rectified-polynomial &allow-other-keys)
+  "Iterate through each memory row and calculates the fit of the item in
+each input location based on the memory rows."
+  (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)
+  )
+
+(defparameter *poly-2* (make-rectified-polynomial 2))
+
+(defun sum-all-memories (item input memories target-row target-col)
+  "Iterate through all input cells and assign a score for the fit of item
+in that location based on memories."
+  (loop :for memory :in memories
+	:sum (sum-one-memory item input memory
+			     :target-col target-col
+			     :target-row target-row
+			     :rectified-polynomial *poly-2*)
+          :into best-memory
+        :finally (return best-memory)))
+
+(defun scan-all-memories (item input memories)
+  (loop :for row :in input
+	:for row-idx :from 0
+	:collect (loop :for col :in row
+		       :for col-idx :from 0
+		       :collect (sum-all-memories item input memories row-idx col-idx))))
+
+(when nil
+  (defparameter *layer1-memories*
+    '((((foo) (foo) (foo))
+       (() () ())
+       (() () ()))
+      (((foo) () ())
+       (() (foo) ())
+       (() () (foo)))
+      (((foo) () ())
+       ((foo) () ())
+       ((foo) () ()))))
+  (defparameter *layer2-memories*
+    '(((() () ())
+       (() () ())
+       (() () ()))
+      ((() () ())
+       (() () ())
+       (() () ()))
+      ((() () ())
+       (() () ())
+       (() () ()))))
+
+  (sum-all-memories 'foo '((() (foo) (foo))
+			   ((bar) (bar) ())
+			   (() () ()))
+		    *layer1-memories* 0 0) ;; 34
+
+  (sum-all-memories 'foo '(((foo) (bar)) ((qux) (foo))) *layer1-memories* 0 0) ;; 12
+
+  (scan-all-memories 'foo
+		     (scan-all-memories 'foo
+					'((() (foo) (foo))
+					  ((bar) (bar) ())
+					  (() () ()))
+					*layer1-memories*)
+		     *layer2-memories*)
+
+  )
diff --git a/tests/algo2.lisp b/tests/algo2.lisp
new file mode 100644
index 0000000..66f7f55
--- /dev/null
+++ b/tests/algo2.lisp
@@ -0,0 +1,92 @@
+(defpackage ffnn/tests/algo2
+  (:use :cl
+	:ffnn
+	:ffnn.algo2
+	:rove))
+
+(in-package :ffnn/tests/algo2)
+
+
+(deftest check-sum-one-row
+  (testing "sum-one-row"
+    (dolist (case '((foo ((foo) () (bar)) ((foo) (foo) (bar)) 1 (3 1))
+		    (foo ((bar) () (bar)) ((bar) (bar) (foo)) 1 (-1 1))
+		    (foo ((bar) () (bar)) ((bar) (bar) (bar)) 1 (1 3))
+		    (foo ((foo) () (bar)) ((foo) (foo) (bar)) nil (1 1))))
+      (destructuring-bind (item input memory index expected) case
+	(ok (equal (ffnn.algo2::sum-one-row item input memory index)
+		   expected))))))
+
+(deftest check-sum-one-memory
+  (testing "Sum one memory"
+    (ok (equal (ffnn.algo2::sum-one-memory 'foo
+		  '(((foo) (foo))
+		    ((bar) (bar))) ;; Input
+		  '(((foo) (foo))
+		    ((bar) (bar))) ;; Memory
+		  :rectified-polynomial (ffnn.algo2::make-rectified-polynomial 2)
+		  :target-row 0 :target-col 0
+		  :start-row 0 :start-col 0)
+	       12))
+    (ok (equal (ffnn.algo2::sum-one-memory 'foo
+		  '(((foo) (foo))
+		    ((baz) (baz)))
+		  '(((foo) (foo))
+		    ((foo) (foo)))
+		  :rectified-polynomial (ffnn.algo2::make-rectified-polynomial 2)
+		  :target-row 0 :target-col 0
+		  :start-row 0 :start-col 0)
+	       0))))
+
+
+(deftest check-sum-all-memories
+  (let ((memories '((((foo) (foo) (foo))
+       (() () ())
+       (() () ()))
+      (((foo) () ())
+       (() (foo) ())
+       (() () (foo)))
+      (((foo) () ())
+       ((foo) () ())
+       ((foo) () ())))))
+    (testing "Sum all memories"
+      (ok (equal
+	   (sum-all-memories 'foo '((() (foo) (foo))
+				    ((bar) (bar) ())
+				    (() () ()))
+			     memories 0 0)
+	   34))
+      (ok (equal
+	   (sum-all-memories 'foo '(((foo) (bar)) ((qux) (foo))) memories 0 0)
+	   12)))))
+
+
+(deftest check-scan-all-memories
+  (let ((layer1-memories
+	  '((((foo) (foo) (foo))
+	     (() () ())
+	     (() () ()))
+	    (((foo) () ())
+	     (() (foo) ())
+	     (() () (foo)))
+	    (((foo) () ())
+	     ((foo) () ())
+	     ((foo) () ()))))
+	(layer2-memories
+	  '(((() () ())
+	     (() () ())
+	     (() () ()))
+	    ((() () ())
+	     (() () ())
+	     (() () ()))
+	    ((() () ())
+	     (() () ())
+	     (() () ())))))
+    (ok (equal (scan-all-memories 'foo
+		     (scan-all-memories 'foo
+					'((() (foo) (foo))
+					  ((bar) (bar) ())
+					  (() () ()))
+					*layer1-memories*)
+		     *layer2-memories*)
+	       12))))