Category : Miscellaneous Language Source Code
Archive   : NEURAL.ZIP
Filename : BAM.PAS

program bam;
{ for further information
Rod Taber
General Dynamics
Electronics Division Mail Zone 7202-K
box 85310
San Diego, CA 92138

Mail without the Mail Zone takes 3 months.}

{$R+,V+,K+,C-,U-}

const
maxrows = 12;
maxcolumns = 12;
maxentries = 144;
maxpatterns = 4;
screenrows = 24;
screencolumns = 80;

type
threeD = array[0..maxpatterns,1..1,1..maxentries] of integer;
twoD = array[1..maxentries] of integer;
oneD = array[1..maxentries] of integer;
square = array[1..maxentries,1..maxentries] of integer;
Textin = string[15];
var

Ham:array[1..maxpatterns] of integer;
Bipolar_A,Bipolar_B,Pattern_A,Pattern_B :threeD;
OriginalTestPattern,OutPatt :oneD;
TestPattern,A_Check,B_Check :oneD;
Rows_A,Rows_B,Columns_A,Columns_B :integer;
MinHam,Num_Patterns,Length_A,Length_B :integer;
Memory :square;
topline,bottomline,margin,leftone,rightone :integer;
lefttwo,leftthree,righttwo,rightthree,leftfour :integer;
energy :real;
threshold,pattern_number,TL,LL,AR,AC,PAC,PAR :integer;
test_type,Matrix_Used :char;
Synchmode,input,input_a,input_b :boolean;
inputfile,outfle :text;
filename,filename2 :string[10];

{$I xface.inc}
{ *************************************************************************** }
function max(x,y: integer): integer;
begin
if x > y then max := x
else max := y;
end;
{ *************************************************************************** }


{ *************************************************************************** }
function min(x,y: integer): integer;
begin
if x < y then min := x
else min := y;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure zero_test;
var
index:integer;
begin
for index := 1 to maxentries do
TestPattern[index] := 0; { zero out Test matrix }
end;
{ *************************************************************************** }


{ *************************************************************************** }
Procedure Readcr(var charValue,errorCode:integer);
{Read the screen at cursor position}
type
RegPack = record
AL,AH,BL,BH,CL,CH,DL,DH : Byte;
BP,SI,DI,DS,ES,Flags : Integer;
end;
var
Regs : RegPack;

begin
with Regs do
begin
Errorcode:=0; {assume no error}
AH:=$8; BH:=$0; {code 8- screen read, page 0}
Intr($10,Regs); {get character in AL via int 10h}
charValue:= AL; {used to be AL - 48 !!!!!}
end;
end; {Readcr}
{ *************************************************************************** }


{ *************************************************************************** }
procedure Read_Row_and_Column_Values;

var
x:integer;
begin
repeat
textbackground(lightcyan);
clrscr; { clears out any predefined user background }
textmode(C80);
textbackground(lightcyan);
textcolor(red);
GoToXY(8,4);
write('B I D I R E C T I O N A L A S S O C I A T I V E M E M O R Y');
GoToXY(8,7); Textcolor(blue);
write('Enter the number of patterns to store. < 1..',maxpatterns,' > ');
readln(num_patterns);
GoToXY(8,8);
write('Enter the number of rows in pattern A: < 1..',maxrows,' > ');
readln(rows_a);
GoToXY(8,9);
write('Enter the number of columns in pattern A: < 1..',maxcolumns,' > ');
readln(columns_a);
GoToXY(8,10);
write('Enter the number of rows in pattern B: < 1..',maxrows,' > ');
readln(rows_b);
GoToXY(8,11);
write('Enter the number of columns in pattern B: < 1..',maxcolumns,' > ');
readln(columns_b);
GoToXY(8,12);
writeln('Enter the threshold of neuron activation:');
GoToXY(10,13);
write(' Value must be in range: - ',maxentries,', + ',maxentries,' ');
readln(threshold);
Length_A := Rows_A * Columns_A;
Length_B := Rows_B * columns_B;

