;Author:     Kathi Dutton
;Date:       Fall 1999
;Line:       To create a perceptron neural network.
;File:       network.l  ( lisp (clos) )
;--------------------------------------------------------------------------
; enter "clos"

  ( in-package "PCL" )

;--------------------------------------------------------------------------
; modelling a neural network

;__________________________________________________________________________
; modelling a generic cell

  ( defclass cell () 
    ( ( network-address :accessor cell-network-address 
                        :initarg :network-address ) )
  )

; display method to display a cell

  ( defmethod display ( (c cell) )
    ( princ "CELL |> network-address = ")
    ( prin1 (cell-network-address c) )
    ( princ " <|" )
    ( terpri )
  )
   
; modelling an input cell

  ( defclass input-cell (cell) 
    ( ( layer-address :accessor input-cell-layer-address
                      :initarg :layer-address )
      ( input-value :accessor input-cell-input-value
                    :initarg :input-value )
    )
  )

; display method to display an input-cell

  ( defmethod display ( (ic input-cell) )
    ( princ "INPUT-CELL |> " )
    ( princ "network-address = " ) ( prin1 (cell-network-address ic) )
    ( princ ", layer-address = " ) ( prin1 (input-cell-layer-address ic) )
    ( princ ", input-value = " ) ( prin1 (input-cell-input-value ic) )
    ( princ " <|" ) ( terpri )
  )


; modelling an input layer which consists of n input-cells

  ( defclass input-layer ()
    ( ( size :accessor input-layer-size :initarg :size )
      ( cells :accessor input-layer-cells :initarg :cells )
    )
  )

; display method to display an input-layer 

  ( defmethod display ( (il input-layer) )
    ( princ "INPUT-LAYER ..." ) ( terpri )
    ( setf icl ( input-layer-cells il ) )
    ( dolist ( ic icl )
      ( display ic )
    )
  )


; modelling an output cell

  ( defclass output-cell (cell) 
    ( ( layer-address :accessor output-cell-layer-address
                      :initarg :layer-address )
      ( net-value :accessor output-cell-net-value :initarg :net-value )
      ( threshold :accessor output-cell-threshold :initarg :threshold )
      ( activation-value :accessor output-cell-activation-value 
                         :initarg :activation-value )
      ( output-value :accessor output-cell-output-value
                     :initarg :output-value )
    )
  )

; display method to display an output-cell

  ( defmethod display ( (oc output-cell) )
    ( princ "OUTPUT-CELL |> " ) 
    ( princ "network-address = " ) ( prin1 (cell-network-address oc) )
    ( princ ", layer-address = " ) ( prin1 (output-cell-layer-address oc) )
    ( princ ", net-value = " ) ( prin1 (output-cell-net-value oc) ) 
    ( princ ", threshold = " ) ( prin1 (output-cell-threshold oc) ) 
    ( princ "," ) (terpri) 
    ( princ " +++ activation-value = " )
    ( prin1 (output-cell-activation-value oc) )
    ( princ ", output-value = " ) ( prin1 (output-cell-output-value oc) )
    ( princ " <|" ) ( terpri )
  )

; modelling an output layer which consists of n output-cells

  ( defclass output-layer ()
    ( ( size :accessor output-layer-size :initarg :size )
      ( cells :accessor output-layer-cells :initarg :cells )
    )
  )
    
; display method to display the output layer

  ( defmethod display ( (ol output-layer) )
    ( princ "OUTPUT-LAYER ..." ) ( terpri )
    ( setf ocl ( output-layer-cells ol ) )
    ( dolist ( oc ocl )
       ( display oc )
    )
  )


; modelling a synapse

  ( defclass synapse ()
    ( ( source :accessor synapse-source :initarg :source )
      ( destination :accessor synapse-destination :initarg :destination )
      ( weight :accessor synapse-weight :initarg :weight )
    )
  )

; display method to display a synapse

  ( defmethod display ( ( s synapse ) ) 
    ( princ "SYNAPSE..." ) (terpri)
    ( setf sc (synapse-source s) ) 
    ( display sc )
    ( setf dc (synapse-destination s) )    
    ( display dc )
    ( princ "weight = " ) ( prin1 ( synapse-weight s ) )
    ( terpri )
  )  



; modelling a synapse space

  ( defclass synapse-space ()
    ( ( synapses :accessor synapse-space-synapses :initarg :synapses ) )
  )

; display method to display a synapse-space

  ( defmethod display ( ( ss synapse-space ) )
    ( princ "SYNAPSE-SPACE..." ) (terpri)
    ( setf ssl ( synapse-space-synapses ss ) )
    ( dolist ( s ssl ) 
      ( display s )
    )
  )

; modelling a two layer network system

  ( defclass perceptron ()
    ( ( input-layer :accessor perceptron-input-layer :initarg :input-layer )
      ( output-layer :accessor perceptron-output-layer :initarg :output-layer )
      ( synapses :accessor perceptron-synapses :initarg :synapses )
    )
  )

; display method to display a perceptron

  ( defmethod display ( (p perceptron) ) 
    ( setf pil (perceptron-input-layer p) )
    ( display pil )
    ( setf pol (perceptron-output-layer p) )
    ( display pol )
    ( setf pss (perceptron-synapses p) )
    ( display pss )
  )


; a method to make a perceptron called  make-perceptron-p
  ( defmethod make-perceptron-p ()
    ( make-il-of-p )
    ( make-ol-of-p )
    ( make-ss-of-p )
    ( make-instance 'perceptron :input-layer il :output-layer ol
        :synapses ss )
  )


