'===========================================================================
' Subject: NEURAL NETWORKS                    Date: 10-17-99 (22:41)       
'  Author: Nathiel T. Tinsley                 Code: QB, QBasic, PDS        
'  Origin: ntins2000@email.msn.com          Packet: ALGOR.ABC
'===========================================================================
'I have converted a c++ adaptive resonance theory neural network into a
'Qbasic program from a book called "C++ Neural Networks and Fuzzy Logic"
'in Chapter 10 from pp. 199 - 221.  The output of the program is almost as
'exact as the C++ version.  I did this back in october of 1993 but I have
'redone it so as to put it online.  If you have any questions you may sent
'me e-mail at my current address at ntins10067@earthlink.net . I have done
'two other C++ neural network programs in Qbasic as well.
DECLARE SUB adjustweights1 ()
DECLARE SUB adjustweights2 ()
DECLARE SUB computation1 (k)
DECLARE SUB computation2 (b)
DECLARE SUB printactivations1 ()
DECLARE SUB printactivations2 ()
DECLARE SUB printoutputs1 ()
DECLARE SUB printoutputs2 ()
DECLARE SUB printweights1 ()
DECLARE SUB printweights2 ()
DECLARE SUB assignmentinput (b)
DECLARE SUB bpn (Network)
DECLARE SUB iterate (b, rr, kk)
DECLARE SUB printlearnedpattern ()
DECLARE SUB inqueryreset (t1)
DECLARE SUB getneuron (m1, m2, m3, y)
DECLARE SUB getnetwork (k, l, aa, bb, cc, dd, ll)
DECLARE FUNCTION restrmax (J, b, k)
DECLARE FUNCTION winner (k, v, kk)

COMMON SHARED aa, bb, cc, dd, ll, rr, so, sj

CONST MAXIMUMSIZE = 60, ar = 6, br = 7, rs = 8

' ar is the input neurons
' br is the output neurons

aa = 2!
bb = 2.5
cc = 6!
dd = .85
ll = 4!
rr = .95

DIM inptv(6)                    'input vector

TYPE Network
activation AS DOUBLE
result AS INTEGER
nnbr AS INTEGER                 'neural network output neuron
inn AS INTEGER                  'input neural network
outn AS INTEGER                 'output neural network
names AS STRING * 30
outwt AS DOUBLE                 'output weight
artneuron AS DOUBLE             'adaptive resonance theory neuron
END TYPE

TYPE artneuron          'adaptive resonance theory neuron
anrn AS INTEGER         'a neuron
bnrn AS INTEGER         'b neuron
anmbr AS INTEGER        'a neuron membership
bnmbr AS INTEGER        'b neuron membership
flag AS INTEGER
ninpt AS INTEGER        'neuron input
sj AS INTEGER
so AS INTEGER
winr AS INTEGER         'winner neuron
ai AS DOUBLE
be AS DOUBLE
ci AS DOUBLE
di AS DOUBLE
el AS DOUBLE
rho AS DOUBLE
END TYPE

DIM SHARED acts1(MAXIMUMSIZE)                            'activation set one
DIM SHARED acts2(MAXIMUMSIZE)                            'activation set two
DIM SHARED anmber                               'a neuron membership
DIM SHARED anrn(MAXIMUMSIZE) AS Network, artneuron       'a neuron
DIM SHARED bnmbr                                'b neuron membership
DIM SHARED bnrn(MAXIMUMSIZE) AS Network                  'b neuron
DIM SHARED b(MAXIMUMSIZE)
DIM SHARED x(MAXIMUMSIZE)
DIM SHARED y(MAXIMUMSIZE)
DIM SHARED x2(MAXIMUMSIZE)
DIM SHARED y2(MAXIMUMSIZE)
DIM SHARED xav(MAXIMUMSIZE)
DIM SHARED yav(MAXIMUMSIZE)
DIM SHARED xty(MAXIMUMSIZE)
DIM SHARED ci(MAXIMUMSIZE)
DIM SHARED outs1(MAXIMUMSIZE)
DIM SHARED outs2(MAXIMUMSIZE)
DIM SHARED mtrx1(MAXIMUMSIZE, MAXIMUMSIZE)                'Matrix set one
DIM SHARED mtrx2(MAXIMUMSIZE, MAXIMUMSIZE)                'Matrix set two
DIM SHARED outwt(MAXIMUMSIZE)                    'Output weight
DIM SHARED db(MAXIMUMSIZE)
DIM SHARED lrndptrn(MAXIMUMSIZE, MAXIMUMSIZE)             'learned pattern
DIM SHARED flag
DIM SHARED tmp
DIM SHARED rho
DIM SHARED jj
DIM SHARED tl
DIM SHARED ninpt                        'learned vector
DIM SHARED winr                         'winner neuron
DIM SHARED J, k

