-- revop.e
-- Revealed Operant Experiment Library
--
-- version 0.5
--
-- 4/29/98 - DAM added rf_by_hf argument to do_block_int and corresponding
--           arguments in all the wrapper functions. Made wrapper functions
--           do_rf_by_hf_block() and do_diverse_rf_by_hf_block().
--
-- 4/22/98 - DAM put floor() into center() to fix integer check
--           error.
--
-- 4/22/98 - DAM fixed improper call to center() on line 369
--
-- 4/22/98 - DAM added check for reinforcement >= $100 in which case 
--           makes message like: "You earned $5.00. Ring it up as 500."
--           Made function center() to position the cursor for a centered
--           string puts.
--
-- 4/22/98 - DAM unhacked extinction hack, made "do_diverse_block" 
--           wrapper. Added f1K to instruct() (instead of hit any key).
--           added check in instruct for single/multiline instruction.


include graphics.e
include file.e
include math.e
include get.e
include machine.e
include wildcard.e

--
-- constants
--
global constant true = 1,
		false = 0

global constant TIMEOUT_NEVER = 0 -- by default standard output
constant STDIN=0

-- Key Constants for Psycho experiments
global constant 
       enterK = 13,
       escapeK = 27,
       spaceK = 32,
       f1K = 315

-- "Drawing" constants
constant SCREEN=1
constant BLOCKLINE=repeat(219,29)

--
-- (local) globals
--
integer LOG
integer total_reward 
atom sound_off_time


function chomp(sequence s)
  -- strips the newline off strings 
  if s[length(s)]='\n' then 
    return s[1..length(s)-1] 
  else
    return s
  end if
end function

function isdigit(integer a)
  -- returns true if a is a digit
  if a >='0' and a <= '9' then
    return true
  else
    return false
  end if
end function

--
-- procedure init()
--
-- initializes graphics mode and opens log file
--
global procedure init()
   atom res
   sequence subject, session, date, fname, d

   -- initialize global variables
   total_reward=0
   sound_off_time=0

   -- interactively start the log file
   puts(SCREEN, "\nSubject: ")
   subject=chomp(gets(STDIN))
   puts(SCREEN, "\nSession: ")
   session = chomp(gets(STDIN))
   puts(SCREEN, "\nDate: ")
   date  = chomp(gets(STDIN))

   fname = subject & '.' & session   
   printf(SCREEN, "\nOpening data file %s...", {fname})

   -- make sure it doesn't already exist
   d = dir(current_dir())
   for i=1 to length(d) do
      if compare(upper(d[i][D_NAME]), upper(fname)) = 0 then
         printf(SCREEN, "ERROR: file %s already exists.", {fname})
         puts(SCREEN, "Please rename it and try again.")
         puts(SCREEN, "(hit any key to exit)")
         while get_key() = -1 do end while
         abort(1)
      end if
   end for

   -- ok, it's not there
   LOG=open(fname, "w")
   if LOG<0 then
      printf(SCREEN, "ERROR: couldn't open file %s for writing. Exiting.", {fname})
      while get_key() = -1 do end while
      abort(1)  
   end if
   printf(LOG,"Subject: %s\nSession: %s\nDate: %s\n\n", {subject, session, date})

   -- intit graphics
   res = graphics_mode(1) -- 40x24, 16 color text mode
   cursor(NO_CURSOR) -- hide cursor

   -- set up for using precise timing
   tick_rate(1000)

end procedure


global procedure finish()
   atom res
   close(LOG)
   res = graphics_mode(-1) -- normal text mode
end procedure


global procedure logs(sequence s)
   puts(LOG,s)
end procedure
  

--
-- function poll()
--
-- wait for key press for up to timeout seconds
-- return sequence: { key, time } 
-- (returned key value of -1 means timeout occurred)
--
global function poll (atom timeout)
    atom start_time, end_time, now
    integer key
    
    start_time = time()
    end_time = start_time + timeout
    now = 0
    key = -1
    
    while (key=-1 and (timeout=TIMEOUT_NEVER or now<end_time)) do
	now = time()
	key = get_key()
 	
	-- DEBUG 
	if key = escapeK then
	   finish()
	   abort(0)
	end if -- DEBUG
 
	-- turn off speaker if we've exceeded sound_off_time
        if sound_off_time and now > sound_off_time then
           sound(0)
           sound_off_time = 0
        end if
   
    end while
    
    return { key, now }
