SHARE
TWEET

nn

incogn1too Jan 16th, 2012 1,050 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (define (n-mk lst) ;make new neuron
  2.   (list 'n lst))
  3.  
  4. (define (l-mk lst) ;make new layer
  5.   (list 'l lst))
  6.  
  7. (define (n-inp-lst x) ;return neuron wheights
  8.   (cadr x))
  9.  
  10. (define (n? x) ;check if x is neuron
  11.   (if (= (car x) 'n) #t #f))
  12.  
  13. (define (l-neuron-lst x) ;returns list of  layers neurons
  14.   (cadr x))
  15.  
  16. (define (l? x) ;checks if x is a layer
  17.   (if (= (car x) 'l) #t #f))
  18.  
  19. (define (l-inp-wh l) ;shows all layer neurns input wheights
  20.   (map (lambda(x)(n-inp-lst x)) (l-neuron-lst l)))
  21.  
  22. (define (l-out-wh l) ;returns all layer neuron output wheights
  23.   (transpose (map (lambda(x)(n-inp-lst x)) (l-neuron-lst l)) '()  ))
  24.  
  25. (define (net-inp-wh net) ;return all network input wheights
  26.   (map (lambda(x)(l-inp-wh x)) net))
  27.  
  28. (define (net-out-wh net) ;returns all network output wheights
  29.   (map (lambda(x)(l-out-wh x)) net))
  30.  
  31. (define (net-mk-data lst) ;make network from data list
  32.   (map (lambda(x)(l-mk-data x)) lst))
  33.  
  34. (define (l-mk-data lst) ;make layer from list
  35.   (l-mk (map (lambda(x)(n-mk x)) lst)))
  36.  
  37. (define (lst-push x lst) ;push
  38.   (cons x lst))
  39.  
  40. (define (lst-push-b x lst) ;push from the end
  41.   (append lst (list x)))
  42.  
  43. (define (randomize n lst) ;randomize returns n random numbers
  44.   (if (= n 0)
  45.         lst
  46.         (randomize (- n 1) (append (list (+ (random 9) 1) ) lst) )))
  47.  
  48. (define (empty? lst) ;checks if the list is empty
  49.   (if (= (length lst) 0) #t #f))  
  50.  
  51. (define (net-make lay) ;makes new network. lay consists of number of neuron for each layer
  52.   (net-mk-new (car lay) (cdr lay) '()))
  53.  
  54. (define (net-mk-new input n-lst lst) ;input - ammount of input neurons; n-lsts - list of neuron ammount for each layer
  55.   (let ( (lst1 (lst-push-b (l-mk-new input (car n-lst) '()) lst)) )
  56.   (if (= (length n-lst) 1) lst1 (net-mk-new (car n-lst) (cdr n-lst) lst1))))
  57.  
  58. (define (l-mk-new input n lst) ;makes new layer
  59.   (let ( (lst1 (append lst (list (n-mk (lst-rand input))))) ) ; seit kluda
  60.   (if (= n 1) (l-mk lst1) (l-mk-new input (- n 1) lst1))))
  61.  
  62. (define (lst-rand n) ;random returns n random numbers divided by 10
  63.   (map (lambda(x)(/ x 10)) (randomize n '()) ))
  64.  
  65. (define (n-akt x param) ;neuron activation function
  66.   (/ x (+ (abs x) param)))
  67.  
  68. (define (lst-sum lst);sums list
  69.   (apply + lst))
  70.  
  71. (define (n-proc neuron input) ;process single neuron
  72.   (n-akt (lst-sum (lst-mul (n-inp-lst neuron) input )) 4))
  73.  
  74. (define (lst-mul a b) ;multiply each element of list a with same element of list b
  75.   (map (lambda(x y)(* x y)) a b))
  76.  
  77. (define (lst-if a b) ;if one of the lists consists of only one element it returns true
  78.   (if (or (= (length a) 1) (= (length b) 1)) #t #f))
  79.  
  80. (define (l-proc l input) ;proceses a layer
  81.   (map (lambda(x)(n-proc x input)) (n-inp-lst l)))
  82.  
  83. (define (net-proc net input) ;proceses a network
  84.   (net-proc2 net (l-check input)))
  85.  
  86. (define (net-proc2 net input)
  87.         (let ( (l (l-proc (car net) input)) )
  88.           (if (= 1 (length net)) l
  89.                 (net-proc2 (cdr net) l))))
  90.  
  91. (define (net-proc-res net input) ;returns a list of results for each layer
  92.   (net-proc-res2 net (l-check input) '() ))
  93.  
  94. (define (net-proc-res2 net input res)
  95.         (let ( (l (l-proc (car net) input)) )
  96.           (let ( (res1 (lst-push-b l res)) )
  97.           (if (= 1 (length net)) res1
  98.                 (net-proc-res2 (cdr net) l res1)))))
  99.  
  100. (define (l-err out err wh) ;counts error for layer
  101.   (lst-mul out (l-err*wh err wh)))
  102.  
  103. (define (l-err*wh err wh) ;next l error * output wheights
  104.   (map (lambda(y)(lst-sum y)) (map (lambda(x)(lst-mul err x)) wh)))
  105.  
  106. (define (lst-2-mul a b) ;multiply 2 lists
  107.   (map (lambda(x y)(* x y)) a b))
  108.  
  109. (define (lst-lst-mul a b) ; miltiply list a with every list from b
  110.   (map (lambda(x)(lst-mul-x x a)) b))
  111.  
  112. (define (net-wh*err wh err) ;miltiply each wheight with error
  113.   (map (lambda(x y)(lst-lst-mul x y)) wh err))
  114.  
  115. (define (net-err+wh err wh) ;add error to wheghts
  116.   (map (lambda(x y)(l-err+wh x y)) err wh))
  117.  
  118. (define (lst-2-sum a b) ; adds to lists
  119.   (map (lambda(x y)(+ x y)) a b))
  120.  
  121. (define (l-err+wh err wh) ;adds error to wheight for layer
  122.   (map (lambda(x y)(lst-2-sum x y)) err wh))
  123.  
  124. (define (lst-put-num lst) ;ads number to each el. of list ex. (1 a)
  125.   (lst-zip (sequence 0 (- (length lst) 1) '() ) lst ))
  126.  
  127. (define (sequence from to res) ;creates sequency of numbers from to
  128.         (let ( (nr (append res (list from))))
  129.           (if (= from to) nr (sequence (+ from 1) to nr ) )))
  130.  
  131. (define (lst-order-max lst) ;sort el.
  132.   (hsort (lst-put-num lst)))
  133.  
  134. (define (lst-zip a b) ; zip 2 lists
  135.   (map (lambda(x y)(list x y)) a b))
  136.  
  137. (define (hsort lst) ;sorts
  138.   (if (empty? lst) '()
  139.   (append
  140.   (hsort (filter (lambda(x) (> (cadr x) (cadr (car lst)))) (cdr lst)))
  141.   (list (car lst))
  142.   (hsort (filter (lambda(x) (<= (cadr x) (cadr (car lst)))) (cdr lst))))))
  143.  
  144. (define (ssort lst) ;sort
  145.   (if (empty? lst) '()
  146.   (append
  147.   (ssort (filter (lambda(x) (> x (car lst))) (cdr lst)))
  148.   (list (car lst))
  149.   (ssort (filter (lambda(x) (<= x (car lst))) (cdr lst))))))
  150.  
  151. (define (net-study net lst spd) ;studys net for each example from the list smpl ((inp)(out))
  152.         (if (net-check-lst net lst) net
  153.           (net-study (net-study-lst net lst spd) lst spd)))
  154.  
  155. (define (net-proc-num net inp) ;process network and returns output number
  156.   (caar (lst-order-max (net-proc net inp))))
  157.  
  158. (define (net-check-lst net lst) ;parbauda sarakstu ar paraugiem
  159.   (lst-and (map (lambda(x)(net-check-smpl net x)) lst)))
  160.  
  161. (define (lst-and lst) ;accumulates list
  162.   (lst-and2 (car lst) (cdr lst)))
  163.  
  164. (define (lst-and2 a lst)
  165.   (if (empty? lst) a (lst-and2 (and a (car lst)) (cdr lst))))
  166.  
  167.  
  168. (define (net-check-smpl net x) ;checks one sample (input output)
  169.   (let ( (inp (car x))
  170.                  (out (cadr x)) )
  171.   (if (= (caar (lst-order-max out)) (net-proc-num net inp)) #t #f)))
  172.  
  173. (define (net-study-lst net lst spd) ; studies network for smaples from lst. Smpl (input output)
  174.   (let ( (x (net-study1 net (caar lst) (cadar lst) spd)) )
  175.   (if (= 1 (length lst)) x
  176.         (net-study-lst x (cdr lst) spd))))
  177.  
  178. (define (net-study1 net inp need spd)
  179.   (net-study2 net (l-check inp) need spd))
  180.  
  181. (define (net-study2 net inp need spd)
  182.   (let ( (x (net-study3 net inp need spd)))
  183.      (if (= (caar (lst-order-max need))(caar (lst-order-max (net-proc x inp))))
  184.            x
  185.            (net-study2 x inp need spd))))
  186.  
  187. (define (slice lst from to)
  188.   (let ( (lng (length lst)) )
  189.         (take (drop lst from) (+ (- lng from) to))))
  190.  
  191. (define (net-study3 net inp need spd)
  192.   (let ((err (net-spd*err spd (slice (net-err net inp need) 1 0)))
  193.                 (wh (net-inp-wh net))
  194.             (out (slice (net-proc-res-out net inp) 0 -1)))
  195.                 (net-mk-data (net-err+wh wh (map (lambda(x y)(lst-lst-mul x y)) out err)))))
  196.  
  197. (define (net-err2 out-lst err-lst wh-lst)
  198.    (let ( (err-lst1 (lst-push (l-err (car out-lst) (car err-lst) (car wh-lst)) err-lst)) )
  199.    (if (lst-if out-lst wh-lst) err-lst1 (net-err2 (cdr out-lst) err-lst1 (cdr wh-lst)))))
  200.  
  201. (define (net-err net inp need) ;networks error list for each neuron
  202.   (let ( (wh-lst (reverse (net-out-wh net)))
  203.                  (err-lst (list (net-out-err net inp need)))
  204.                  (out-lst (reverse (slice (net-proc-res-out net inp) 0 -1))))    
  205.                  (net-err2 out-lst err-lst wh-lst)))
  206.  
  207. (define (net-spd*err spd err) ;multiply error with speed
  208.   (map (lambda(x)(lst-mul-x spd x)) err))
  209.  
  210. (define (lst-mul-x s lst) ;multiply list with x
  211.   (map (lambda(x)(* s x)) lst))
  212.  
  213. (define (net-proc-res-out net inp) ;x*(1 - x) for each neuron output
  214.   (lst-push inp (map (lambda(x)(l-proc-res-out x)) (net-proc-res net inp))))
  215.  
  216. (define (l-proc-res-out lst)
  217.         (map (lambda(x)(* x (- 1 x))) lst))
  218.  
  219. (define (l-out-err need fact) ;error of otput layer
  220.   (map (lambda(x y)(n-out-err x y)) need fact))
  221.  
  222. (define (n-out-err need fact) ;error of output neuron
  223.   (* fact (- 1 fact)(- need fact)))
  224.  
  225. (define (net-out-err net inp need) ;networks error lists
  226.   (l-out-err need (net-proc net inp)))
  227.  
  228. (define (lst-print lst);prints list
  229.   (map (lambda(x)(and (newline)(display x))) lst)(newline))
  230.  
  231. (define (lst-print2 lst)
  232.   (map (lambda(x)(lst-print x)) lst)(newline))
  233.  
  234. (define (l-check lst) lst)
  235.  
  236. (define (transpose lst res)
  237.   (if (empty? (car lst)) res
  238.         (transpose (lst-cdr lst) (append res (lst-car lst)))))
  239.  
  240. (define (lst-cdr lst) ;cdr of all list elements
  241.   (map (lambda(x)(cdr x)) lst))
  242.  
  243. (define (lst-car lst) ;car of all list elements
  244.   (list (map (lambda(x)(car x)) lst)))
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!
 
Top