TextColor(Red + Blink); { blinks if inputs are unacceptable }
if Length_A <= maxentries then input_a := True
else
begin
input_a := False;
GoToXY(13,17);
writeln('Values for matrix A are out of bounds.');
repeat until keypressed;
end;
if Length_B <= maxentries then input_b := True
else
begin
input_b := False;
GoToXY(13,17);
writeln('Values for matrix B are out of bounds.');
repeat until keypressed;
end;
if num_patterns < min(length_a,length_b) then input := True
else
begin
input := False;
GoToXY(13,17);
writeln('Number of patterns must be less than ',min(length_a,length_b));
repeat until keypressed;
end;
TextColor(Blue);
until (input_a and input_b and input); { all inputs are within range }
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure UseCurrentScreenSetup;

begin
{ Synchmode := True;
} topline := 5;
bottomline := 15;
margin := 3;
leftone := 4;
rightone := 18;
lefttwo := 22;
righttwo := 36;
leftthree := 40;
rightthree := 54;
leftfour := 58;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure SetMemoryToZero;
{$R+,V+,K+,C-,U-}

var
index,row,column,size:integer;

begin
size := max(length_a,length_b);
for row := 1 to size do
for column := 1 to size do
memory[row,column] := 0;
end;
{ *************************************************************************** }


{ *************************************************************************** }
Procedure SaveScreen(Matrix_Used:char;row_in,column_in:integer);

var
position,charValue,ErrorCode :integer;
begin
position := 1;
for AR := 1 to row_in do
begin
for AC := 1 to column_in do
begin
PAC:=LL+AC-1;
PAR:=TL+AR-1;
GoToXY(PAC,PAR);
Readcr(charValue,ErrorCode); Delay(2);
if ErrorCode <> 0 then write('error');

case Matrix_Used of
'A': begin
if charValue = 177 then
Pattern_A[Pattern_Number,1,position] := 1
else
Pattern_A[Pattern_Number,1,position] := 0;
end;
'B': begin
if charValue = 177 then
Pattern_B[Pattern_Number,1,position] := 1
else
Pattern_B[Pattern_Number,1,position] := 0;
end;
'T': begin
if charValue = 177 then
TestPattern[position] := 1
else
TestPattern[position] := 0;
end;
end; { end case }

position := position + 1;
end;
end;

{ the following text erases the instructions yet leaves the Test Pattern }
if Matrix_Used = 'T' then
begin
TextBackground(lightcyan);
GoToXY(1,BottomLine + 4); { Beginning of instructions on screen }
writeln(' ');
writeln(' ');
writeln(' ');
writeln(' ');
end;

end;
{ *************************************************************************** }


{ *************************************************************************** }
Procedure DataFromKeyboard (Matrix_Used:char; rows,columns:integer);

{PatternNumber must be defined prior to call}

var
char3 :char;
intval :integer;
charValue :integer;

label
loop1,InitLoop;

begin
TextBackground(lightgray);
GoToXY(1,1);
{ only print heading for the first time this screen appears i.e., Matrix_a }
if Matrix_Used <> 'B' then
case Pattern_Number of
0: begin
write(' Enter the Test Pattern');
end;

1..MaxPatterns:
begin
TextColor(blue);
write(' Enter Pattern Number ',pattern_Number:2 );
end;
end; {case}

TextColor(blue);
TextBackground(lightcyan);

case Matrix_Used of
'A' : begin { Matrix A input }
GoToXY(LL,TL - 2);
write('MATRIX A');
end;
'B' : begin { Matrix B input }
GoToXY(lefttwo,TL - 2);
write('MATRIX B');
end;
'T' : begin { TestPattern input }
GoToXY(LL,TL - 2);
write('TEST PATTERN');
end;
end; { end case }

TextColor(Magenta);
TextBackground(lightgray);

for AR:= 1 to Rows do
begin
for AC:= 1 to Columns do
begin
PAC:=LL+AC-1; {column to place cursor}
PAR:=TL+AR-1; {row to place cursor}
GoToXY(PAC,PAR);
write(chr(249));
GoToXY(PAC,PAR); { cursor stays in position }
end;
end;

{A zero matrix is now on the screen for Pattern 'PatternNumber'}

TextColor(blue); { I N S T R U C T I O N S }
TextBackground(lightcyan);
GoToXY(1,BottomLine + 4); { Next free line on screen }
writeln(' Position cursor using arrow keys.');
writeln(' Press period "." to change pattern.');
writeln(' Press space bar to remove changes.');
write(' Press RETURN to store Matrix after entering complete pattern');

Textbackground(lightgray);
InitLoop: GoToXY(LL,TL); { cursor to first element of input pattern}
AC:=LL; {initialize row and column counters}
AR:=TL;

