[From Bill Powers (950725.1540 MDT)]
Bruce Abbott, Rick Marken, other modelers.
Below is the code for OPCOND4.PAS, followed by the slightly revised code for
SETPARAM.PAS (allows longer labels in box). I'll follow with a writeup, but
figured you might want to get started. It seems to work, roughly, for the
Staddon data, although I don't have the optimal readouts of the variables
(peak behavior rate, mainly). It's initialized to show the bursts followed by
pauses; collection time is at 5.5 sec.
If you're missing any other modules, ask.
Best,
Bill P.
···
=======================================================================
program opcond4;
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 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);
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;
{======================================================}
begin
setgraphics;
setfillstyle(0,0);
clearviewport;
loadparams;
SetupParam(maxx - 200,0,13,param);
loadframe;
initcsys(csys);
for i := 1 to NUMFRAMES DO
initframe(frame[i]);
setcolor(white);
clock := 0.0;
tclock := 0.0;
timex := 0;
dt := 0.1;
x := 0;
showsked;
outtextxy(maxx - 200,maxy - 10,'PRESS q TO QUIT');
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;
tclock := tclock + dt;
end;
restorecrtmode;
closegraph;
end.
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.
Revised 941220 to include an initialization value in the parameter
list.
Revised 950610 to increase legend width to 12.
}
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[12];
case kind: char of
'b'
bvinit,bvmin,bvmax,bvstep: byte;
bv: ^byte;
);
'i': (
ivinit,ivmin,ivmax,ivstep: integer;
iv: ^integer;
);
'r': (
rvinit,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 rv^ := rvinit else
if kind = 'i' then iv^ := ivinit else
if kind = 'b' then bv^ := bvinit;
end;
xmark := 2;
xlegend := 2 + textwidth('>');
xdata := 2 + textwidth('>HHHHHHHHHHHH:');
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);
setviewport(0,0,getmaxx,getmaxy,false);
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;