OPCOND4.PAS, op conditioning program with collection time

[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':frowning:
                          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;

end.