loop1:read(kbd,char3);
intval:=ord(char3);
if intval = 27 then
begin
read(kbd,char3);
intval:=ord(char3);
end;

case intval of { beeps on attempt to move off pattern display }
80: begin
if AR + 1 >= Rows + TL then
begin sound(800); delay(60); nosound; end
else AR := AR+1; { down arrow}
end;
72: begin
if AR - 1 < TL then
begin sound(800); delay(60); nosound; end
else AR := AR-1; {up arrow}
end;
75: begin
if AC - 1 < LL then
begin sound(800); delay(60); nosound; end
else AC := AC-1; {left arrow}
end;
77: begin
if AC + 1 >= Columns + LL then
begin sound(800); delay(60); nosound; end
else AC := AC+1; {right arrow}
end;
46: begin {digits}
write(chr(177));
end;
32: begin
textcolor(magenta);
write(chr(249));
textcolor(blue);
end;
13: begin
SaveScreen(Matrix_Used,Rows,Columns); { works for Matrix A, B or Test }
end; {of case 13}

end;{case statement}

GoToXY(AC,AR); {goto new cursor position}
if intval <> 13 then goto loop1;

TextBackground(lightcyan);
end; {DataFromKeyboard}
{ *************************************************************************** }


{ *************************************************************************** }
procedure EraseOldMatrices;

begin
TextBackground(lightcyan);

{ clear old Matrix A }
LL := leftone;
for AR:= 1 to Rows_A do
begin
for AC:= 1 to Columns_A do
begin
PAC:=LL+AC-1; {column to place cursor}
PAR:=TL+AR-1; {row to place cursor}
GoToXY(PAC,PAR);
write(' ');
end;
end;

{ clear old Matrix B }
LL := lefttwo;
for AR:= 1 to Rows_B do
begin
for AC:= 1 to Columns_B do
begin
PAC:=LL+AC-1; {column to place cursor}
PAR:=TL+AR-1; {row to place cursor}
GoToXY(PAC,PAR);
write(' ');
end;
end;

end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure InputTestPattern;

var
n:integer;

begin
Pattern_Number := 0;
for n := 1 to maxentries do
begin
A_Check[n] := 0;
B_Check[n] := 0;
end;
TextColor(Red);
repeat
GoToXY(1,Bottomline + 2);
writeln(' ');
writeln(' ');
writeln(' ');
writeln(' ');
GoToXY(1,Bottomline + 2);
write(' Is test pattern of type A or B ? (A/B) ');
readln(test_type);
until test_type in ['a','A','b','B'];

GoToXY(1,Bottomline + 2); { erases 'Is test pattern of' query }
writeln(' ');

{ eliminate lower case input and relace with uppercase equivalent }
if test_type = 'a' then test_type := 'A';
if test_type = 'b' then test_type := 'B';

if test_type = 'A' then
begin
clrscr;
TL := topline; LL := leftone;
DataFromKeyboard('T',rows_a,columns_a);
end
else
begin { if test_type = B }
clrscr;
TL := topline; LL := leftone;
DataFromKeyboard('T',rows_b,columns_b);
end;
OriginalTestPattern := TestPattern;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure ComputeEnergy;

var
sum : real;
temp: oneD;
pattern_n,len_A,len_B,temp1: integer;

begin
sum := 0.0;
energy := 0.0;
for pattern_n := 1 to num_patterns do
begin
for len_B := 1 to Length_B do
begin
temp[len_B] := 0;
for len_A := 1 to Length_A do
begin
temp1 := ( memory[len_A,len_B] - 0 );
temp[len_B] := temp[len_B] + Pattern_A[pattern_n,1,len_A] * temp1;
end;
end;
for len_B := 1 to Length_B do
sum := sum + temp[len_B] * Pattern_B[pattern_n,1,len_B];
energy := -sum;
end;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure Hamming;

var
n,j:integer;

begin
for n := 1 to num_patterns do
Ham[n] := 0;
MinHam := 1;
for n := 1 to num_patterns do
begin
if test_type = 'A' then
begin
for j := 1 to Length_A do
if Pattern_A[n,1,j] <> OriginalTestPattern[j]
then Ham[n] := Ham[n] + 1;
if Ham[n] < Ham[MinHam] then MinHam := n;
end
else
begin
for j := 1 to Length_B do
if Pattern_B[n,1,j] <> OriginalTestPattern[j]
then Ham[n] := Ham[n] + 1;
if Ham[n] < Ham[MinHam] then MinHam := n;
end;
end;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure status(x,y:integer;TxT:textin);

