! An example of Schema Abstraction using
! Minerva2, from Hintzman(1986) Psyc Rev
! Note: This is slightly different that Hintzman's exact
! version (to make it simpler) but does the same thing

PROGRAM Minerva2

use number_generators

implicit none


 integer, parameter  :: N_Feat = 13, &  ! # of features in each field
                        N_Cats = 3,  &  ! # of categories
			   Exp = 3,  &  ! # power of similarity metric
		       N_Items = 18, &  ! total # of exemplars to be learned
    	          High_Distort = 4,  &  ! # of features to flip in high distortion
		  Low_Distort  = 2,  &  ! # of features to flip in low distortion
		         SUBS  = 20     ! # of subjects (replications) to simulate
			   
 real,    parameter  ::      F = 0.0   ! probability of forgettig a feature


   real  :: Memory(N_Feat*2, N_Items), &
            Trace(N_Feat*2, N_Items),  &
            Prototype(N_Feat, N_Cats), &
	    Label(N_Feat, N_Cats),     &
	    Probe(N_Feat),             &
            Echo(N_Feat),              &
	    Activation             
	    
 integer :: i, j, idum, sample, time

!++++++++BEGIN SIMULATION++++++++++++++++++++++++++++++++++++++
 call RandSeed                 ! initializing the r-num generator
 
 
 
 
 Memory = 0                     ! make sure memory matrix is empty
  
 ! Generating Prototypes and Labels for N_Cats categories: 
 do i = 1, N_Cats
  Prototype(:,i) = Random_Vector(N_Feat)
  Label(:,i) = Random_Vector(N_Feat)
 enddo
 
 ! Creating memory with high-level distortions (n=4 flipped elements)
 ! We'll do 3, 6, and 9 distortions of Cats 1, 2, 3; identical to Hintzman (1986) p. 415
 do i = 1, 3 
   Memory(1:N_Feat,i) = Distort(Prototype(:,1), N_Feat, High_Distort)  ! making 3 distortions of Cat 1 prototype
   Memory(N_Feat+1:N_Feat*2,i) = Label(1:N_Feat,1)                     ! and labelling them "Cat 1" 
 enddo

 do i = 4, 9 
   Memory(1:N_Feat,i) = Distort(Prototype(:,2), N_Feat, High_Distort)  ! making 6 distortions of Cat 2 prototype
   Memory(N_Feat+1:N_Feat*2,i) = Label(1:N_Feat,2)                     ! and labelling them "Cat 2" 
 enddo
 
 do i = 10, N_Items 
   Memory(1:N_Feat,i) = Distort(Prototype(:,3), N_Feat, High_Distort)  ! making 9 distortions of Cat 3 prototype
   Memory(N_Feat+1:N_Feat*2,i) = Label(1:N_Feat,3)                     ! and labelling them "Cat 3" 
 enddo



 !OK, our memory is now full with exemplars that are distortions of the prototypes
 ! first, let's see what happens when we probe with a category label and get an echo back from
 ! memory...

 
 write(*,*) 'Let''s probe with "Category C" Label:'
 write(*,*) '====================================='

 Echo = 0  
 Probe = Label(:,3)
 
 do i = 1, N_Items
  Activation = Vector_Cosine(Probe, Memory(N_Feat+1:N_Feat*2, i), N_Feat) ** Exp   ! Activation formula, p. 413
  write(*,*) 'Exemplar', i, 'Activation: ', Activation
  Echo = Echo + (Memory(1:N_Feat,i)*Activation)
 enddo
 
 do i = 1, N_Items
   write(*,*) 'Similarity between echo and exemplar', i, ': ', Vector_Cosine(Echo, Memory(1:N_Feat,i), N_Feat)
 enddo

 write(*,*) 'Similarity between echo and C prototype: ', Vector_Cosine(Echo, Prototype(:,3), N_Feat)

 write(*,*)
 write(*,*) 'What we retrieved looks more like the prototype than any of the exemplars, even though it was not experienced!'



 write(*,*) 
 write(*,*) 'Now Let''s probe with "Category A" Label:'
 write(*,*) '========================================='
 
 Echo = 0  
 Probe = Label(:,1)
 
 do i = 1, N_Items
  Activation = Vector_Cosine(Probe, Memory(N_Feat+1:N_Feat*2, i), N_Feat) ** Exp   ! Activation formula, p. 413
  write(*,*) 'Exemplar', i, 'Activation: ', Activation
  Echo = Echo + (Memory(1:N_Feat,i)*Activation)
 enddo
 
 do i = 1, N_Items
   write(*,*) 'Similarity between echo and exemplar', i, ': ', Vector_Cosine(Echo, Memory(1:N_Feat,i), N_Feat)
 enddo

 write(*,*) 'Similarity between echo and A prototype: ', Vector_Cosine(Echo, Prototype(:,1), N_Feat)
 
 write(*,*)
 write(*,*) 'From the smaller category, the echo is a bit more like the exemplars than the prototype'


 write(*,*) 
 write(*,*) 'Next, a low and high-level distorted exemplar, what label comes back?'
 write(*,*) '====================================================================='

 Echo = 0
 Probe = Distort(Prototype(:,3), N_Feat, Low_Distort)
 
 do i = 1, N_Items
   Activation = Vector_Cosine(Probe, Memory(1:N_Feat,i), N_Feat) ** Exp  ! Activating memory traces relative to probe
   Echo = Echo + (Memory(N_Feat+1:N_Feat*2,i)*Activation) 
 enddo

 write(*,*) 'Low-level distortion'
 write(*,*) '===================='
 do i = 1, N_Cats
   write(*,*) 'Similarity of echo to Label ', i, ': ', Vector_Cosine(Echo, Label(:,i), N_Feat)
 enddo


 Echo = 0
 Probe = Distort(Prototype(:,3), N_Feat, High_Distort)
 
 do i = 1, N_Items
   Activation = Vector_Cosine(Probe, Memory(1:N_Feat,i), N_Feat) ** Exp  ! Activating memory traces relative to probe
   Echo = Echo + (Memory(N_Feat+1:N_Feat*2,i)*Activation) 
 enddo

 write(*,*) 
 write(*,*) 'High-level distortion'
 write(*,*) '====================='
 do i = 1, N_Cats
   write(*,*) 'Similarity of echo to Label ', i, ': ', Vector_Cosine(Echo, Label(:,i), N_Feat)
 enddo
 
 Echo = 0
 Probe = Prototype(:,3)
 
 do i = 1, N_Items
   Activation = Vector_Cosine(Probe, Memory(1:N_Feat,i), N_Feat) ** Exp  ! Activating memory traces relative to probe
   Echo = Echo + (Memory(N_Feat+1:N_Feat*2,i)*Activation) 
 enddo

 write(*,*) 
 write(*,*) 'Probing with C Prototype'
 write(*,*) '========================'
 do i = 1, N_Cats
   write(*,*) 'Similarity of echo to Label ', i, ': ', Vector_Cosine(Echo, Label(:,i), N_Feat)
 enddo
 
  Echo = 0
 Probe = Prototype(:,1)
 
 do i = 1, N_Items
   Activation = Vector_Cosine(Probe, Memory(1:N_Feat,i), N_Feat) ** Exp  ! Activating memory traces relative to probe
   Echo = Echo + (Memory(N_Feat+1:N_Feat*2,i)*Activation) 
 enddo

 write(*,*) 
 write(*,*) 'Probing with A Prototype'
 write(*,*) '========================'
 do i = 1, N_Cats
   write(*,*) 'Similarity of echo to Label ', i, ': ', Vector_Cosine(Echo, Label(:,i), N_Feat)
 enddo


