'******************************************************************************
'Subject: The 1986 Rumelhart, Hinton and Williams backpropagation
' algorithm: a toy network classifier for capital letters.
'Author : Sjoerd.J.Schaper
'Date : 12-12-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
DEFSNG A-Z
DEFINT M-N, R-T
DECLARE SUB inlink (wt())
'initialize net links
DECLARE SUB capsin (aup(), sw)
'read letter map file
DECLARE SUB shuffle (nc(), nr)
'random letter sequence
DECLARE SUB forprop (alo(), wlo(), aup())
'propagate w/t sigmoid function
DECLARE SUB outerr (dup(), aup(), alo())
'compute output error
DECLARE SUB bakprop (dup(), aup(), dlo(), wlo())
'backpropagation
DECLARE SUB adjust (wlo(), dlo(), aup())
'adjust weights w/momentum
DECLARE SUB prints (alo(), nr)
'print test states
CONST G = 5 ' sigmoid gain
CONST ETA = .1 ' learning rate
CONST ALP = .5 ' momentum
CONST EPS = 1 ' error bound
CONST MIN = .05 ' small number
CONST IX = 5, IY = 7, NI = IX * IY ' letter box
CONST NH = 10 ' hidden layer
CONST NO = 26 ' capital letters
DIM lmap(NI * NO - 1) AS SINGLE ' letter maps
DIM ic(NO - 1) AS INTEGER ' letter indices
DIM ainp(NI) AS SINGLE ' input layer activations
DIM whid(NI, NH - 1, 1) AS SINGLE ' input -> hidden layer weights
DIM dhid(NH - 1) AS SINGLE ' hidden layer errors
DIM ahid(NH) AS SINGLE ' hidden layer activations
DIM wout(NH, NO - 1, 1) AS SINGLE ' hidden -> output layer weights
DIM dout(NO - 1) AS SINGLE ' output layer errors
DIM aout(NO - 1) AS SINGLE ' output layer activations
DIM atar(NO - 1) AS SINGLE ' target states
DIM SHARED errnet ' net error
RANDOMIZE TIMER: CLS
inlink whid(): ainp(NI) = 1 ' hidden layer bias
inlink wout(): ahid(NH) = 1 ' output layer bias
m = 0: train = -1
DO
m = m + 1
errsum = 0
IF train THEN
n = m MOD 9
IF n = 1 THEN
capsin lmap(), 1 ' training file
ELSEIF n = 0 THEN
capsin lmap(), 2 ' validation file
END IF
shuffle ic(), 19
ELSE
capsin lmap(), 3 ' testing file
OPEN ".\result.txt" FOR OUTPUT AS 1
shuffle ic(), 0
END IF
FOR t = 0 TO NO - 1
r = ic(t) * NI
FOR s = 0 TO NI - 1
ainp(s) = lmap(r + s) ' copy single letter map
NEXT s
FOR s = 0 TO NO - 1
atar(s) = MIN
NEXT s
atar(ic(t)) = 1 - MIN ' set target cell
forprop ahid(), whid(), ainp()
forprop aout(), wout(), ahid()
outerr dout(), aout(), atar()
errsum = errsum + errnet
IF train THEN
IF n > 0 THEN
bakprop dhid(), ahid(), dout(), wout()
adjust whid(), dhid(), ainp()
adjust wout(), dout(), ahid()
END IF
ELSE
prints aout(), ic(t) ' output test state
END IF
NEXT t
IF train THEN
train = INKEY$ = "" ' user abort
LOCATE 2, 3: PRINT "iteration"; TAB(17); m
e! = CSNG(CLNG(100 * errsum) / 100)
IF n > 0 THEN
LOCATE 3, 3: PRINT "training error"; e!; " "
t1 = errsum > EPS ' above error bound
ELSE
LOCATE 4, 3: PRINT "validation err"; e!; " "
t2 = valerr > errsum ' must decrease
train = train * -(t1 OR t2)
valerr = errsum
END IF
ELSE
PRINT #1, "iteration"; m; TAB(15); "testerr"; e!
EXIT DO
END IF
LOOP
CLOSE
SYSTEM
SUB adjust (wlo(), dlo(), aup())
FOR r = 0 TO UBOUND(dlo)
e = ETA * dlo(r) ' error term
FOR s = 0 TO UBOUND(aup) ' update weights
d = e * aup(s) ' delta
z = wlo(s, r, 1) + ALP * wlo(s, r, 0)
wlo(s, r, 1) = z + d: wlo(s, r, 0) = d
NEXT s
NEXT r
END SUB
SUB bakprop (dup(), aup(), dlo(), wlo())
FOR r = 0 TO UBOUND(dup)
e = 0
FOR s = 0 TO UBOUND(dlo)
e = e + dlo(s) * wlo(r, s, 1) ' lower layer
NEXT s
ds = G * aup(r) * (1 - aup(r)) ' partial derivative
dup(r) = ds * e ' error
NEXT r
END SUB
SUB capsin (aup(), sw)
SELECT CASE sw
CASE 1: l$ = ".\capitals.lif"
CASE 2: l$ = ".\validat.lif"
CASE ELSE: l$ = ".\testing.lif"
END SELECT
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: aup(t) = MIN
IF MID$(l$, s + 1, 1) = "*" THEN
aup(t) = 1 - MIN ' initial activation
END IF
NEXT s
NEXT r
CLOSE 1
END SUB
SUB forprop (alo(), wlo(), aup())
FOR r = 0 TO UBOUND(wlo, 2)
z = 0
FOR s = 0 TO UBOUND(aup) ' compute inner products
z = z + wlo(s, r, 1) * aup(s)
NEXT s
alo(r) = 1 / (1 + EXP(-G * z)) ' cell activation
NEXT r
END SUB
SUB inlink (wt())
e = 2 * MIN
FOR r = 0 TO UBOUND(wt, 1)
FOR s = 0 TO UBOUND(wt, 2) ' small random weights
wt(r, s, 1) = (RND - .5) * e
NEXT s
NEXT r
END SUB
SUB outerr (dup(), aup(), alo())
errnet = 0
FOR r = 0 TO UBOUND(dup) ' output layer
e = alo(r) - aup(r)
ds = G * aup(r) * (1 - aup(r)) ' partial derivative
dup(r) = ds * e ' error
errnet = errnet + e * e ' neterror sum
NEXT r
errnet = errnet * .5
END SUB
SUB prints (alo(), nr)
s = UBOUND(alo)
REDIM i(s) AS INTEGER
FOR r = 0 TO s
i(r) = r
NEXT r
DO
sw = -1: s = s - 1 ' bubble the alphabeth
FOR r = 0 TO s
IF alo(i(r)) < alo(i(r + 1)) THEN
SWAP i(r), i(r + 1): sw = 0
END IF
NEXT r
LOOP UNTIL sw
e0 = NO: e1 = 0
PRINT #1, CHR$(nr + 65); " ";
FOR r = 0 TO UBOUND(alo)
IF alo(r) < e0 THEN e0 = alo(r)
IF alo(r) > e1 THEN e1 = alo(r)
PRINT #1, CHR$(i(r) + 65); ' print letter sequence
NEXT r
e! = CSNG(CLNG(100 * LOG(e1 - e0)) / 100)
PRINT #1, " range"; e!;
e! = CSNG(CLNG(100 * LOG(errnet)) / 100)
PRINT #1, TAB(44); "neterr"; e!
END SUB
SUB shuffle (nc(), nr)
FOR r = 0 TO NO - 1
nc(r) = r
NEXT r
FOR t = 1 TO nr ' switch indices
r = INT(RND * NO)
s = INT(RND * NO)
SWAP nc(r), nc(s)
NEXT t
END SUB