var first:char;
last :textin;

begin
TextBackground(blue); { if status is not called from StatusLine }
first := copy(TxT,1,1);
last := copy(TxT,2,(length(TxT) - 1));
GoToXY(x,y); Textcolor(white); write(first);
GoToXY(x + 1,y); Textcolor(yellow); write(last);
end;
{ *************************************************************************** }


{ *************************************************************************** }
Procedure StatusLine;

var i:integer; ch:char;

begin

TextBackground(blue);
GoToXY(1,23);
for i := 1 to screencolumns do write(' '); { status line background }
GoToXY(12,23); TextColor(Yellow);
write('STATUS LINE - First letter of choice and RETURN selects:');
GoToXY(1,24);
for i := 1 to screencolumns do write(' '); { status line background }
Status(15,24,'Quit');
if SynchMode = True then Status(34,24,'Synch ')
else Status(34,24,'Asynch');
Status(55,24,'Ham dist');
GoToXY(15,20);
write('Select execution Mode -- Synchronous/Asynchronous');
repeat
begin
read(kbd,ch);
if ch in ['s','S'] then SynchMode := True;
if ch in ['a','A'] then SynchMode := False;
end;
until ch in ['a','A','s','S'];
if SynchMode = True then Status(34,24,'Synch ')
else Status(34,24,'Asynch');
Textbackground(lightcyan);Textcolor(blue);
GoToXY(15,20);
write(' ');

end;{StatusLine}
{ *************************************************************************** }


{ *************************************************************************** }
Procedure TurnPCcursorOff;
{get rid of regular cursor}
type
RegPack = record
AL,AH,BL,BH,CL,CH,DL,DH : Byte;
BP,SI,DI,DS,ES,Flags : Integer;
end;
var
Regs : RegPack;

begin
with Regs do
begin
AH:=$1; CH:=16;CL:= 0;
Intr($10,Regs);
end;
end;{TurnPCcursorOff}
{ *************************************************************************** }


{ *************************************************************************** }
Procedure TurnPCcursorOn;
{turn on regular cursor}
type
RegPack = record
AL,AH,BL,BH,CL,CH,DL,DH : Byte;
BP,SI,DI,DS,ES,Flags : Integer;
end;
var
Regs : RegPack;

begin
with Regs do
begin
AH:=$1; CH:=7;CL:= 9; {start line>end means cursor off}
Intr($10,Regs);
end;
end; {TurnPCcursorOn}
{ *************************************************************************** }


{ *************************************************************************** }
procedure BipolarizeB;

var
index:integer;

begin
for index := 1 to Length_B do
begin
if Pattern_B[Pattern_Number,1,index] = 0
then Bipolar_B[Pattern_Number,1,index] := -1
else Bipolar_B[Pattern_Number,1,index] := 1;
end;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure BipolarizeA;

var
index:integer;

begin
for index := 1 to Length_A do
begin
if Pattern_A[Pattern_Number,1,index] = 0
then Bipolar_A[Pattern_Number,1,index] := -1
else Bipolar_A[Pattern_Number,1,index] := 1;
end;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure Memorize_Bipolar;

var
pattern_n,len_A,len_B,temp : integer;

begin
GoToXY(4,bottomline + 2);
write(' * Please wait - Bipolarization in Progress * ');
for pattern_n := 1 to num_patterns do
for len_A := 1 to Length_A do
for len_B := 1 to Length_B do
memory[len_a,len_b] := memory[len_a,len_b] +
bipolar_a[pattern_n,1,len_a] *
bipolar_b[pattern_n,1,len_b];
end;
{ *************************************************************************** }


{ *************************************************************************** }
function CheckIfKeypressed: boolean;
var
ch:char; n,keyint: integer;

begin
if not(keypressed) then CheckIfKeypressed := False
else
begin
read(kbd,ch);
keyint := ord(ch);
case keyint of
113,81 : CheckIfKeypressed := True;
{ Q or q for Quit has been pressed }

115,83 : begin { S or s }
Synchmode := True;
Status(34,24,'Synch ');
CheckIfKeypressed := False; {continues execution}
end;

