'******************************************************************************
'Subject: Auto-associative memory, John Hopfield's 1982 discrete
'         recurrent network: a toy engine for pattern recall.
'Author : Sjoerd.J.Schaper - vspickelen
'Date   : 12-14-2005
'Code   : all QBasic's, FreeBasic extendable
'Keys   : [Esc] quit program
'******************************************************************************
'This program is copyright (c) 2005 by the author. It is made available as is,
'and no warranty - about the program, its performance, or its conformity to any
'specification - is given or implied. It may be used, modified, and distributed
'freely, as long as the original author is credited as part of the final work.
'******************************************************************************
REM $STATIC
DEFINT A-Z

DECLARE SUB mapsin (sw)
'read map file
DECLARE SUB weights ()
'compute link weights
DECLARE SUB shuffle (nr)
'random update sequence
DECLARE FUNCTION propag (t)
'propagate signals
DECLARE SUB paints (t, a, nr)
'paint network cell t
DECLARE SUB prints ()
'print cell states

CONST MODE = 12, dW = 640, dH = 480
' set screenmode, width, height
'CONST MODE = 19, dW = 800, dH = 600 ' FreeBasic only

CONST IX = 13, IY = 13              ' bit box
CONST NI = IX * IY                  ' number of cells
CONST NO = 10                       ' number of bitmaps
CONST DEL = 20                      ' graphics delay

DIM SHARED bmp(NI * NO - 1)         ' binary bitmaps
DIM SHARED ic(NI - 1)               ' cell indices
DIM SHARED act(NI - 1)              ' bipolar activations
DIM SHARED wei(NI - 1, NI - 1)      ' weight matrix

mapsin 1 '                            training file
weights '                             imprint in memory

mapsin 2 '                            testing file
OPEN ".\result.txt" FOR OUTPUT AS 1

FOR n = 0 TO NO - 1

   t = n * NI
   FOR r = 0 TO NI - 1
      act(r) = bmp(t + r) '           copy single bitmap
      paints r, act(r), 0
   NEXT r
   LOCATE 2, 2: PRINT "map "; n + 1; " ";

   m = 0
   DO
      shuffle 19

      FOR r = 0 TO NI - 1 '           asynchronous updates
         m = m + 1
         
         IF propag(r) THEN m0 = m
         LOCATE 3, 2: PRINT "iter"; m; " ";
         IF INKEY$ <> "" THEN EXIT DO
      NEXT r
   LOOP UNTIL m - m0 > NI

   prints '                           output test state
NEXT n

SLEEP
CLOSE
SYSTEM

SUB mapsin (sw)
   l$ = ".\patterns.lif"
   IF sw > 1 THEN l$ = ".\badpatts.lif"
   OPEN l$ FOR INPUT AS 1

   FOR r = 0 TO NO * IY - 1
      DO
         IF NOT EOF(1) THEN LINE INPUT #1, l$
      LOOP WHILE l$ = ""
      FOR s = 0 TO IX - 1 '           scan line
         t = r * IX + s: bmp(t) = -1 '    low
         IF MID$(l$, s + 1, 1) = "*" THEN
            bmp(t) = 1 '                  high
         END IF
      NEXT s
   NEXT r
   CLOSE 1
END SUB

SUB paints (t, a, nr)
STATIC fl
IF NOT fl THEN
   SCREEN MODE
   PALETTE 0, &H180000
   PALETTE 1, &H0
   PALETTE 2, &H303030: COLOR 2
   r = 1 + dW * .25 * .618
   s = r + dW * .75 - 1: fl = -1
   VIEW (r, 1)-(s, dH - 2), 0, 2

   dx! = IX - .5: dy! = IY - .5
   WINDOW SCREEN (-.5, -.5)-(dx!, dy!)
   n = IX: IF IY > IX THEN n = IY '   max(IX, IY)
   FOR r = 0 TO n
      dt! = r - .5
      LINE (dt!, -.5)-(dt!, dy!), 1 ' draw grid
      LINE (-.5, dt!)-(dx!, dt!), 1
   NEXT r
END IF

   r = t \ IX
   s = t - r * IX
   PAINT (s, r), a + 1, 1 '           update cell
   SLEEP nr '                         wait...
END SUB

SUB prints
   g$ = STRING$(NI + IY * 2, " ")
   CrLf$ = CHR$(13) + CHR$(10)

   t = 1
   FOR r = 1 TO NI '                  extract pattern
      IF act(r - 1) = 1 THEN
         MID$(g$, t, 1) = "*"
      END IF
      t = t + 1
      IF r MOD IX = 0 THEN
         MID$(g$, t, 2) = CrLf$
         t = t + 2
      END IF
   NEXT r
   PRINT #1, g$
END SUB

FUNCTION propag (t)
    r = ic(t): z = 0
    FOR s = 0 TO NI - 1
       z = z + wei(r, s) * act(s)
    NEXT s '                          compute inner product

    sw = 0
    IF z <> 0 THEN '                  zero threshold
       n = 1: IF z < 0 THEN n = -1 '  pass through hard limiter
       IF act(r) <> n THEN
          act(r) = n: sw = -1
          paints r, n, DEL
       END IF
    END IF

propag = sw
END FUNCTION

SUB shuffle (nr)
   FOR r = 0 TO NI - 1
      ic(r) = r
   NEXT r

   FOR t = 1 TO nr '                  switch indices
      r = INT(RND * NI)
      s = INT(RND * NI)
      SWAP ic(r), ic(s)
   NEXT t
END SUB

SUB weights
   FOR n = 0 TO NO - 1 '              sum outer products
      t = n * NI '                    map offset
      FOR r = 0 TO NI - 1
         z = bmp(t + r)
         FOR s = 0 TO NI - 1
            wei(r, s) = wei(r, s) + z * bmp(t + s)
         NEXT s
      NEXT r
   NEXT n

   FOR r = 0 TO NI - 1 '              zero diagonal
      wei(r, r) = 0
   NEXT r
END SUB