;Author:     Kathi Dutton
;Date:       Fall 1999
;Line:       To create a perceptron neural network.
;File:       nn2.l  ( lisp (clos) )
;--------------------------------------------------------------------------
;  elaboration: The following programs builts upon our previous network.
;  In this version a hidden layer is added.  The problem is to solve a
;  2X2 Dobo game.
;--------------------------------------------------------------------------
; 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 a hidden cell

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

; display method to display a hidden-cell

  ( defmethod display ( (hc hidden-cell) )
    ( princ "HIDDEN-CELL |> " )
    ( princ "network-address = " ) ( prin1 (cell-network-address hc) )
    ( princ ", layer-address = " ) ( prin1 (hidden-cell-layer-address hc) )
    ( princ ", net-value = " ) ( prin1 (hidden-cell-net-value hc) )
    ( princ "," ) (terpri)
    ( princ " threshold = " ) ( prin1 (hidden-cell-threshold hc) )
    ( princ ", +++ activation-value = " )
    ( prin1 (hidden-cell-activation-value hc) )
    ( princ ", output-value = " ) ( prin1 (hidden-cell-output-value hc) )
    ( princ " <|" ) ( terpri )
  )
  
; modelling an hidden layer which consists of n hidden-cells

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

; display method to display the hidden layer

  ( defmethod display ( (hl hidden-layer) )
    ( princ "HIDDEN-LAYER ..." ) ( terpri )
    ( setf hcl ( hidden-layer-cells hl ) )
    ( dolist ( hc hcl )
       ( display hc )
    )
  )
  
; 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 synapse1 ()
    ( ( source :accessor synapse1-source :initarg :source )
      ( destination :accessor synapse1-destination :initarg :destination )
      ( weight :accessor synapse1-weight :initarg :weight )
    )
  )

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

; display method to display a synapse

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

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

; modelling a synapse space

  ( defclass synapse1-space ()
    ( ( synapses1 :accessor synapse1-space-synapses1 :initarg :synapses1 ) )
  )

  ( defclass synapse2-space ()
    ( ( synapses2 :accessor synapse2-space-synapses2 :initarg :synapses2 ) )
  )

; display method to display a synapse-space

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

  ( defmethod display ( ( ss synapse2-space ) )
    ( princ "SYNAPSE-SPACE..." ) (terpri)
    ( setf ssl ( synapse2-space-synapses2 ss ) )
    ( dolist ( s ssl )
      ( display s )
    )
  )
; modelling a three layer network system

  ( defclass neural-network ()
    ( ( input-layer :accessor neural-network-input-layer 
                    :initarg :input-layer )
      ( hidden-layer :accessor neural-network-hidden-layer 
                     :initarg :hidden-layer )
      ( output-layer :accessor neural-network-output-layer 
                     :initarg :output-layer )
      ( synapses1 :accessor neural-network-synapse1-space-synapses1                                             :initarg :synapses1 )
      ( synapses2 :accessor neural-network-synapse2-space-synapses2
                  :initarg :synapses2 )
    )
  )

; display method to display a network

  ( defmethod display ( (n neural-network) ) 
    ( setf netil (neural-network-input-layer n) )
    ( display netil )
    ( setf nethl (neural-network-hidden-layer n) )
    ( display nethl )
    ( setf netol (neural-network-output-layer n) )
    ( display netol )
    ( setf netss1 (neural-network-synapse1-space-synapses1 n) )
    ( display netss1 )
    ( setf netss2 (neural-network-synapse2-space-synapses2 n) )
    ( display netss2 )
  )


