W dniu środa, 26 września 2012 12:53:27 UTC+2 użytkownik Piotr Chamera napisał:
> Po przeczytaniu, co napisali przedpiścy, spróbowałem napisać
> proste rozwiązanie iteracyjne (w Common Lispie).
> W założeniu zaczynam z wektorem x na wierzchołku hiperkostki
> jednostkowej i poruszam się w jej wnętrzu po płaszczyźnie
> wyznaczonej przez jej narożniki ruchami w kierunku tego wierzchołka
> kostki, który daje aktualnie największy gradient funkcji celu.
> Kiedy nie ma już możliwości ruchu zmniejszam krok o połowę
> (a la szukanie binarne). To chyba powinno działać? - możecie
> zweryfikować czy się gdzieś nie machnąłem?

Moja poprzednia metoda daje takie wyniki:
https://rapidshare.com/files/330997453/dane.html
Warunek stopu to 500tys iteracji bez poprawy rozwiazania.
Czas to okolo 0.05s na i3. Dokladnosc obliczen jak widac :)
Mozna porownac czy podobne sa wyniki.
Pozdrawiam




>
>
>
> Znaczące są funkcje "move" i "maxff" reszta jest analogiczna jak
>
> w zadaniu w C++.
>
>
>
> Szybkościowo mieści się w założonym 0,03 s nawet w nieoptymalizowanym
>
> lispie chociaż robi dużo nadmiarowych obliczeń :) - pytanie tylko czy
>
> jest poprawne?
>
>
>
>
>
>
>
> (defconstant +N+ 3)
>
> (defconstant +M+ 8)
>
>
>
> ;;;; pomocnicze działania na wektorach
>
>
>
> (defun add (va vb) ; suma
>
> (let ((vr (make-array +M+ :element-type 'float)))
>
> (dotimes (i +M+)
>
> (setf (aref vr i) (+ (aref va i) (aref vb i))))
>
> vr))
>
>
>
> (defun sub (va vb) ; różnica
>
> (let ((vr (make-array +M+ :element-type 'float)))
>
> (dotimes (i +M+)
>
> (setf (aref vr i) (- (aref va i) (aref vb i))))
>
> vr))
>
>
>
> (defun smul (va s) ; mnożenie ze skalarem
>
> (let ((vr (make-array +M+ :element-type 'float)))
>
> (dotimes (i +M+)
>
> (setf (aref vr i) (* (aref va i) s)))
>
> vr))
>
>
>
> (defun check-in-1-box (vx) ; sprawdzenie czy wektor mieści się kostce
>
> (every (lambda (x) (and (<= x 1.0)
>
> (>= x 0)))
>
> vx))
>
>
>
> ;;;; inicjalizacje parametrów zadania
>
>
>
> (defun frand ()
>
> (random 1.0))
>
>
>
>
>
> (defun initP ()
>
> "Utwóż wektor losowych p takich, że p >=1 i p <= 5"
>
> (let ((p (make-array +M+ :element-type 'float)))
>
> (dotimes (i +M+)
>
> (setf (aref p i) (+ 1.0 (* (frand) 5.0))))
>
> p))
>
>
>
> (defun initZ (vp)
>
> "Utwóż losową tablicę współczynników dla funkcji f na podstawie vp"
>
> (let ((mz (make-array +N+)))
>
> (dotimes (i +N+)
>
> (let ((mzi (make-array +M+ :element-type 'float)))
>
> (dotimes (j +M+)
>
> (setf (aref mzi j) (ecase (random 3)
>
> (0 0)
>
> (1 1)
>
> (2 (aref vp j)))))
>
> (setf (aref mz i) mzi)))
>
> mz))
>
>
>
> (defun initX (&optional (vx nil))
>
> "Utwórz wektor losowych x takich, że x >= 0 i sum(x) = 1"
>
> (when (null vx)
>
> (setf vx (make-array +M+ :element-type 'float)))
>
> (dotimes (i +M+)
>
> (setf (aref vx i) (random 1.0)))
>
> (let ((sum (reduce #'+ vx)))
>
> (dotimes (i +M+)
>
> (setf (aref vx i) (/ (aref vx i) sum))))
>
> vx)
>
>
>
>
>
> (defun initDir ()
>
> "Utwórz zbiór narożników hiperkostki"
>
> (let ((dir (make-array +M+)))
>
> (dotimes (i +M+)
>
> (let ((vdir (make-array +M+ :element-type 'float :initial-element
>
> 0.0)))
>
> (setf (aref vdir i) 1.0)
>
> (setf (aref dir i) vdir)))
>
> dir))
>
>
>
>
>
> (defun asert (vx)
>
> "Sprawdz czy vx spełnia warunki x >= 0 i sum(x) = 1"
>
> (when (some (lambda (x) (< x 0))
>
> vx)
>
> (error "x mniejsze od zera"))
>
> (when (> (abs (- 1.0 (reduce #'+ vx)))
>
> 0.00001)
>
> (error "błąd sumy x większy od 0.00001"))
>
> t)
>
>
>
> ;;;; zadanie
>
>
>
> (defun f (z x &aux (sum 0.0))
>
> (dotimes (i +M+)
>
> (setf sum (+ sum
>
> (* (aref z i) (aref x i)))))
>
> sum)
>
>
>
>
>
> (defun ff (mz x)
>
> (asert x)
>
> (let ((min nil))
>
> (dotimes (i +N+)
>
> (let ((tmp (f (aref mz i) x)))
>
> (when (or (null min)
>
> (> min tmp))
>
> (setf min tmp))))
>
> min))
>
>
>
> ;;;; rozwiązanie
>
>
>
> (defun move (mz vx step dir)
>
> (let ((max (ff mz vx))
>
> (max-vx vx))
>
> (dolist (s (list step (- step))) ; sprawdz ruchy w obu kierunkach
>
> (dotimes (i +M+) ; po wszystkich osiach układu
>
> współrzędnych
>
> (let ((v (add vx (smul (sub (aref dir i) vx) s)))) ; idziemy po linii
>
> vx - dir o współczynnik s
>
> (when (check-in-1-box v)
>
> (let ((p-max (ff mz v)))
>
> (when (> p-max max) ; zapisz najlepszy znaleziony ruch
>
> (setf max p-max
>
> max-vx v)))))))
>
> (values max-vx max)))
>
>
>
> (defun maxff (mz)
>
> (let* ((vx (let ((v (make-array +M+ :element-type 'float
>
> :initial-element 0.0)))
>
> (setf (aref v 0) 1.0)
>
> v)) ; początkowy x i aktualizowny na bieżąco najlepszy
>
> (max 0.0) ; początkowe maksimum i aktualizowne na bieżąco najlepsze
>
> (dir (initDir)) ; tablica wierzchołków kostki (wektory typu [1 0 0 ... 0])
>
> (step 0.5) ; aktualny krok modyfikacji
>
> (epsilon 0.00001)) ; żądana dokładność maksimum
>
> (do () ((< step epsilon) ())
>
> (multiple-value-bind (p-vx p-max) (move mz vx step dir)
>
> (if (> (- p-max max) epsilon)
>
> (setf max p-max
>
> vx p-vx)
>
> (setf step (/ step 2.0)))))
>
> (values vx max)))
>
>
>
>
>
>
>
> ; // TODO: zmaksymalizować funkcję ff( z , x ) zmiejąc x (nie zmieniając z)
>
>
>
> Można tego użyć np tak: (maxff (initZ (initP)))