CLS

PRINT "This is a adaptive resonance theory neuron network."
PRINT "The neural network is set up for illustration with "; ar; " input "
PRINT "neurons and "; br; " output neurons.  This program is written in "
PRINT "Qbasic 1.1 by Nathiel Thomas Tinsley, who is attempting to create "
PRINT "a neural network program in Qbasic as effective as in c++."
PRINT "You may change the values of ar, br, and rs but do not tamper with"
PRINT "the rest of the program unless you understand its nature."

CALL getnetwork(ar, br, aa, bb, cc, dd, ll)
CALL iterate(inptv(0), rr, rs)
CALL iterate(inptv(1), rr, rs)
CALL iterate(inptv(2), rr, rs)
CALL iterate(inptv(3), rr, rs)

SUB adjustweights1

        FOR I = 0 TO anmbr
                I = I + 1
                IF outs1(I) > 0 THEN
                        mtrx1(I, winr) = 1!
                ELSE
                        mtrx1(I, winr) = 0
                END IF
                anrn(I / outwt(winr)).outwt = mtrx1(I, winr)
        NEXT I

        CALL printweights1

END SUB

SUB adjustweights2

        winr = winr + 1

        PRINT "Winner is "; winr; ":"

        FOR I = 0 TO anmbr
                I = I + 1
                IF outs1(I) > 0 THEN
                        mtrx2(winr, I) = el / (so + el - 1)
                ELSE
                        mtrx2(winr, I) = 0
                END IF

                bnrn(winr / outwt(I)).outwt = mtrx2(winr, I)
        NEXT I

        CALL printweights2

END SUB

SUB assignmentinput (b)

        sj = so = 0

        PRINT "Input vector: "

        FOR J = 0 TO anmbr
                J = J + 1
                PRINT b(J)
        NEXT J

        PRINT

        FOR J = 0 TO anmbr
                J = J + 1
                sj = b(J)
                anrn(J).activation = b(J) / (1! + ci + ai * (b(J) + be))
                acts1(J) = anrn(J).activation

                IF anrn(J).activation > 0 THEN
                        anrn(J).result = 1
                ELSE
                        anrn(J).result = 0
                        so = anrn(J).result
                END IF
        NEXT J

END SUB

SUB bpn (Network) STATIC
Network = Network + 1
END SUB

SUB computation1 (k)
        
        FOR J = 0 TO bnmbr
                J = J + 1
                FOR II1 = 0 TO anmbr
                        II1 = II1 + 1
                        ci(J) = outs1(II1) * mtrx2(J, II1)
                NEXT II1
                bnrn(J).activation = ci(J)
                acts2(J) = ci(J)
        NEXT J

        winr = 1

        winr = winr + winner(bnmbr, acts2, k)
        PRINT "Winner is "; winr

        FOR J = 0 TO bnmbr
                J = J + 1
                IF J IMP winr THEN
                        bnrn(J).result = 1
                ELSE
                        bnrn(J).result = 0
                        outs2(J) = bnrn(J).result
                END IF
        NEXT J

        CALL printactivations2
        CALL printoutputs2

END SUB

SUB computation2 (b)

        so = 0
        
        FOR J = 0 TO anmbr
                J = J + 1
                db(J) = 0
                FOR I = 0 TO bnmbr
                        I = I + 1
                        db(J) = mtrx1(J, I) * outs2(I)
                NEXT I
                tmp = b(J) + di * db(J)
                acts1(J) = (tmp - be) / (ci(J) + 1! + ai * tmp)
                anrn(J).activation = acts1(J)

                IF anrn(J).activation > 0 THEN
                        anrn(J).result = 1
                ELSE
                        anrn(J).result = 0
                END IF

                outs1(J) = anrn(J).result
                so = anrn(J).result
        NEXT J

        PRINT
        CALL printactivations1
        CALL printoutputs1

END SUB