; a method to make a 2x2 dobo net
  ( defmethod make-22-dobo (nr-hidden-nodes)
     ( setf net-add 1 )

; to create the input-layer for network

    ( setf ic1 (make-instance 'input-cell :network-address net-add 
        :layer-address 1 :input-value () ))
    ( setf net-add (+ net-add 1) ) 
    ( setf ic2 (make-instance 'input-cell :network-address net-add
        :layer-address 2 :input-value () ))
    ( setf net-add (+ net-add 1) )
    ( setf ic3 (make-instance 'input-cell :network-address net-add
        :layer-address 3 :input-value () ))
    ( setf net-add (+ net-add 1) )
    ( setf ic4 (make-instance 'input-cell :network-address net-add
        :layer-address 4 :input-value () ))
    (setf il (make-instance 'input-layer :size 4 
        :cells (list ic1 ic2 ic3 ic4)))
  
; to create the hidden layer for network
   
   ( setf h-layer-add 1 )
   ( setf hc-list () )
   ( setf size 0 )
   ( dotimes (i nr-hidden-nodes) 
     ( setf node-nr (make-instance 'hidden-cell :network-address net-add
         :layer-address h-layer-add :net-value 'nil :threshold 'nil
         :activation-value 'nil :output-value 'nil) )
     ( setf h-layer-add (+ h-layer-add 1) )
     ( setf net-add (+ net-add 1) )
     ( setf size (+ size 1) )
     ( setf hc-list (cons node-nr hc-list) ) 
   )
   ( setf hl (make-instance 'hidden-layer :size size :cells hc-list) ) 


; to create the output-layer for network

   ( setf oc1 (make-instance 'output-cell :network-address net-add 
       :layer-address 1 :output-value () :threshold () :activation-value ()
       :net-value () ))
   ( setf ol (make-instance 'output-layer :size 1 :cells (list oc1) ) )

; to create the synapse-space for network

   ( setf s1-list () )
   ( setf s2-list () )
   ( setf ic-list ( input-layer-cells il ) )
   ( setf hc-list ( hidden-layer-cells hl ) )
   ( setf oc-list ( output-layer-cells ol ) )
   ( dotimes ( n (length hc-list) )
     (setf destination ( nth n hc-list ) ) 
       ( dotimes ( x (length ic-list) )
         ( setf source ( nth x ic-list ) )
         ( setf s1 (make-instance 'synapse1 :source source 
                      :destination destination :weight () ) )
         ( setf s1-list ( cons s1 s1-list  ) )
       )
   )
   ( dotimes ( n (length oc-list) )
     ( setf destination ( nth n oc-list ) )
       ( dotimes ( x (length hc-list) )
         ( setf source ( nth x hc-list ) )
         ( setf s2 (make-instance 'synapse2 :source source
                        :destination destination :weight () ) )
         ( setf s2-list ( cons s2 s2-list ) )
       )
   )   
   ( setf ss1 (make-instance 'synapse1-space :synapses1 s1-list) )
   ( setf ss2 (make-instance 'synapse2-space :synapses2 s2-list) )

; make the network

  ( setf net (make-instance 'neural-network :input-layer il :hidden-layer hl
               :output-layer ol :synapses1 ss1 :synapses2 ss2 ) )

; establish weights and thresholds
  ( establish-weights net )
  ( establish-thresholds net )

; make dobo

  ( setf net (make-instance 'neural-network :input-layer il :hidden-layer hl
               :output-layer ol :synapses1 ss1 :synapses2 ss2 ) )
  )


; establish weights

  ( defmethod establish-weights ( (net neural-network) )
    (princ "establish weights") (terpri)
    ( setf ss1 (neural-network-synapse1-space-synapses1 net) )
    ( setf sl1 (synapse1-space-synapses1 ss1) )
    ( dolist (s1 sl1)
      (princ "synapse1") (terpri)
      ( setf rn (random-low-high 1 9) )
      ( cond
       ( ( = rn 1 ) ( setf (synapse1-weight s1) 0.1 ) )
       ( ( = rn 2 ) ( setf (synapse1-weight s1) 0.2 ) )
       ( ( = rn 3 ) ( setf (synapse1-weight s1) 0.3 ) )  
       ( ( = rn 4 ) ( setf (synapse1-weight s1) 0.4 ) ) 
       ( ( = rn 5 ) ( setf (synapse1-weight s1) 0.5 ) ) 
       ( ( = rn 6 ) ( setf (synapse1-weight s1) 0.6 ) ) 
       ( ( = rn 7 ) ( setf (synapse1-weight s1) 0.7 ) ) 
       ( ( = rn 8 ) ( setf (synapse1-weight s1) 0.8 ) ) 
       ( ( = rn 9 ) ( setf (synapse1-weight s1) 0.9 ) )
       )
        (princ "weight= " ) (prin1 (synapse1-weight s1)) (terpri)
      )

    ( setf ss2 (neural-network-synapse2-space-synapses2 net) )
    ( setf sl2 (synapse2-space-synapses2 ss2) )
    ( dolist (s2 sl2)
      ( setf rn (random-low-high 1 9) )
      ( cond
       ( ( = rn 1 ) ( setf (synapse2-weight s2) 0.1 ) )
       ( ( = rn 2 ) ( setf (synapse2-weight s2) 0.2 ) )
       ( ( = rn 3 ) ( setf (synapse2-weight s2) 0.3 ) )
       ( ( = rn 4 ) ( setf (synapse2-weight s2) 0.4 ) )
       ( ( = rn 5 ) ( setf (synapse2-weight s2) 0.5 ) )
       ( ( = rn 6 ) ( setf (synapse2-weight s2) 0.6 ) )
       ( ( = rn 7 ) ( setf (synapse2-weight s2) 0.7 ) )
       ( ( = rn 8 ) ( setf (synapse2-weight s2) 0.8 ) )
       ( ( = rn 9 ) ( setf (synapse2-weight s2) 0.9 ) )
       )
     )
    ( setf neural-network-synapse1-space-synapses1 ss1 )                       
    ( setf neural-network-synapse2-space-synapses2 ss2 )
    )

; randomly assign threshold for hidden-cells & output-cell

    ( defmethod establish-thresholds ( (net neural-network) )
      ( setf ol (neural-network-output-layer net) )
      ( setf oc-list (output-layer-cells ol) )
      ( dolist ( oc oc-list )
         ( setf rn (random-low-high 1 9) )
           ( cond
             ( ( = rn 1 ) ( setf (output-cell-threshold oc) 0.1 ) )
             ( ( = rn 2 ) ( setf (output-cell-threshold oc) 0.2 ) )
             ( ( = rn 3 ) ( setf (output-cell-threshold oc) 0.3 ) )
             ( ( = rn 4 ) ( setf (output-cell-threshold oc) 0.4 ) )
             ( ( = rn 5 ) ( setf (output-cell-threshold oc) 0.5 ) )
             ( ( = rn 6 ) ( setf (output-cell-threshold oc) 0.6 ) )
             ( ( = rn 7 ) ( setf (output-cell-threshold oc) 0.7 ) )
             ( ( = rn 8 ) ( setf (output-cell-threshold oc) 0.8 ) )
             ( ( = rn 9 ) ( setf (output-cell-threshold oc) 0.9 ) )
           )
      )
      ( setf neural-network-output-layer oc-list )
 ; set thresholds for hidden-cells
      ( setf hl (neural-network-hidden-layer net) )
      ( setf hc-list (hidden-layer-cells hl) )
      ( dolist ( hc hc-list )
         ( setf rn (random-low-high 1 9) )
           ( cond
             ( ( = rn 1 ) ( setf (hidden-cell-threshold hc) 0.1 ) )
             ( ( = rn 2 ) ( setf (hidden-cell-threshold hc) 0.2 ) )
             ( ( = rn 3 ) ( setf (hidden-cell-threshold hc) 0.3 ) )
             ( ( = rn 4 ) ( setf (hidden-cell-threshold hc) 0.4 ) )
             ( ( = rn 5 ) ( setf (hidden-cell-threshold hc) 0.5 ) )
             ( ( = rn 6 ) ( setf (hidden-cell-threshold hc) 0.6 ) )
             ( ( = rn 7 ) ( setf (hidden-cell-threshold hc) 0.7 ) )
             ( ( = rn 8 ) ( setf (hidden-cell-threshold hc) 0.8 ) )
             ( ( = rn 9 ) ( setf (hidden-cell-threshold hc) 0.9 ) )
           )
      )
      ( setf neural-network-hidden-layer hc-list )  
    )
     
; random number generator

    ( defun random-low-high ( low high &aux spread xrn rn )
    ( setf spread ( + ( - high low ) 1 ) )    
    ( setf xrn ( random spread ) )
    ( setf rn ( + low xrn ) )    rn  )


; apply network method

  ( defmethod apply-neural-network ( (net neural-network) (inputs list) )
    (princ "inside apply-nerd-net") (terpri)
    ( 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 neural-network) (inputs list) &aux ) 
    ( princ "establish inputs") (terpri)
    (princ "inputs are ") (prin1 inputs) (terpri)
    ( setf il (neural-network-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 neural-network-input-layer ic-list )
  )

;  compute net values

  ( defmethod compute-net-values ( (net neural-network) &aux )
    (princ "compute net values") (terpri)
    ( setf hl (neural-network-hidden-layer net) )
    ( setf hc-list (hidden-layer-cells hl) )
    ( dolist (hc hc-list)
      ( setf hc-synapses1 (find-leading-synapses-1 net hc) )
      ( setf sum 0 )
      ( dolist (s1 hc-synapses1)
        (display s1)
        ( setf ic (synapse1-source s1) )
        ( setf input (input-cell-input-value ic) )
        ( setf weight (synapse1-weight s1) )
        ( princ "weight: ") (prin1 (synapse1-weight s1))(terpri)
        (princ "input: ") (prin1 input)(terpri)
        ( setf sum ( + ( * input weight ) sum) )
      )
      ( setf (hidden-cell-net-value hc) sum )
    )
    ( setf neural-network-hidden-layer hc-list )
    ( setf ol (neural-network-output-layer net) )
    ( setf oc-list (output-layer-cells ol) )
    ( dolist (oc oc-list)
      ( setf oc-synapses2 (find-leading-synapses-2 net oc) )
      ( setf sum 0 )
      ( dolist (s2 oc-synapses2) 
        ( setf hc (synapse2-source s2) )
        ( setf input (hidden-cell-net-value hc) )
        ( setf weight (synapse2-weight s2) )
        ( setf sum ( + ( * input weight ) sum) )
      )
      ( setf (output-cell-net-value oc) sum )
    )
    ( setf neural-network-output-layer oc-list )
  )

; find leading synapses two methods depending upon whether cell is oc or hc

  ( defmethod find-leading-synapses-1 ((net neural-network) (hc hidden-cell))
    (princ "find leading synapses 1") (terpri)
    ( setf result () )
    ( setf ss1 (neural-network-synapse1-space-synapses1 net) )
    ( setf sl1 (synapse1-space-synapses1 ss1) )
    ( list sl1)
     ( dolist (s1 sl1)
      ( setf hc-s1 (synapse1-destination s1) )
      ( if (= (hidden-cell-layer-address hc-s1)
             (hidden-cell-layer-address hc) )
       ( setf result (cons s1 result) )
      )     
    )
    result
  )


  ( defmethod find-leading-synapses-2 ((net neural-network) (oc output-cell))
    (princ "find leading synapses 2") (terpri)
    ( setf result () )
    ( setf ss2 (neural-network-synapse2-space-synapses2 net) )
    ( setf sl2 (synapse2-space-synapses2 ss2) ) 
     ( dolist (s2 sl2)
      ( setf oc-s2 (synapse2-destination s2) )
      ( if (= (output-cell-layer-address oc-s2) 
             (output-cell-layer-address oc) )
       ( setf result (cons s2 result) )
       
      ) 
    )
    result
  )


; compute activation value

  ( defmethod compute-activation-values ( ( net neural-network ) )
    (princ "compute-activation-values") (terpri)
    ( setf hl (neural-network-hidden-layer net) )
    ( setf hl-list (hidden-layer-cells hl) )
    ( dolist (hc hc-list)
      ( if ( > ( hidden-cell-net-value hc ) ( hidden-cell-threshold hc ) )
         ( setf ( hidden-cell-activation-value hc ) 1 )
      )
      ( if ( < ( hidden-cell-net-value hc ) ( hidden-cell-threshold hc ) )
         ( setf ( hidden-cell-activation-value hc ) 0 )
      )  
    )
    ( setf ol (neural-network-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 neural-network-output-layer oc-list )
  )

; compute-output-values

  ( defmethod compute-output-values ( (net neural-network) )
    (princ "compute output values") (terpri)
    ( setf ol (neural-network-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 neural-network-output-layer oc-list)
  )

; return output values as a list

  ( defmethod ret-output-values-as-a-list ( (net neural-network) )
    (princ "return output values") (terpri)
    ( setf ol (neural-network-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 (append o-value-list o-value ) )
    )
    ( prin1 o-value-list )
  )

  
; a method to test the neural network

  ( defmethod test (( net neural-network ))
    (princ "just made it to test dobo") (terpri)
    ( setf input-vectors '( (0000) (0001) (0010) (0011) (0100) (0101)
                            (0110) (1000) (1001) (1010) (1011) (1100)
                            (1101) (1110) (1111) ) )
    ( setf good '(01) ) ( setf bad '(00) ) 
    ( setf output-vectors (list good bad bad good bad good good bad
                           good good good good good good bad) )
    ( setf nr-correct 0 )
    ( princ "input/output vectors are set") (terpri)
    ( dotimes (i 15)
      ( setf iv (nth i input-vectors) )
      ( setf oc (nth i output-vectors) )
      ( princ "calling apply-nerd-net") (terpri)
      ( setf answer ( apply-neural-network net iv) )
      ( princ "yes made to back from apply-nerd-net") (terpri)
      ( if (equal ov answer)
           ( setf nr-correct ( + 1 nr-correct ) )
      )
    )
    ( = nr-correct 15 )
   )

; search for optimine hidden layer nodes

  ( defmethod hidden-node-search (&aux hidden-node-limit trial-limit)
    ( princ "hidden-node-search") (terpri)
    ( setf hidden-node-limit 6 )
    ( setf trial-limit 1000 )
    ( setf best-value-so-far -1 )
    ( setf best-net-so-far -1 )
    ( dotimes (h hidden-node-limit)
      ( setf nr-hidden-nodes (+ h 1) )
      ( dotimes (n trial-limit)
        ( princ "about to make-22-dobo") (terpri)
        ( setf net (make-22-dobo nr-hidden-nodes) )
        ( princ "return from make dobo") (terpri)
        ( setf result (test net) )
        (princ "return from test dobo") (terpri)
        ( cond
          ( ( > result best-value-so-far )
            ( setf best-value-so-far result )
            ( setf best-net-so-far net )
          )
        )
        ( if ( = best-value-so-far 15 )
            ( return-from hidden-node-search net ) 
        )
      )
    )
    return-from hidden-node-search best-net-so-far
  )