A1 (let
((this (new nearest-neighbours 3 euclidean-distance)))
(progn
(learn this (list 1 1) 1)
(learn this (list 1 2) 1)
(learn this (list 1 3) 2)
(learn this (list 2 1) 1)
(learn this (list 2 2) 2)
(learn this (list 2 3) 2)
(learn this (list 3 1) 2)
(learn this (list 3 2) 2)
(learn this (list 3 3) 3)
this)) | B1 (list 1 1) | C1 (estimate @a!1! @b1) | B2 (list 1.3 1.3) | D1 (classify @a!1! @b1) | C2 (estimate @a!1! @b2) | B3 (list 1.63 1.63) | D2 (classify @a!1! @b2) | C3 (estimate @a!1! @b3) | B4 (list 2.0 2.0) | D3 (classify @a!1! @b3) | C4 (estimate @a!1! @b4) | B5 (list 2.3 2.3) | D4 (classify @a!1! @b4) | C5 (estimate @a!1! @b5) | B6 (list 2.6 2.6) | D5 (classify @a!1! @b5) | C6 (estimate @a!1! @b6) | B7 (list 3 3) | D6 (classify @a!1! @b6) | C7 (estimate @a!1! @b7) | B8 (list 3.3 3.3) | D7 (classify @a!1! @b7) | C8 (estimate @a!1! @b8) | B9 (list 3.6 3.6) | D8 (classify @a!1! @b8) | C9 (estimate @a!1! @b9) | D9 (classify @a!1! @b9) | (defproc take (n l)
(if
(or (= n 0) (null? l))
nil
(cons (first l) (take (- n 1) (rest l)))))
(setq get-distance first)
(setq get-weight first)
(setq get-vector first)
(setq get-label second)
(defproc less-distance? (pair-1 pair-2)
(< (get-distance pair-1) (get-distance pair-2)))
(defproc greater-weight? (pair-1 pair-2)
(> (get-weight pair-1) (get-weight pair-2)))
(defproc less-label? (pair-1 pair-2)
(< (get-label pair-1) (get-label pair-2)))
(defproc zero-distance? (pair)
(= (get-distance pair) 0))
(defproc to-weighted-label (pair)
(/ (get-label pair) (get-distance pair)))
(defproc to-weight (pair)
(/ (get-distance pair)))
(defproc arithmetic-average (pair-list)
(aif
(find-if zero-distance? pair-list)
(get-label it)
(/
(apply + (map-with to-weighted-label pair-list))
(apply + (map-with to-weight pair-list)))))
(defproc sum-adjacent (pair-list)
(cond
((null? pair-list)
nil)
((single? pair-list)
pair-list)
((= (get-label (first pair-list)) (get-label (second pair-list)))
(sum-adjacent
(cons
(list
(+ (get-weight (first pair-list)) (get-weight (second pair-list)))
(get-label (first pair-list)))
(rest (rest pair-list)))))
(t
(cons
(first pair-list)
(sum-adjacent (rest pair-list))))))
(defproc group (pair-list)
(sum-adjacent
(sort pair-list less-label?)))
(defproc to-weight-pair (pair)
(list
(to-weight pair)
(get-label pair)))
(defproc majority (pair-list)
(second
(or
(find-if zero-distance? pair-list)
(first
(sort
(group
(map-with to-weight-pair pair-list))
greater-weight?)))))
(defclass nearest-neighbours nil)
(defmethod initialize ((this nearest-neighbours) neighbour-count measure)
(and
(integer? neighbour-count)
(> neighbour-count 0)
(= (type-of measure) (quote lambda)))
(progn
(.= this neighbour-count neighbour-count)
(.= this measure measure)
this))
(defmethod learn ((this nearest-neighbours) vector label)
(list? vector)
(with-slots (training-set vector-length) this
(if
training-set
(if
(= (length vector) vector-length)
(push (list vector label) training-set)
(throw (quote error) "vector has wrong number of elements"))
(progn
(setq training-set (list (list vector label)))
(setq vector-length (length vector))))))
(defmethod get-neighbours ((this nearest-neighbours) vector)
(list? vector)
(with-slots-read-only (training-set neighbour-count measure) this
(take
neighbour-count
(sort
(map-with
(lambda (pair) (list (measure vector (get-vector pair)) (get-label pair)))
training-set)
less-distance?))))
(defmethod estimate ((this nearest-neighbours) vector)
(list? vector)
(arithmetic-average (get-neighbours this vector)))
(defmethod classify ((this nearest-neighbours) vector)
(list? vector)
(majority (get-neighbours this vector)))
(defproc square (x) (* x x))
(defproc euclidean-distance (v w)
(apply +
(zip-with
(lambda (x1 x2) (square (- x1 x2)))
v
w)))
(defproc manhattan-distance (v w)
(apply +
(zip-with
(lambda (x1 x2) (abs (- x1 x2)))
v
w)))