97,65 : begin { A or a }
Synchmode := False;
Status(34,24,'Asynch');
CheckIfKeypressed := False; {continues execution}
end;

104,72 : begin
for n := 1 to num_patterns do
begin
GoToXY(16,18 + (n-1));
write('Hamming Distance for Pattern ',test_type);
writeln(' ',n,' is :',Ham[n]);
end;
GoToXY(20,22);
writeln('Press any key to continue ');
repeat until keypressed;
GoToXY(20,22);
writeln(' ');
CheckIfKeypressed := False; {continues execution}
for n := 1 to num_patterns do
begin
GoToXY(16,18 + (n-1));
write(' ');
writeln(' ');
end;
end;
else CheckIfKeypressed := False;
{ no action taken }

end; { end case }
end;
end;
{ *************************************************************************** }

{ *************************************************************************** }
procedure Bammer(Test_Pat:oneD; test_now:char;
leng1,leng2:integer);

var
Memory_Transpose :Square;
maxrow,n,k,i,j,m,y,Start,Finish :integer;
BinVect :OneD;

begin

Textbackground(lightcyan);
TextColor(blue);
GoToXY(lefttwo,TL - 2);
write('MATRIX A');
GoToXY(leftthree,TL - 2);
write('MATRIX B');
Textbackground(lightgray);
TextColor(magenta);

if Synchmode = True then
begin { Synchronous Mode prints out all Neurons }

for j := 1 to leng1 do
OutPatt[j] := 0;

case test_now of
'A' : begin
B_Check := Test_Pat;

for i := 1 to leng2 do
if Test_Pat[i] = 0 then BinVect[i] := -1
else BinVect[i] := 1;

for i := 1 to leng1 do
for j := 1 to leng2 do
Memory_Transpose[j,i] := Memory[i,j];

for j := 1 to leng1 do
for i := 1 to leng2 do
OutPatt[j] := OutPatt[j] + BinVect[i] * Memory_Transpose[i,j];
end;
'B' : begin
A_Check := Test_Pat;

for i := 1 to leng2 do
if Test_Pat[i] = 0 then BinVect[i] := -1
else BinVect[i] := 1;

for i := 1 to leng1 do
for j := 1 to leng2 do
OutPatt[i] := OutPatt[i] + BinVect[j] * Memory[j,i];
end;
end; { end case }


for j := 1 to leng1 do
begin
if (OutPatt[j] - threshold) > 0 then TestPattern[j] := 1
else
if (OutPatt[j] - threshold) < 0 then TestPattern[j] := 0
else
case test_now of
'A' : TestPattern[j] := A_Check[j];
'B' : TestPattern[j] := B_Check[j];
end; { end case }
end; { end for Start to Finish }

case test_now of
'A':
begin
k := TL - 1; { prints out matrix A }
for y := 0 to Length_A - 1 do
begin
i := y mod Columns_A;
if i = 0 then k := k + 1;
GoToXY(lefttwo + i,k);
if TestPattern[y + 1] = 1 then write(chr(177))
else write(chr(249));
end;

k := TL - 1; { prints out matrix B }
for y := 0 to Length_B - 1 do
begin
i := y mod Columns_B;
if i = 0 then k := k + 1;
GoToXY(leftthree + i,k);
if Test_Pat[y + 1] = 1 then write(chr(177))
else write(chr(249));
end;
end; { 'A' }
'B':
begin
k := 1; { prints out matrix A }
for i := 0 to Rows_A - 1 do
begin
for j := 0 to Columns_A - 1 do
begin
GoToXY(lefttwo + j,TL + i);
if Test_Pat[k] = 1 then write(chr(177))
else write(chr(249));
k := k + 1;
end;
end;

k := 1; { prints out matrix B }
for i := 0 to Rows_B - 1 do
begin
for j := 0 to Columns_B - 1 do
begin
GoToXY(leftthree + j,TL + i);
if TestPattern[k] = 1 then write(chr(177))
else write(chr(249));
k := k + 1;
end;
end;
end; { 'B' }
end; { case test_now of }
end; { if Synchmode true }


if Synchmode = False then
begin { Asynchronous Mode prints out one Neuron }

for j := 1 to leng1 do
OutPatt[j] := 0;

case test_now of
'A' : begin
B_Check := Test_Pat;

