[From Bill Powers (941204.1755 MST)]
Here is OPCOND3.PAS and a slightly improved version of the SETPARAM.PAS
unit which allows setting byte parameters. This is the same program as
before except that now it uses both FRAMEPLT.PAS and SETPARAM.PAS and
thus can easily be changed. Also a few bugs have been found and fixed.
This is still work in progress and many improvements can be made. Others
are welcome to mangle the code.
OPCOND3 implements a choice of four schedules: Fixed Ratio (FR),
Variable Ratio (VR), Fixed Interval (FI), and Variable Interval (VI). A
basic control-system model is used, in which the rate of bar-pressing
(or whatever) is proportional to the error signal, the error signal is
the difference between a reference signal and a perceptual signal, and
the perceptual signal depends on the rate of reinforcement. The rate of
reinforcement depends on the schedule connecting the behavior to the
reinforcer, completing the closed loop.
The program is initialized to a _very_ arbitrary set of parameters, all
the important ones being adjustable while the program is running. Such a
wide range of performance is possible that only a systematic approach to
adjusting the parameters can lead to the best form of the model. The
main purpose of OPCOND3 is to allow the user to see the effects of
changing the various parameters. The cumulative record that is shown can
be made to look like most of those in Ferster and Skinner's _Schedules
of reinforcement_ for the four main types of schedule, although of
course learning effects are not represented.
The adjustable parameters are as follows (I've described this before but
a little repetition never hurts). There are some differences, so this is
the official word as of 941204:
SCHEDULE PARAMETERS:
{ THESE VARIABLES INITIALIZED FOR A SPECIFIC FR SCHEDULE }
skedtype := FR;
ratio := 20;
reinfsize := 154.0;
{THESE VARIABLES INITIALIZED FOR OTHER TYPES OF SCHEDULE}
prob := 0.025;
intrvl := 45;
range := 15;
min := 0.0;
Skedtype is an enumerated variable with values of FR, VR, FI, and VI.
However, the numbers 0,1,2, and 3 are shown on the display, because I
couldn't figure out a simple way to use SetParam for an enumerated
variable and display the appropriate symbol.
For a fixed-ratio schedule, only the "ratio" number counts. For a
variable-ratio schedule, the ratio varies at random between ratio-minus-
range and ratio-plus-range. For a fixed-interval schedule, the interval
in seconds is set by "intrvl" alone. And for a variable-interval
(constant-probability) schedule, "prob" sets the probability of a
reinforcement per second, and "min" sets the minimum interval in
seconds. There is no error-checking to see, for example, that "range" is
not set so large that a variable ratio can go negative.
CONTROL SYSTEM PARAMETERS:
Each reinforcement adds to the value of the perceptual signal an amount
equal to reinfsize (called "Rew size" on the screen). The new value of
the perceptual signal decays at a rate proportional to the signal, the
rate being set by "decay".
The reference signal is set by "Ref".
The resulting error signal is multiplied by "gain" and added to a timer
variable. A limit on the size of the error signal is set by "elim." When
the timer reaches a value called "olim," it is reset to zero and one
output action occurs.
···
-----------------------------------------------------------------------
program opcond3;
{
Version as of 941204.
Exit by typing 'q' or Escape key.
}
uses dos,crt,graph,frameplt,setparam;
const BGIDIR = '\tp\bgi';
NUMFRAMES = 2;
left = 203; right = 205; up = 200; down = 208; PgUp = 201; PgDn = 209;
Ins = 210; Del = 211; EndKey = 207; Home = 199; EscKey = 27; Cr = 13;
maxlimit: array[0..5] of real = (10.0,50.0,10.0,10.0,100.0,100.0);
minlimit: array[0..5] of real = (0.0,0.0,0.0,0.0,-100.0,-100.0);
delta: array[0..5] of real = (1.0,2.0,1.0,1.0,5.0,5.0);
type controlsystype = record
oldclock: real;
q,p,r,netg,e,o,omax,emax,g,decay: real;
action: boolean;
actionrate: real;
end;
skedkindtype = (FR,VR,FI,VI);
skedrectype = record
oldclock, oldreinf,oldnumacts: real;
numacts,numreinf: longint;
reinfsize,reinf,reinfrate: real;
enabled: boolean;
ratio,counter,intrvl,range,min: integer;
prob,timer,cumrec: real;
skedtype: skedkindtype;
end;
var
csys: controlsystype;
sked: skedrectype;
param: paramlisttype;
ch: char;
graphdriver,graphmode,maxx,maxy: integer;
dt,clock: real;
i,timex,x: integer;
maxcol: word;
frame: array[1..NUMFRAMES] of frametype;
clkint: longint;
clearplots: boolean;
paramptr: integer;
paramx,paramy: integer;
tempactrate,tempreinfrate: real;
vratio: integer;
function getcod: byte;
var ch: byte;
begin
ch := ord(readkey);
if (ch = 0) and keypressed then
ch := ord(readkey) or $80;
getcod := ch;
end;
procedure writereal(x,y: integer; r: real);
var numstr: string[20];
begin
str(r:6:2,numstr);
setfillstyle(0,0);
bar(x,y,x+textwidth(numstr),textheight('H'));
setcolor(white);
outtextxy(x,y,numstr);
end;
procedure writeint(x,y: integer; i: integer);
var numstr: string[20];
begin
str(i:6,numstr);
setfillstyle(0,0);
bar(x,y,x+textwidth(numstr),textheight('H'));
setcolor(white);
outtextxy(x,y,numstr);
end;
procedure loadparams;
begin
with param[1] do
begin
legend := 'Type ';
kind := 'b';
bvmin := 0;
bvmax := 3;
bvstep := 1;
bv := @sked.skedtype;
end;
with param[2] do
begin
legend := 'Interval';
kind := 'i';
ivmin := 1;
ivmax := 500;
ivstep := 1;
iv := @sked.intrvl;
end;
with param[3] do
begin
legend := 'Range ';
kind := 'i';
ivmin := 0;
ivmax := 500;
ivstep := 1;
iv := @sked.range;
end;
with param[4] do
begin
legend := 'Min ';
kind := 'r';
rvmin := 0.0;
rvmax := 500.0;
rvstep := 1.0;
rv := @sked.min;
end;
with param[5] do
begin
legend := 'Prob ';
kind := 'r';
rvmin := 0.0;
rvmax := 1.0;
rvstep := 0.001;
rv := @sked.prob;
end;
with param[6] do
begin
legend := 'Ratio ';
kind := 'i';
ivmin := 1;
ivmax := 500;
ivstep := 1;
iv := @sked.ratio;
end;
with param[7] do
begin
legend := 'Rew size';
kind := 'r';
rvmin := 0.0;
rvmax := 1000.0;
rvstep := 2.0;
rv := @sked.reinfsize;
end;
with param[8] do
begin
legend := 'Decay*1k';
kind := 'r';
rvmin := 0.0;
rvmax := 1.0;
rvstep := 0.0005;
rv := @csys.decay;
end;
with param[9] do
begin
legend := 'Ref lev ';
kind := 'r';
rvmin := 0.0;
rvmax := 300.0;
rvstep := 10.0;
rv := @csys.r;
end;
with param[10] do
begin
legend := 'Gain ';
kind := 'r';
rvmin := 0.0;
rvmax := 100.0;
rvstep := 0.1;
rv := @csys.g;
end;
with param[11] do
begin
legend := 'Err max ';
kind := 'r';
rvmin := 1.0;
rvmax := 100.0;
rvstep := 1.0;
rv := @csys.emax;
end;
with param[12] do
begin
legend := 'Trig Lev';
kind := 'r';
rvmin := 1.0;
rvmax := 200.0;
rvstep := 1.0;
rv := @csys.omax;
end;
end;
procedure loadframe;
begin
with frame[1] do
begin
numyvars := 3;
mx := maxx; my := maxy;
xbase := 40; ybase := 20;
xsize := 300; ysize := 450;
numxgrid := 30; numygrid := 50;
xzero := 0; yzero := 0;
xmax := 600.0; {sec}
ymax[1] := 500.0; ymax[2] := 5000.0; ymax[3] := 500;
ylegend[1] := 'REINF RATE/Hr';
ylegend[2] := 'BEH RATE/Hr';
ylegend[3] := 'CUMULATIVE RECORD';
xlegend := 'TIME, SEC';
color[1] := lightgreen; color[2] := lightred; color[3] := yellow;
yvar[1] := @sked.reinfrate;
yvar[2] := @csys.actionrate;
yvar[3] := @sked.cumrec;
xvar := @clock;
end;
with frame[2] do
begin
numyvars := 2;
mx := maxx; my := maxy;
xbase := 399; ybase := 50;
xsize := 240; ysize := 200;
numxgrid := 30; numygrid := 40;
xzero := 0; yzero := 0;
xmax := 600.0; {sec}
ymax[1] := 400.0; ymax[2] := 400.0;
ylegend[1] := 'REF SIG';
ylegend[2] := 'INPUT Q';
xlegend := 'TIME, SEC';
color[1] := lightgreen; color[2] := lightred;
yvar[1] := @csys.r;
yvar[2] := @csys.q;
xvar := @clock;
end;
end;
procedure initsked(var sked: skedrectype);
begin
paramx := 230; paramy := 50;
paramptr := 1;
tempactrate := 0.0;
tempreinfrate := 0.0;
with sked do
begin
{THESE VARIABLES ARE INITIALIZED TO THESE VALUES IN ANY CASE}
oldclock := 0.0;
reinfrate := 0.0;
numacts := 0;
numreinf := 0;
counter := 0;
cumrec := 0;
timer := 0.0;
reinf := 0.0;
enabled := false;
{ THESE VARIABLES INITIALIZED FOR A SPECIFIC FR SCHEDULE }
skedtype := FR;
ratio := 20;
reinfsize := 154.0;
{THESE VARIABLES INITIALIZED FOR OTHER TYPES OF SCHEDULE}
prob := 0.025;
intrvl := 45;
range := 15;
min := 0;
end;
end;
procedure initcsys(var csys: controlsystype);
begin
with csys do
begin
oldclock := 0.0; { USED FOR COMPUTING RATES }
actionrate := 0.0; { INITIAL ACTION RATE }
p := 0.0; { INITIAL PERCEPTUAL SIGNAL}
q := 0.0; { SENSED INPUT QUANTITY}
r := 201.0; { REFERENCE SIGNAL }
g := 1.0; { GAIN, ERROR-TO-RATE CONVERSION }
o := 0.0; { OUTPUT TIMER }
emax := 900.0; { ERROR LIMIT }
omax := 90.0; { TRIGGER LIMIT ON OUTPUT TIMER }
decay := 2.0e-2; { DECAY RATE OF INPUT QUANTITY }
action := false; { NO INITIAL ACTION }
end;
end;
{$F+}
function DetectVGA: integer;
begin
DetectVGA := 2;
end;
procedure setgraphics; {ADAPTS TO HARDWARE}
var err: integer;
begin
clrscr;
graphdriver := 0; graphmode := 0;
{err := installuserdriver('svga16',@detectvga);}
detectgraph(graphdriver,graphmode);
initgraph(Graphdriver,graphmode,BGIDIR);
graphmode := getmaxmode;
setgraphmode(graphmode);
maxx := getmaxx; maxy := getmaxy;
maxcol := getmaxcolor;
end;
{$F-}
procedure schedule(var sked: skedrectype; action: boolean);
var i: integer;
begin
with sked do
begin
{TEST FOR ENABLED CONDITION AND SET FLAG}
{EVERYTHING GETS RESET IN "IF PRESS" BELOW}
if (skedtype in [FR,VR]) then
begin
if action then
begin
inc(counter);
if skedtype = FR then
enabled := counter >= ratio
else
enabled := counter >= vratio;
end;
end
else {FOUND INTERVAL SCHEDULE }
if not enabled then
begin
timer := timer + dt;
case skedtype of
FI: enabled := (timer > intrvl);
VI: enabled := (random(10000) < round(1E4*prob*dt)) and (timer >=
min);
end;
end;
{IF PRESS, CHECK FOR DELIVERY}
if action then
begin
cumrec := cumrec + 1.0;
if cumrec > 500.0 then cumrec := 0.0;
inc(numacts);
tempactrate := tempactrate + 40.0;
if enabled then
begin
inc(numreinf);
tempreinfrate := tempreinfrate + 40.0;
oldclock := clock;
reinf := reinf + reinfsize; {ACCUMULATE REINFORCEMENTS}
counter := 0;
timer := 0.0;
enabled := false;
if skedtype = VR then
vratio := ratio + random(2*range) - range;
end
end;
tempreinfrate := tempreinfrate - dt/90.0*tempreinfrate;
tempactrate := tempactrate - dt/90.0*tempactrate;
with csys do
actionrate := actionrate + 0.001*(tempactrate - actionrate);
reinfrate := reinfrate + 0.001*(tempreinfrate - reinfrate);
end;
end;
procedure control(var csys: controlsystype; var sked: skedrectype);
begin
with csys do
begin
q := q + sked.reinf - decay*q*dt - 0.0001; {get reinforcer, apply decay}
if q < 0.0 then q := 0.0;
sked.reinf := 0.0;
e := r - q; { comparator & amplifier }
if e < 0.0 then e := 0.0; { one-way control }
if e > emax then e := emax; { limit error signal }
o := o + g*e*dt; { integrate in output timer}
action := o > omax; { check trigger level}
if action then
begin
o := 0; {reset output timer}
oldclock := clock;
end;
end;
end;
procedure showsked;
begin
moveto(frame[2].xbase - 40,maxy - frame[2].ybase + 15);
settextstyle(0,0,2);
bar(frame[2].xbase - 40,maxy - frame[2].ybase + 15,
frame[2].xbase+textwidth(' VARIABLE INTERVAL') - 40,maxy -
frame[2].ybase+31);
case sked.skedtype of
FR: outtext('FIXED RATIO');
VR: outtext('VARIABLE RATIO');
FI: outtext('FIXED INTERVAL');
VI: outtext('VARIABLE INTERVAL');
end;
settextstyle(0,0,1);
end;
{======================================================}
begin
setgraphics;
setfillstyle(0,0);
initsked(sked);
initcsys(csys);
clearviewport;
loadparams;
SetupParam(maxx - 200,0,12,param);
loadframe;
for i := 1 to NUMFRAMES DO
initframe(frame[i]);
setcolor(white);
clock := 0.0;
timex := 0;
dt := 0.1;
x := 0;
showsked;
ch := chr(0);
while not (ch in ['q',chr(EscKey)]) do
begin
control(csys,sked);
schedule(sked,csys.action);
for i := 1 to NUMFRAMES do
plotvar(frame[i]);
clearplots := false;
for i := 1 to NUMFRAMES do
clearplots := clock > frame[i].xsize/frame[i].xscale;
if clearplots then
begin
for i := 1 to NUMFRAMES do clrplot(frame[i]);
clock := 0.0;
end;
if keypressed then
begin
ch := changeparam(param);
showsked;
if ch = ' ' then ch := readkey;
end;
clock := clock + dt;
end;
restorecrtmode;
closegraph;
end.
Updated version of SetPAram unit follows:
Unit SetParam;
{ SetParam Unit. This Unit allows changing program parameters while the
program is running. SetUpParam draws a box with program variable
names in it with values of those variables. Using ChangeParam, selection
of a variable is done with the Up and Down arrow keys, and values are
changed with the + and - keys. A legend, a kind (integer or real), an
upper limit, a lower limit, a step size, and the address of a program
variable are specified in the record entry for each item in the parameter
list. The ChangeParam function returns the char value of the keystroke;
it is called on every iteration of the program in which parameters are
to be changed. When called conditionally on the "keystroke" test, it does
not interrupt the running program. Even if called without that test, it
returns to the running program immediately after each keystroke.
Before using ChangeParams, SetUpParam should be called once, with
arguments designating the x and y position of the upper left corner of
the box, the number of parameters, and the name of the parameter list,
which is a "var" argument of type paramlisttype, an array[1..MAXPARAMS] of
paramtype. MAXPARAMS is a constant set to 20. When SetUpParam is called,
it initializes the variables so they are within the lower and upper
limits specified in the record, if they are not already there.
WTP 941122.
Modification, 941204: A byte type has been added to the "kinds" of
records in paramtype. This is intended to be used with enumerated
types. If there are less than 256 elements in a type, one byte is
used to represent them. Of course this "kind" can be used for any
byte variables.
}
interface
const
left = 203; right = 205; up = 200; down = 208; PgUp = 201; PgDn = 209;
Ins = 210; Del = 211; EndKey = 207; Home = 199; EscKey = 27;
MAXPARAMS = 20;
type paramtype = record
legend: string[8];
case kind: char of
'b'
bvmin,bvmax,bvstep: byte;
bv: ^byte;
);
'i': (
ivmin,ivmax,ivstep: integer;
iv: ^integer;
);
'r': (
rvmin,rvmax,rvstep: real;
rv: ^real;
);
end;
paramlisttype = array[1..MAXPARAMS] of paramtype;
var
numparams: integer;
procedure SetupParam(bx,by,np: integer;
var paramlist: paramlisttype);
function ChangeParam(var p: paramlisttype): char;
implementation
Uses Crt,Dos,graph;
var xmark,xlegend,xdata,xbox,ybox: integer;
itemnum: integer;
function getcmd: byte;
var b: byte;
begin
b := ord(readkey);
if b = 0 then
begin
b := ord(readkey);
getcmd := b or $80;
end
else
getcmd := ord(b);
end;
procedure showparam(p: paramtype);
var numstr: string[10];
o: byte;
begin
with p do
case kind of
'b': begin
o := bv^;
str(o:10,numstr);
end;
'i': str(iv^:10,numstr);
'r': str(rv^:10:4,numstr);
end;
setfillstyle(0,0);
bar(xdata, 2 + (itemnum - 1)*10,
xdata + textwidth('+0000.0000'), 2 + (itemnum - 1)*10 +
textheight('0'));
outtextxy(xdata, 2 + (itemnum-1)*10,numstr);
end;
procedure SetupParam(bx,by,np: integer;
var paramlist: paramlisttype);
var j: integer;
begin
numparams := np;
for j := 1 to numparams do
with paramlist[j] do
begin
if kind = 'r' then
if rv^ < rvmin then rv^ := rvmin else
if rv^ > rvmax then rv^ := rvmax;
if kind = 'b' then
if bv^ < bvmin then bv^ := bvmin else
if bv^ > bvmax then bv^ := bvmax;
if kind = 'i' then
if iv^ < ivmin then iv^ := ivmin else
if iv^ > ivmax then iv^ := ivmax;
end;
xmark := 2;
xlegend := 2 + textwidth('>');
xdata := 2 + textwidth('>HHHHHHHH:');
xbox := bx; ybox := by;
setviewport(bx,by,bx + xdata + textwidth('+0000.0000') + 2,
by + numparams*10 + 4,true);
clearviewport;
rectangle(0,0,xdata + textwidth('+0000.0000') + 2,numparams*10 + 4);
for j := 1 to numparams do
begin
itemnum := j;
outtextxy(xlegend,2 + (j - 1)*10,paramlist[j].legend);
showparam(paramlist[j]);
end;
itemnum := 1;
setcolor(lightred);
outtextxy(xmark,2 + (itemnum - 1)*10,'>');
setcolor(white);
end;
function ChangeParam(var p: paramlisttype): char;
var cmd: byte;
begin
setviewport(xbox,ybox,xbox + xdata + textwidth('+0000.0000') + 2,
ybox + numparams*10 + 4,false);
cmd := getcmd;
setfillstyle(0,0);
gotoxy(xmark,2 + (itemnum - 1)*10);
bar(xmark,2 + (itemnum - 1)*10,xmark + textwidth('>'),
2 + (itemnum - 1)*10 + textheight('>'));
with p[itemnum] do
begin
case cmd of
Down: if itemnum < numparams then inc(itemnum)
else itemnum := 1;
Up : if itemnum > 1 then dec(itemnum)
else itemnum := numparams;
ord('+') : case kind of
'i': iv^ := iv^ + ivstep;
'b': bv^ := bv^ + bvstep;
'r': rv^ := rv^ + rvstep;
end;
ord('-') : case kind of
'i': iv^ := iv^ - ivstep;
'b': if bv^ > 0 then bv^ := bv^ - bvstep;
'r': rv^ := rv^ - rvstep;
end;
end;
end;
with p[itemnum] do
begin
if kind = 'r' then
if rv^ < rvmin then rv^ := rvmin else
if rv^ > rvmax then rv^ := rvmax;
if kind = 'b' then
if bv^ < bvmin then bv^ := bvmin else
if bv^ > bvmax then bv^ := bvmax;
if kind = 'i' then
if iv^ < ivmin then iv^ := ivmin else
if iv^ > ivmax then iv^ := ivmax;
end;
gotoxy(xmark,2 + (itemnum - 1)*10);
setcolor(lightred);
outtextxy(xmark,2 + (itemnum - 1)*10,'>');
setcolor(white);
showparam(p[itemnum]);
ChangeParam := chr(cmd);
setviewport(0,0,getmaxx,getmaxy,false);
end;
end.
Best,
Bill P.