SUB getnetwork (k, l, aa, bb, cc, dd, ll)

        anmbr = k
        bnmbr = l
        ninpt = 0
        ai = aa
        be = bb
        ci = cc
        di = dd
        el = ll
        flag = 0

        y1$ = STRING$(y1, "ANEURON")
        y1 = VAL(y1$)
        y2$ = STRING$(y2, "BNEURON")
        y2 = VAL(y2$)

        FOR I = 0 TO anmbr
                I = I + 1
                anrn(I).artneuron = anrn(I).artneuron
                CALL getneuron(I, bnmbr, 0, y1)
        NEXT I

        FOR I = 0 TO bnmbr
                I = I + 1
                bnrn(I).artneuron = bnrn(I).artneuron
                CALL getneuron(I, 0, anmbr, y2)
        NEXT I

        tmp1 = .2 + (be - 1!) / di
        tmp2 = -.1 + el / (anmbr - 1! + el)
        tmp3 = -be / (1! + ci)

        FOR I = 0 TO anmbr
                I = I + 1
                anrn(I).activation = tmp3
                acts1(I) = tmp3
                FOR J = 0 TO bnmbr
                        J = J + 1
                        mtrx1(I, J) = tmp1
                        mtrx2(J, I) = tmp2
                        anrn(I / J).outwt = mtrx1(I, J)
                        bnrn(J / I).outwt = mtrx2(J, I)
                NEXT J
        NEXT I

        CALL printweights1
        CALL printweights2
        CALL printactivations1
        PRINT

END SUB

SUB getneuron (m1, m2, m3, y)

        names = y
        nnbr = m1
        outn = m2
        inn = m3

        FOR I = 0 TO outn
                I = I + 1
                outwt(I) = .625
        NEXT I

        result = result + 0
        activation = activation + 0

END SUB

SUB inqueryreset (t1)

        flag = 0
        so = so - 1
        sj = sj - 1
        jj = so / sj
       
        PRINT "Degree of match "; jj; " vigilance "; rho; "."

        IF jj > rho THEN
                flag = 1
        ELSE
                PRINT "Winner is "; t1; "."
                PRINT "Reset required "
        END IF

END SUB

SUB iterate (b, rr, kk)

        rho = rr
        flag = 0

        CALL assignmentinput(b)
        CALL computation1(kk)
        CALL computation2(b)
        CALL inqueryreset(winr)

        IF flag IMP 1 THEN
                ninpt = ninpt + 1

                CALL adjustweights1
                CALL adjustweights2

                FOR J3 = 0 TO anmbr
                        J3 = J3 + 1
                        lrndptrn(ninpt, J3) = b(J3)
                        CALL printlearnedpattern
                NEXT J3
        ELSE
                FOR J = 0 TO bnmbr
                        J = J + 1
                        outs2(J) = 0
                        bnrn(J).result = 0
                NEXT J

                CALL iterate(b, rr, winr)
        END IF

END SUB

SUB printactivations1

        PRINT "Activations of F1 layers neurons: "

        FOR J = 0 TO anmbr
                J = J + 1
                PRINT acts1(J)
        NEXT J

        PRINT

END SUB

SUB printactivations2

        PRINT "Activations of F2 layer neurons: "

        FOR J = 0 TO bnmbr
                J = J + 1
                PRINT acts2(J)
        NEXT J

        PRINT

END SUB

SUB printlearnedpattern

        PRINT "Learned vector # "; ninpt; ":"

        FOR J = 0 TO anmbr
                J = J + 1
                PRINT lrndptrn(ninpt, J)
        NEXT J

        PRINT

END SUB

SUB printoutputs1

        PRINT "Outputs of F1 layer neurons: "

        FOR J = 0 TO anmbr
                J = J + 1
                PRINT outs1(J)
        NEXT J

        PRINT

END SUB

SUB printoutputs2

        PRINT "Outputs of F2 layer neurons: "

        FOR J = 0 TO bnmbr
                J = J + 1
                PRINT outs2(J)
        NEXT J

        PRINT

END SUB

SUB printweights1

        PRINT "Weights for F1 layer neurons: "

        FOR I3 = 0 TO anmbr
                I3 = I3 + 1
                FOR I4 = 0 TO bnmbr
                        I4 = I4 + 1
                        PRINT anrn(I3 / I4).outwt;
                NEXT I4
                PRINT
        NEXT I3

        PRINT

END SUB

SUB printweights2

        PRINT "Weights for F2 layer neurons: "
        FOR I3 = 0 TO bnmbr
                I3 = I3 + 1
                FOR I4 = 0 TO anmbr
                        I4 = I4 + 1
                        PRINT bnrn(I3 / I4).outwt
                NEXT I4
                PRINT
        NEXT I3

        PRINT

END SUB

FUNCTION restrmax (J, b, k)

        FOR I = 0 TO J
                I = I + 1
                IF I = k THEN
                        tmp = I
                        I = J
                END IF
        NEXT I

        FOR I = 0 TO J
                I = I + 1
                IF I = tmp AND I = k THEN
                        IF b(I) > b(tmp) THEN
                                tmp = I
                        END IF
                END IF
        NEXT I

END FUNCTION

FUNCTION winner (k, v, kk)

        t1 = restrmax(k, v, kk)

END FUNCTION