for i := 1 to leng2 do
if Test_Pat[i] = 0 then BinVect[i] := -1
else BinVect[i] := 1;

for i := 1 to leng1 do
for j := 1 to leng2 do
Memory_Transpose[j,i] := Memory[i,j];

Start := Random(leng1);
if Start = 0 then Start := leng1;

for i := 1 to leng2 do
OutPatt[Start] := OutPatt[Start] +
BinVect[i] * Memory_Transpose[i,Start];
end;

'B' : begin
A_Check := Test_Pat;

for i := 1 to leng2 do
if Test_Pat[i] = 0 then BinVect[i] := -1
else BinVect[i] := 1;

Start := Random(leng1);
if Start = 0 then Start := leng1;

for i := 1 to leng2 do
OutPatt[Start] := OutPatt[Start] +
BinVect[i] * Memory[i,Start];
end;
end; { end case }


for j := 1 to leng1 do
begin
if (OutPatt[j] - threshold) > 0 then TestPattern[j] := 1
else
if (OutPatt[j] - threshold) < 0 then TestPattern[j] := 0
else
case test_now of
'A' : TestPattern[j] := A_Check[j];
'B' : TestPattern[j] := B_Check[j];
end; { end case }
end; { end for Start to Finish }


case test_now of
'A' : begin
k := TL - 1; { prints out matrix A }
for y := 0 to Length_A - 1 do
begin
i := y mod Columns_A;
if i = 0 then k := k + 1;
GoToXY(lefttwo + i,k);
if TestPattern[y + 1] = 1 then write(chr(177))
else write(chr(249));
end;

k := TL - 1; { prints out matrix B }
for y := 0 to Length_B - 1 do
begin
i := y mod Columns_B;
if i = 0 then k := k + 1;
GoToXY(leftthree + i,k);
if Test_Pat[y + 1] = 1 then write(chr(177))
else write(chr(249));
end;
end; { 'A' }

'B' : begin
k := 1; { prints out matrix A }
for i := 0 to Rows_A - 1 do
begin
for j := 0 to Columns_A - 1 do
begin
GoToXY(lefttwo + j,TL + i);
if Test_Pat[k] = 1 then write(chr(177))
else write(chr(249));
k := k + 1;
end;
end;

k := 1; { prints out matrix B }
for i := 0 to Rows_B - 1 do
begin
for j := 0 to Columns_B - 1 do
begin
GoToXY(leftthree + j,TL + i);
if TestPattern[k] = 1 then write(chr(177))
else write(chr(249));
k := k + 1;
end;
end;
end; { 'B' }
end; { case test_now of }
end; { end if Synchmode False }

GoToXY(1,Bottomline + 2);
TextBackground(lightcyan);
TextColor(blue);

end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure Bam;

begin

GoToXY(1,1); TextColor(Red);
write(' P R O C E S S I N G ');

if test_type = 'A' then
begin
repeat
Bammer(TestPattern,'B',Length_B,Length_A);
Bammer(TestPattern,'A',Length_A,Length_B);
until CheckIfKeypressed;
end
else
begin
repeat
Bammer(TestPattern,'A',Length_A,Length_B);
Bammer(TestPattern,'B',Length_B,Length_A);
until CheckIfKeypressed;
end;

end;
{ *************************************************************************** }


{ *************************************************************************** }
function DataFromFile:boolean;

begin
textbackground(lightcyan);
clrscr; { clears out any predefined user background }
textmode(C80);
textbackground(lightcyan);
textcolor(red);
GoToXY(8,4);
write('B I D I R E C T I O N A L A S S O C I A T I V E M E M O R Y');
DataFromFile := False;
GoToXY(1,8);
if yes(' Do you want to read the patterns from a file ? ') then
begin
GoToXY(1,9);
write(' Enter the filename to read from: ');
readln(filename);
assign(inputfile,filename);
{$I-}
reset(inputfile);
{$I+}
DataFromFile := True;
if not(ioresult = 0) then
begin
GoToXY(1,9); Textcolor(Red + Blink);
writeln('Unable to open file ');
exit;
end;
end;
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure ReadInFile;
var
temp:integer; ch:char;

