[From Bill Powers (950726.0905 MDT)]
Here is OPCOND5.PAS which does put jogs on the cumulative record where
reinforcements occur.
Bill P.
···
=======================================================================
program opcond5;
uses dos,crt,graph,frameplt,setparam;
const BGIDIR = '';
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;
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: integer;
min,prob,timer,cumrec: real;
skedtype: skedkindtype;
end;
var
csys: controlsystype;
sked: skedrectype;
param: paramlisttype;
ch: char;
graphdriver,graphmode,maxx,maxy: integer;
dt,clock,tclock: 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;
timecoll,colltime: real;
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';
bvinit := 0;
bvmin := 0;
bvmax := 3;
bvstep := 1;
bv := @sked.skedtype;
end;
with param[2] do
begin
legend := 'Interval';
kind := 'i';
ivinit := 44;
ivmin := 1;
ivmax := 500;
ivstep := 1;
iv := @sked.intrvl;
end;
with param[3] do
begin
legend := 'Range ';
kind := 'i';
ivinit := 15;
ivmin := 0;
ivmax := 500;
ivstep := 1;
iv := @sked.range;
end;
with param[4] do
begin
legend := 'Min ';
kind := 'r';
rvinit := 0.0;
rvmin := 0.001;
rvmax := 500.0;
rvstep := 0.0001;
rv := @sked.min;
end;
with param[5] do
begin
legend := 'Prob ';
kind := 'r';
rvinit := 0.02;
rvmin := 0.001;
rvmax := 1.0;
rvstep := 0.001;
rv := @sked.prob;
end;
with param[6] do
begin
legend := 'Ratio ';
kind := 'i';
ivinit := 20;
ivmin := 1;
ivmax := 500;
ivstep := 1;
iv := @sked.ratio;
end;
with param[7] do
begin
legend := 'Rew size';
kind := 'r';
rvinit := 100.0;
rvmin := 0.0;
rvmax := 1000.0;
rvstep := 2.0;
rv := @sked.reinfsize;
end;
with param[8] do
begin
legend := 'Decay*1k';
kind := 'r';
rvinit := 0.010;
rvmin := 0.0;
rvmax := 1.0;
rvstep := 0.0005;
rv := @csys.decay;
end;
with param[9] do
begin
legend := 'Ref lev ';
kind := 'r';
rvinit := 500.0;
rvmin := 0.0;
rvmax := 1000.0;
rvstep := 10.0;
rv := @csys.r;
end;
with param[10] do
begin
legend := 'Gain ';
kind := 'r';
rvinit := 5.0;
rvmin := 0.0;
rvmax := 100.0;
rvstep := 0.1;
rv := @csys.g;
end;
with param[11] do
begin
legend := 'Err max ';
kind := 'r';
rvinit := 50.0;
rvmin := 1.0;
rvmax := 1000.0;
rvstep := 1.0;
rv := @csys.emax;
end;
with param[12] do
begin
legend := 'Trig Lev';
kind := 'r';
rvinit := 100.0;
rvmin := 1.0;
rvmax := 200.0;
rvstep := 1.0;
rv := @csys.omax;
end;
with param[13] do
begin
legend := 'Coll Time';
kind := 'r';
rvinit := 5.5;
rvmin := 0.0;
rvmax := 60.0;
rvstep := 0.1;
rv := @colltime;
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] := 10000.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] := 800.0; ymax[2] := 800.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 jog;
var u,x,y:real;
i: integer;
begin
with frame[1] do
begin
u := yvar[3]^ * yscale[3];
y := my - ybase - yzero - round(u);
x := xbase + xzero + round(xvar^*xscale);
if (y > my - ybase - ysize) and (y < my - ybase) then
for i := -3 to 3 do
putpixel(round(x+i),round(y+i),white);
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}
o := 0.0; { OUTPUT TIMER }
action := false; { NO INITIAL ACTION }
timecoll := colltime;
end;
end;
{$F+}
function DetectVGA: integer;
begin
DetectVGA := 2;
end;
procedure setgraphics; {ADAPTS TO HARDWARE}
var err: integer;
begin
clrscr;
graphdriver := 0; graphmode := 0;
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 := 3600.0/(tclock - csys.oldclock);
csys.oldclock := tclock;
if enabled then
begin
inc(numreinf);
jog;
timecoll := colltime; { set timer for collection time }
tempreinfrate := 3600.0/(tclock - sked.oldclock);
sked.oldclock := tclock;
reinf := reinf + reinfsize; {ACCUMULATE REINFORCEMENTS}
counter := 0;
timer := 0.0;
enabled := false;
if skedtype = VR then
vratio := ratio + random(2*range) - range;
end
end;
with csys do
actionrate := actionrate + 0.0005*(tempactrate - actionrate);
reinfrate := reinfrate + 0.0005*(tempreinfrate - reinfrate);
end;
end;
procedure control(var csys: controlsystype; var sked: skedrectype);
begin
with csys do
begin
q := q + sked.reinf - decay*q*dt; {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 }
if timecoll >= 0.0 then
begin
timecoll := timecoll - dt; { count down collection time }
action := false;
end
else { collection time finished }
begin
o := o + g*e*dt; { integrate in output timer}
action := o > omax; { check trigger level}
if action then o := 0; { reset output timer}
end;
end;
end;
procedure showsked;
begin
moveto(maxx - 180,150);
settextstyle(0,0,1);
bar(maxx - 180,150,
maxx - 180+textwidth(' VARIABLE INTERVAL'),
150 + textheight('0'));
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;
{======================================================}