; a method to create the input-layer for P

  ( defmethod make-il-of-p ()
    ( setf ic1 (make-instance 'input-cell :network-address 1 :layer-address 1
        :input-value () ))
    ( setf ic2 (make-instance 'input-cell :network-address 2 :layer-address 2
        :input-value () ))
    ( setf ic3 (make-instance 'input-cell :network-address 3 :layer-address 3
        :input-value () ))
    (setf il (make-instance 'input-layer :size 3 :cells (list ic1 ic2 ic3)))
  )

; a method to create the output-layer for P

  ( defmethod make-ol-of-p ()
    ( setf oc1 (make-instance 'output-cell :network-address 4 :layer-address 1
        :output-value () :threshold 0.8 :activation-value () :net-value () ))
    ( setf oc2 (make-instance 'output-cell :network-address 5 :layer-address 2
        :output-value () :threshold 0.8 :activation-value () :net-value () ))
    ( setf oc3 (make-instance 'output-cell :network-address 6 :layer-address 3
        :output-value () :threshold 0.4 :activation-value () :net-value () ))
    (setf ol (make-instance 'output-layer :size 3 :cells (list oc1 oc2 oc3)))
  )

; a method to create the synapse-space for p

  ( defmethod make-ss-of-p ()
   (setf s11 (make-instance 'synapse :source ic1 :destination oc1 :weight 0.5))
   (setf s12 (make-instance 'synapse :source ic1 :destination oc2 :weight 0.3))
   (setf s13 (make-instance 'synapse :source ic1 :destination oc3 
                :weight -0.3))
   (setf s21 (make-instance 'synapse :source ic2 :destination oc1 
                :weight -0.5))
   (setf s22 (make-instance 'synapse :source ic2 :destination oc2 :weight 0.3))
   (setf s23 (make-instance 'synapse :source ic2 :destination oc3 :weight 1.0))
   (setf s31 (make-instance 'synapse :source ic3 :destination oc1 :weight 0.5))
   (setf s32 (make-instance 'synapse :source ic3 :destination oc2 :weight 0.3))
   (setf s33 (make-instance 'synapse :source ic3 :destination oc3
                :weight -0.3))
   (setf ss (make-instance 'synapse-space :synapses (list s11 s12 s13 s21 s22
                                                     s23 s31 s32 s33)) )
  )

; apply perceptron method

  ( defmethod apply-perceptron ( (net perceptron) (inputs list) )
    ( establish-inputs net inputs )
    ( compute-net-values net )
    ( compute-activation-values net )
    ( compute-output-values net )
    ( ret-output-values-as-a-list net )
  )

; establish-inputs

  ( defmethod establish-inputs ( (net perceptron) (inputs list) &aux ) 
    ( setf il (perceptron-input-layer net) )
    ( setf ic-list (input-layer-cells il) )
    ( dotimes (x (length inputs) )
      ( setf input (nth x inputs) )
      ( setf ic (nth x ic-list) )
      ( setf (input-cell-input-value ic) input )     
   )
    ( setf perceptron-input-layer ic-list )
  )

;  compute net values

  ( defmethod compute-net-values ( (net perceptron) &aux )
    ( setf ol (perceptron-output-layer net) )
    ( setf oc-list (output-layer-cells ol) )
    ( dolist (oc oc-list)
      ( setf oc-synapses (find-leading-synapses net oc) )
      ( setf sum 0 )
      ( dolist (s oc-synapses) 
        ( setf ic (synapse-source s) )
        ( setf input (input-cell-input-value ic) )
        ( setf weight (synapse-weight s) )
        ( setf sum ( + ( * input weight ) sum) )
      )
      ( setf (output-cell-net-value oc) sum )
    )
    ( setf perceptron-output-layer oc-list )
  )

; find leading synapses

  ( defmethod find-leading-synapses ((net perceptron) (oc output-cell))
    ( setf result () )
    ( setf ss (perceptron-synapses net) )
    ( setf sl (synapse-space-synapses ss) ) 
     ( dolist (s sl)
      ( setf oc-s (synapse-destination s) )
      ( if (= (output-cell-layer-address oc-s) 
             (output-cell-layer-address oc) )
       ( setf result (cons s result) )
       
      ) 
    )
    result
  )

; compute activation value

  ( defmethod compute-activation-values ( ( net perceptron ) )
    ( setf ol (perceptron-output-layer net) )
    ( setf oc-list (output-layer-cells ol) )
    ( dolist (oc oc-list)
      ( if ( > ( output-cell-net-value oc  ) ( output-cell-threshold oc ) )
         ( setf ( output-cell-activation-value oc ) 1 )
      )
      ( if ( < ( output-cell-net-value oc ) ( output-cell-threshold oc ) )
         ( setf ( output-cell-activation-value oc) 0 ) 
      )
    )
    ( setf perceptron-output-layer oc-list )
  )

; compute-output-values

  ( defmethod compute-output-values ( (net perceptron) )
    ( setf ol (perceptron-output-layer net) )
    ( setf oc-list (output-layer-cells ol) )
    ( dolist (oc oc-list)
       ( setf ( output-cell-output-value oc ) (output-cell-activation-value oc) ) 
    )
    ( setf ol (make-instance 'output-layer :size 3 :cells (list oc1 oc2 oc3) ) ) 
    ( setf perceptron-output-layer ol)
  )

; return output values as a list

  ( defmethod ret-output-values-as-a-list ( (net perceptron) )
    ( setf ol (perceptron-output-layer net) )
    ( setf oc-list (output-layer-cells ol) )
    ( setf o-value-list ()  )
    ( dolist ( oc oc-list )
       ( setf o-value (output-cell-output-value oc) )
       ( setf o-value-list (cons o-value-list o-value ) )
    )
    ( prin1 o-value-list )
  )