begin
TurnPCcursorOff;
readln(inputfile,num_patterns);
readln(inputfile,Rows_A);
readln(inputfile,Columns_A);
readln(inputfile,Rows_B);
readln(inputfile,Columns_B);
Length_A := Rows_A * Columns_A;
Length_B := Rows_B * columns_B;
clrscr;
textcolor(blue); TL := topline;
GoToXY(1,1);
write('Reading Patterns from file: ',filename);
GoToXY(leftone,TL - 2);
write('MATRIX A');
GoToXY(lefttwo,TL - 2);
write('MATRIX B');
textbackground(lightgray);
textcolor(magenta);
for Pattern_Number := 1 to num_patterns do
begin
GoToXY(13,bottomline + 1);
write('Pattern ',Pattern_Number);
TL := topline; LL := leftone;
for AR := 1 to Rows_A do
begin
for AC := 1 to Columns_A do
begin
PAC := LL + AC - 1;
PAR := TL + AR - 1;
GoToXY(PAC,PAR);
read(inputfile,temp);
if temp = 1 then write(chr(177))
else write(chr(249));
end;
end;

LL := lefttwo; TL := topline;
for AR := 1 to Rows_B do
begin
for AC := 1 to Columns_B do
begin
PAC := LL + AC - 1;
PAR := TL + AR - 1;
GoToXY(PAC,PAR);
read(inputfile,temp);
if temp = 1 then write(chr(177))
else write(chr(249));
end;
end;

LL := leftone; TL := topline;
SaveScreen('A',Rows_A,Columns_A);
LL := lefttwo; TL := topline;
SaveScreen('B',Rows_B,Columns_B);
BipolarizeB;
BipolarizeA;

GoToXY(8,bottomline + 2); Textbackground(lightcyan);
Textcolor(red); write('Press any key to continue reading patterns.');
repeat until keypressed;
read(kbd,ch);
GoToXY(8,bottomline + 2); Textbackground(lightcyan);
write(' '); { erase above }
Textcolor(magenta); Textbackground(lightgray);

end; { for Pattern_Number }
textcolor(blue); Textbackground(lightcyan);
GoToXY(4, bottomline + 1); TurnPCcursorOn;
writeln('Enter the threshold of neuron activation:');
GoToXY(4,bottomline + 2);
write(' Value must be in range: - ',maxentries,', + ',maxentries,' ');
readln(threshold); TurnPCcursorOff;
GoToXY(4, bottomline + 1);
writeln(' ');
end;
{ *************************************************************************** }


{ *************************************************************************** }
procedure WriteToFile;
var n,z:integer;
begin
if yes(' Do you want to save the memory patterns to a file ? ') then
begin
write(' Enter the file name to save patterns to: ');
readln(filename2);
assign(outfle,filename2);
rewrite(outfle);
writeln(outfle,num_patterns);
writeln(outfle,Rows_A);
writeln(outfle,Columns_A);
writeln(outfle,Rows_B);
writeln(outfle,Columns_B);
for n := 1 to num_patterns do
begin
for z := 1 to Length_A do
write(outfle,Pattern_A[n,1,z],' ');
writeln(outfle);
for z := 1 to Length_B do
write(outfle,Pattern_B[n,1,z],' ');
writeln(outfle);
end;
close(outfle);
end;
end;
{ *************************************************************************** }


{ *************************************************************************** }
begin { MAIN }
repeat { until not 'yes try another set of patterns ' }
UseCurrentScreenSetup;
if DataFromFile = False then
begin { input is from the keyboard }
Read_Row_and_Column_Values;
SetMemoryToZero;
clrscr;
for Pattern_Number := 1 to num_patterns do
begin
TL := topline; LL := leftone;
DataFromKeyboard('A',rows_a,columns_a);
TL := topline; LL := lefttwo;
DataFromKeyboard('B',rows_b,columns_b);
BipolarizeB;
BipolarizeA;
if Pattern_Number <> num_patterns then EraseOldMatrices;
end;
end { input is from the keyboard }
else { input is from the files }
ReadInFile;
SetMemoryToZero;

Memorize_Bipolar;
ComputeEnergy;
TurnPCcursorOn;
repeat { until not yes 'another test pattern ' }
zero_test;
InputTestPattern;
Hamming;
TurnPCcursorOff;
StatusLine;
Bam;
TurnPCcursorOn;
WriteToFile;
until not yes(' Do you want to try another test pattern ? ');
until not yes(' Do you want to try another set of patterns ? ');
TextMode; { returns screen to previous graphics color mode }
clrscr;
end.