end function


procedure pause(atom duration)
    atom t, et
    sequence s

    et = time() + duration
    t = 0
    while t < et do
	s = poll(duration)
	t = time()
    end while
end procedure


procedure click()
    sound(600)
    sound_off_time = time() + .01
end procedure


procedure beep()
    sound(440)
    sound_off_time = time() + .05
end procedure


procedure boop()
    sound(110)
    pause(.05)
    sound(0)
end procedure


procedure green_square()
   text_color(BRIGHT_GREEN)
   for i = 5 to 21 do
      position(i,6)
      puts(SCREEN, BLOCKLINE)
   end for
   pause(.5)
   clear_screen()
   text_color(BRIGHT_WHITE)
end procedure
   

global procedure update_total_display()
   -- updates the screen to correctly display the
   -- global variable total_reward in the upper left
   -- corner.
   position(1,1)
   puts(SCREEN,"            ")
   position(1,1)
   printf(SCREEN,"$%-10.2f", {total_reward/100})
end procedure


global procedure readyStim()
   bk_color(BLACK)
   clear_screen()
   update_total_display()
end procedure


global procedure startedStim()
  bk_color(BLUE)
  clear_screen()
  update_total_display()
end procedure


global procedure goodKeyStim()
    click()
end procedure


global procedure ringup(integer amount)
   -- waits for subject to "ring up" the amount with the 
   -- number keys, then updates the total. 
   sequence RINGUP_KEYS
   integer done
   sequence in, s, v

   sound(440)
   pause(.125)
   sound(0)

   RINGUP_KEYS = {'1','2','3','4','5','6','7','8','9','0'}
   done = false
   while not done do
      -- get a ringup input
      s = {}
      in = {0}
      while in[1] != enterK do
         in = poll(TIMEOUT_NEVER)
         if find(in[1],RINGUP_KEYS) then
            s = append(s,in[1])
            click()
         end if
      end while
      -- make sure it matches the amount
      v = value(s)
      if v[1]=GET_SUCCESS and v[2] = amount then
         done = true
      else
         boop()
      end if
   end while
   total_reward = total_reward + amount
   update_total_display()
end procedure


procedure center(integer row, sequence str)
   -- positions cursor so that puts(SCREEN,str)
   -- will make str centered on row (assumes 40x25)
   integer x,mid,ln
   mid = 20
   ln = length(str)
   x = mid-floor(ln/2)
   position(row,x)
end procedure


procedure correctOpStim(integer amount)
   -- stim signaling *correct* operant
   sequence str

   if amount > 0 then      
      if amount > 99 then
	 str = sprintf("You just earned $%-.2f.", {amount/100})
         center(9,str)
         puts(SCREEN, str)
         str = sprintf("Ring it up as %d.", {amount})
         center(11,str)
         puts(SCREEN, str)
      else
         str = sprintf("You just earned %d cents.", {amount})
         center(9,str)
         puts(SCREEN,str)
	 str =  "Ring it up."
         center(11,str)
         puts(SCREEN,str)
      end if

      ringup(amount)
   end if 
end procedure


procedure incorrectOpStim()
   -- stim signaling complete but *incorrect* operant
   -- (nothing)   
end procedure


procedure incompleteOpStim()
   -- stim signaling *incomplete* operant (not enough keys)
    boop() pause(.05) boop() pause(.05) boop()
end procedure


procedure timeoutStim()
   -- stim signaling input timeout  
   boop()
end procedure


procedure displayHelp(sequence s)
   -- displays text s on the screen 
   -- and blocks until another key is hit
   sequence dummy
   center(10,s)
   puts(SCREEN,s)
   dummy = poll(5)
   clear_screen()
   update_total_display()
end procedure


global procedure instruct(sequence s)
   -- displays text of strings in s one per line on the screen
   -- and blocks for a key hit. Takes either a sequence of strings
   -- or a simple string. 
   sequence str, k

   k = {0,0}
   -- normalize simple string "foo" to {"foo"}
   if length(s)=0 then
      s = {""}
   elsif not sequence(s[1]) then
      s = {s}
   end if

   clear_screen()
   for i=1 to length(s) do
      str = s[i]
      center(11+i,str)
      puts(SCREEN,str)
   end for
   str = "Hit F1 to continue."
   center(11+length(s)+2,str)
   puts(SCREEN,str)
   while k[1] != f1K do
     k = poll(TIMEOUT_NEVER)
     if k[1] != f1K then
        boop()
     end if
   end while
   clear_screen()