!++++++++END SIMULATION++++++++++++++++++++++++++++++++++++++++




 CONTAINS
! Subroutines follow this statement
!=================================================================

!****************************************************************
function Random_Vector(D)
 integer  :: D, i
 real     :: Random_Vector(D), x

do i = 1, D
  x = ran3(idum)  ! random number 0 <= x <= 1 from uniform 
  if  (x >= 0.5) then
    Random_Vector(i) = 1    
  else
    Random_Vector(i) = -1
  endif
enddo
end function Random_Vector
!****************************************************************


!****************************************************************
function Distort(Vector, D, n_flip)
  integer :: i, j, D, n_flip, List(n_flip)
  real    :: Vector(D), Distort(D), x


 List = Rand_List(n_flip, D)        ! get a list of n_flip random numbers from 1..D

 Distort = Vector

do i = 1, n_flip
 Distort(List(i)) = -1.0 * Vector(List(i))   ! flipping bit
enddo

end function
!****************************************************************



!*****************************************************************
subroutine Forget(F, Matrix)
  integer  :: i, j
  real     :: F, Matrix(N_Feat*2,N_Items), x
  
 do i = 1, N_Items
   do j = 1, N_Feat*2
      x = ran3(idum) 
      if (x < F) Matrix(j,i) = 0   ! Forget the feature with a probability of F
   enddo
 enddo

end subroutine Forget
!*****************************************************************



!************************************************
!     SOME MATRIX ALGEBRA TOOLS:
!
!************************************************
!****************************************************************
function Vector_Length (Vector, n)
   integer :: i, n 
   real    :: Vector_Length, Vector(n), SS

 SS = 0.0
  SS = dot_product(Vector, Vector)
 Vector_Length = sqrt(SS)
end function Vector_Length 
!****************************************************************



!****************************************************************
subroutine Normalize (Vector_In, n)
   integer             :: i, n
   real                :: Vector_In(n), Vect_Length
    
  Vect_Length = 0.0 
  Vect_Length = Vector_Length(Vector_In, n)
  Vector_In = Vector_In / Vect_Length
end subroutine Normalize
!****************************************************************


!****************************************************************
function Vector_Cosine (Vector1, Vector2, n)
   
   real      :: Vector1(n), Vector2(n)
   real      :: Vector_Cosine
   integer :: n, i
 
 call Normalize(Vector1, n) 
 call Normalize(Vector2, n) 
 Vector_Cosine = dot_product(Vector1, Vector2)
 
end function Vector_Cosine
!****************************************************************

!**************************************************************** 
function Correlate (x, y, n) 
   real    :: Correlate, x(n), y(n), &
              yt, xt, t, syy, sxy, sxx, df, ay, ax
   integer :: n, j
   real, parameter :: tiny = 1.0e-20
   
  ax = 0.0
  ay = 0.0
  
  do j = 1, n
    ax = ax + x(j)
    ay = ay + y(j)
  end do
  
  ax = ax /n
  ay = ay /n
  sxx = 0.0
  syy = 0.0
  sxy = 0.0
  
  do j = 1, n
    xt = x(j) - ax
    yt = y(j) - ay
    sxx = sxx + xt**2
    syy = syy + yt**2
    sxy = sxy + xt * yt
  end do
  
  Correlate = sxy/sqrt(sxx*syy)
  
end function Correlate
!**************************************************************** 


END PROGRAM Minerva2