end procedure


--
-- do_block_int(ops, keys, hfs, MIN_LENGTH, rfSched, helptext, use_green, require_diversity, rf_by_hf)
--
--               ops: the number of operants that must be completed to finish the block 
--              keys: the set of permissible keys for the rO body, e.g. "qweasdzxc"
--               hfs: the set of permissible header/footer pairs, e.g. {{"qzc","zse"},{"asd","qwe"}}
--        MIN_LENGTH: the minimum total length for a complete rO
--           rfSched: the reinforcement schedule to cycle through , e.g. { 5, 0, 0, 15, 0, 10 }
--          helptext: the text to display upon a number pad key being hit
--         use_green: true if every correct operant is reinforced with a green flash
-- require_diversity: true if repeating a recent hf (one of the past 3) is to be counted incorrect 
--          rf_by_hf: a sequence for the rf amt associated with the corresponding hf in hfs.
--
global procedure do_block_int (integer ops, sequence keys, sequence hfs, integer min_length, 
                               sequence rfSched, 
                               sequence helptext, 
                               integer use_green, 
                               integer require_diversity,
                               sequence rf_by_hf)
    
    -- declare log variables
    atom startTime, endTime
    integer code, rf
    sequence bodyKeys, bodyTimes
    
    -- declare various scratch variables
    integer k       -- key
    integer len     -- length of body sequence
    atom t          -- time
    integer done    -- flag
    sequence ke     -- key event
    sequence head, foot, hf
    integer opnum
    integer SCHEDULE_PERIOD
    integer n, hfnum

    sequence hfhist -- for require_diversity
    hfhist = {0,0,0}

    SCHEDULE_PERIOD = length(rfSched)
    opnum = 1

    -- log beginning of block
    printf(LOG, "# Beginning block of %d operants.\n", {ops}) 

    while (opnum <= ops) do
	
	-- reinitialize logging variables (different for each op)
	startTime = 0
	bodyKeys = {}
	bodyTimes = {}
	endTime = 0
	code = 0 -- default (incomplete)
	rf = -1
	
	
	--
	-- get Ra (wait for space bar press)
	--
	done = false
	readyStim()
	while (not done) do
	    ke = poll(TIMEOUT_NEVER) -- ke = { key, time }          
	    k = ke[1]
	    if k = spaceK then
		done = true
            -- a help key ? 
            elsif isdigit(k) then
               n = k-'0'+1
               if (n and n <= length(helptext)) then
                  displayHelp(helptext[n]) -- LOG IT? 
               end if
	    end if
	end while
	startTime = ke[2]
	startedStim() 


	-- 
	-- do operant body
	--
	done = false
	while (not done) do
	    
	    -- wait for a keypress (or timeout)
	    ke = poll(TIMEOUT_NEVER)
	    k = ke[1] -- key
	    t = ke[2] -- time
	    
	    -- timeout or wspace key (not allowed)
	    if k = -1 or k = spaceK then
		done = true
		endTime = t
                code = 0 
		
	    -- return key ?
	    elsif k = enterK then
		done = true
		endTime = t
                -- code:
		-- was the operant complete ?
		len = length(bodyKeys)
		if len >= min_length then -- was it long enough ?
		    head = bodyKeys[1..3] 
		    foot = bodyKeys[len-2 .. len]
                    hf = {head,foot} 
                    -- was the operant correct? 
                    hfnum = find(hf, hfs) 
		    if hfnum then
		       code = 1
                       if require_diversity then
                          -- if hfnum is one of the last 3 hfs the subject got
                          -- correct for, change code to -1 (incorrect)
                          if find(hfnum, hfhist) then
                             code = -1
                          else -- it's ok; update hfhist
                             hfhist[2..3] = hfhist[1..2]
                             hfhist[1] = hfnum
                          end if
                       end if -- require diversity
                    else 
                       -- it was complete but incorrect (h/f were wrong)
                       code = -1
		    end if 
		end if -- else it was incomplete and stays 0
	    
	    -- a body key ? 
	    elsif find(k, keys) then            -- is it an allowed key ?
		len = length(bodyKeys)
		-- check for trills
                -- no repeats of either of the previous 2 keys are allowed
                -- that is, ABC ok, ABA no good, ABB no good 
	        if not find(k, bodyKeys[max({1,len-1})..len]) then
		   bodyKeys = append(bodyKeys, k)
		   bodyTimes = append(bodyTimes, t)
		   goodKeyStim()
		end if
	    
	    end if -- timeout / return / body key
		
	end while -- body not done
	
	
	--
	-- do reinforcer
	--
	if code = 0 then 
	    incompleteOpStim()
	elsif code = -1 then 
            incorrectOpStim() 
	else -- code = 1

            -- pick the rf amount out of the rfSched
            rf = rfSched[remainder(opnum-1, SCHEDULE_PERIOD)+1]

            -- handle rf_by_hf case: the rf amount is dictated by identity of the hf used 
            if length(rf_by_hf)>0 then 
               rf = rf * rf_by_hf[hfnum] -- rf will have been 0 or 1 
            end if

            -- do the reinforcement
	    if use_green then
               green_square()
            end if
	    correctOpStim(rf)

	end if

	
	--
	-- do logging
	--
	print(LOG, {opnum,startTime,bodyKeys,bodyTimes,endTime,code,rf})
	puts(LOG, "\n")
	
	
	--
	-- move on to next operant if successful
	--
	if code = 1 then
	    opnum = opnum + 1
	end if
	
    end while -- opnum = 1 to ops

    -- log end of block
    puts(LOG, "# Ending block\n")

end procedure -- do_block

-- Log File Format
--
-- each sequence represents one attempted operant
--
-- { opnum, startTime, bodyKeys, bodyTimes, endTime, code, rf }
--
-- opnum: the operant number being attempted
-- startTime: the time the operant is begun (the Ra is executed)
-- bodyKeys: a sequence of keys making up operant body
-- bodyTimes: sequence of times for keys making up operant body 
-- endTime: the time that the operant ended
-- code: 0 for incomplete, -1 for incorrect, 1 for correct
-- rf: reinforcer given


--
-- wrappers for do_block_int
--

global procedure do_block(integer ops, sequence keys, sequence hfs, 
                          integer MIN_LENGTH, sequence rfSched, sequence helptext)
  -- just do_block_int but with 
  --   reinforce_correct <= false 
  --   require_diversity <= false
  do_block_int(ops, keys, hfs, MIN_LENGTH, rfSched, helptext, false, false, {})
end procedure

global procedure do_reinforced_block(integer ops, sequence keys, sequence hfs, 
                          integer MIN_LENGTH, sequence rfSched, sequence helptext)
  -- just do_block_int but with 
  --   reinforce_correct <= true 
  --   require_diversity <= false
  do_block_int(ops, keys, hfs, MIN_LENGTH, rfSched, helptext, true, false, {})
end procedure

global procedure do_diverse_block(integer ops, sequence keys, sequence hfs, 
                          integer MIN_LENGTH, sequence rfSched, sequence helptext)
  -- just do_block_int but with 
  --   reinforce_correct <= false
  --   require_diversity <= true (disallows repetition of hf used within 
  --    the past 3 trials)
  do_block_int(ops, keys, hfs, MIN_LENGTH, rfSched, helptext, false, true, {})
end procedure

global procedure do_rf_by_hf_block(integer ops, sequence keys, sequence hfs, 
                          integer MIN_LENGTH, sequence rfSched, sequence helptext, 
                          sequence amtsched)
  -- just do_block_int but with 
  --   reinforce_correct <= false
  --   require_diversity <= false (allows repetition of hf used within the past 3 trials)
  --   rf_by_hf <= amtsched (reward according to the hf used)
  --
  do_block_int(ops, keys, hfs, MIN_LENGTH, rfSched, helptext, false, false, amtsched)
end procedure

global procedure do_diverse_rf_by_hf_block(integer ops, sequence keys, sequence hfs, 
                          integer MIN_LENGTH, sequence rfSched, sequence helptext, 
                          sequence amtsched)
  -- just do_block_int but with 
  --   reinforce_correct <= false
  --   require_diversity <= true (disallows repetition of hf used within the past 3 trials)
  --   rf_by_hf <= amtsched (reward according to the hf used)
  --
  do_block_int(ops, keys, hfs, MIN_LENGTH, rfSched, helptext, false, true, amtsched)
end procedure