Skip to content
Snippets Groups Projects
Commit f4892b96 authored by Liam Healy's avatar Liam Healy
Browse files

Simulated annealing state functions, example

Created #'sa-state-value, #'make-sa-states, #'make-new-sa-state,
#'copy-sa-state and use them in the callbacks.  Argument match between
#'simulated-annealing and #'simulated-annealing-int.  Trivial example
ported but fails in assigning parameter values when run.
parent 788ec0b5
No related branches found
No related tags found
No related merge requests found
;; Simulated Annealing ;; Simulated Annealing
;; Liam Healy Sun Feb 11 2007 - 17:23 ;; Liam Healy Sun Feb 11 2007 - 17:23
;; Time-stamp: <2009-05-16 23:18:31EDT simulated-annealing.lisp> ;; Time-stamp: <2009-05-17 22:57:01EDT simulated-annealing.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -22,24 +22,52 @@ ...@@ -22,24 +22,52 @@
(t-min :double)) (t-min :double))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Callbacks ;;;; Simulated annealing states
;;;;**************************************************************************** ;;;;****************************************************************************
;;; A "state pointer" is in integer with a value of 0, 1, or 2. The ;;; States will be saved in an array of length 4, *sa-states*, a
;;; users functions must suitably define state and be prepared to keep ;;; local special. The "state pointer" is an index of type (integer 0 3).
;;; three instances. When they callbacks are called they will be
;;; directed to do certain operations on one (or two) of the three
;;; states.
(defun state-pointer (foreign-pointer) (defun state-pointer (foreign-pointer)
(cffi:pointer-address (cffi:mem-aref foreign-pointer :pointer))) (cffi:pointer-address (cffi:mem-aref foreign-pointer :pointer)))
(defun sa-state-value (foreign-pointer)
(declare (special *sa-states*))
(aref *sa-states* (state-pointer foreign-pointer)))
(defun make-sa-states (length)
(declare (special *sa-states*))
(setf *sa-states* (make-array length :adjustable t)))
(defun make-new-sa-state (&rest arguments)
"Make a new simulated annealing state.
Pass any arguments to user-state-maker-function."
(declare
(special user-state-maker-function sa-state-counter *sa-states*))
(prog1 (cffi:make-pointer sa-state-counter)
(when (>= sa-state-counter (length *sa-states*))
(adjust-array *sa-states* (1+ sa-state-counter)))
(setf (aref *sa-states* sa-state-counter)
(apply user-state-maker-function arguments))
(incf sa-state-counter)))
;;; The user-copy-function should take two states, and return nothing.
(defun copy-sa-state (source destination)
(declare (special user-copy-function))
(funcall user-copy-function
(sa-state-value source)
(sa-state-value destination)))
;;;;****************************************************************************
;;;; Callbacks
;;;;****************************************************************************
;;; The user-energy-function should take one state pointers, and ;;; The user-energy-function should take one state pointers, and
;;; return a double-float. ;;; return a double-float.
;;; typedef double (*gsl_siman_Efunc_t) (void *xp); ;;; typedef double (*gsl_siman_Efunc_t) (void *xp);
(cffi:defcallback sa-energy-function :double ((state :pointer)) (cffi:defcallback sa-energy-function :double ((state :pointer))
(declare (special user-energy-function)) (declare (special user-energy-function))
(funcall user-energy-function (state-pointer state))) (funcall user-energy-function (sa-state-value state)))
;;; The user-step-function should take a rng pointer, a state pointer, ;;; The user-step-function should take a rng pointer, a state pointer,
;;; and a double-float, and return nothing. The rng pointer should be ;;; and a double-float, and return nothing. The rng pointer should be
...@@ -48,38 +76,28 @@ ...@@ -48,38 +76,28 @@
(cffi:defcallback sa-step-function :void (cffi:defcallback sa-step-function :void
((rng :pointer) (state :pointer) (step-size :double)) ((rng :pointer) (state :pointer) (step-size :double))
(declare (special user-step-function)) (declare (special user-step-function))
(funcall user-step-function rng (state-pointer state) step-size)) (funcall user-step-function rng (sa-state-value state) step-size))
;;; typedef double (*gsl_siman_metric_t) (void *xp, void *yp); ;;; typedef double (*gsl_siman_metric_t) (void *xp, void *yp);
(cffi:defcallback sa-metric-function :double (cffi:defcallback sa-metric-function :double
((state1 :pointer) (state2 :pointer)) ((state1 :pointer) (state2 :pointer))
(declare (special user-metric-function)) (declare (special user-metric-function))
(funcall user-metric-function (state-pointer state1) (state-pointer state2))) (funcall user-metric-function (sa-state-value state1) (sa-state-value state2)))
;;; typedef void (*gsl_siman_print_t) (void *xp); ;;; typedef void (*gsl_siman_print_t) (void *xp);
(cffi:defcallback sa-print-function :void ((state :pointer)) (cffi:defcallback sa-print-function :void ((state :pointer))
(declare (special user-print-function)) (declare (special user-print-function))
(funcall user-print-function (state-pointer state))) (funcall user-print-function (sa-state-value state)))
;;; The user-copy-function should take two state pointers, and return nothing.
;;; typedef void (*gsl_siman_copy_t) (void *source, void *dest); ;;; typedef void (*gsl_siman_copy_t) (void *source, void *dest);
(cffi:defcallback sa-copy-function :void ((source :pointer) (destination :pointer)) (cffi:defcallback sa-copy-function :void ((source :pointer) (destination :pointer))
(declare (special user-copy-function)) (copy-sa-state source destination))
(funcall user-copy-function
(state-pointer source)
(state-pointer destination)))
;;; The copy constructor will be special. It will only be called
;;; three times in the run, and it will generate in succession the
;;; three pointer values. It should expect copy state from the
;;; supplied value.
;;; typedef void * (*gsl_siman_copy_construct_t) (void *xp); ;;; typedef void * (*gsl_siman_copy_construct_t) (void *xp);
(cffi:defcallback sa-copy-constructor-function :pointer ((state :pointer)) (cffi:defcallback sa-copy-constructor-function :pointer ((state :pointer))
(declare (special sa-state-counter user-maker-function)) (let ((new (make-new-sa-state)))
(prog1 (copy-sa-state state new)
(cffi:make-pointer sa-state-counter) new))
(make-)
(incf sa-state-counter)))
;;; Destructor? How quaint. Don't do anything. ;;; Destructor? How quaint. Don't do anything.
;;; typedef void (*gsl_siman_destroy_t) (void *xp); ;;; typedef void (*gsl_siman_destroy_t) (void *xp);
...@@ -91,47 +109,51 @@ ...@@ -91,47 +109,51 @@
;;;; New ;;;; New
;;;;**************************************************************************** ;;;;****************************************************************************
(export 'simulated-annealing)
(defun simulated-annealing (defun simulated-annealing
(parameters generator (state-values parameters
state-maker-function generator
energy-function step-function metric-function state-maker-function energy-function
print-function copy-function) step-function metric-function print-function copy-function)
(declare (special user-state-maker-function
user-energy-function user-step-function
user-metric-function user-print-function
user-copy-function sa-state-counter))
(let ((sa-state-counter 0) (let ((sa-state-counter 0)
(user-state-maker-function state-maker-function) (user-state-maker-function state-maker-function)
(user-energy-function energy-function) (user-energy-function energy-function)
(user-step-function step-function) (user-step-function step-function)
(user-metric-function metric-function) (user-metric-function metric-function)
(user-print-function print-function) (user-print-function print-function)
(user-copy-function copy-function) (user-copy-function copy-function))
(user-maker-function state-maker-function)) (declare (special
sa-state-counter
user-state-maker-function user-energy-function
user-step-function user-metric-function
user-print-function user-copy-function))
(make-sa-states 4)
(simulated-annealing-int (simulated-annealing-int
parameters generator parameters
x0-p generator
sa-energy-function (make-new-sa-state state-values) ; x0-p
sa-step-function 'sa-energy-function
sa-metric-function 'sa-step-function
sa-print-function))) 'sa-metric-function
'sa-print-function)))
(defmfun simulated-annealing-int (defmfun simulated-annealing-int
(parameters generator x0-p (parameters generator x0-p
energy-function step-function metric-function energy-function step-function metric-function
print-position) print-function)
"gsl_siman_solve" "gsl_siman_solve"
(((mpointer generator) :pointer) (x0-p :pointer) (((mpointer generator) :pointer) (x0-p :pointer)
((cffi:get-callback energy-function) :pointer) ((cffi:get-callback energy-function) :pointer)
((cffi:get-callback step-function) :pointer) ((cffi:get-callback step-function) :pointer)
((cffi:get-callback metric-function) :pointer) ((cffi:get-callback metric-function) :pointer)
((cffi:get-callback print-position) :pointer) ((cffi:get-callback print-function) :pointer)
((cffi:get-callback 'sa-copy-function) :pointer) ((cffi:get-callback 'sa-copy-function) :pointer)
((cffi:get-callback 'sa-copy-constructor-function) :pointer) ((cffi:get-callback 'sa-copy-constructor-function) :pointer)
((cffi:get-callback 'sa-destroy-function) :pointer) ((cffi:get-callback 'sa-destroy-function) :pointer)
(0 sizet) (0 sizet)
(parameters simulated-annealing-parameters)) (parameters simulated-annealing-parameters))
:c-return :void :c-return :void
:export nil
:documentation ; FDL :documentation ; FDL
"Perform a simulated annealing search through a given "Perform a simulated annealing search through a given
space. The space is specified by providing the functions energy-function and space. The space is specified by providing the functions energy-function and
...@@ -157,11 +179,11 @@ ...@@ -157,11 +179,11 @@
x0-p. If the annealing process has been successful this x0-p. If the annealing process has been successful this
should be a good approximation to the optimal point in the space. should be a good approximation to the optimal point in the space.
If the function pointer print-position is not null, a debugging If the function pointer print-function is not null, a debugging
log will be printed to standard output with the following columns: log will be printed to standard output with the following columns:
number_of_iterations temperature x x-x0p Ef(x) number_of_iterations temperature x x-x0p Ef(x)
and the output of the function print-position itself. If and the output of the function print-function itself. If
print-position is null then no information is printed. print-function is null then no information is printed.
The simulated annealing routines require several user-specified The simulated annealing routines require several user-specified
functions to define the configuration space and energy function.") functions to define the configuration space and energy function.")
...@@ -172,53 +194,30 @@ ...@@ -172,53 +194,30 @@
;;; Trivial example, Sec. 24.3.1 ;;; Trivial example, Sec. 24.3.1
;;; This does not work. ;;; This does not work.
(defun M2 (cx cy) (defun trivial-example-energy (state)
(with-c-double (cx x) (let ((x (aref state 0)))
(with-c-double (cy y) (* (exp (- (expt (1- x) 2))) (sin (* 8 x)))))
(abs (- x y)))))
(defvar *sa-function-calls*) (defun trivial-example-step (generator state step-size)
(let ((rand (uniform generator))
(x (aref state 0)))
(setf x (+ x (- (* 2 rand step-size) step-size)))))
(defun E2 (arg) (defun trivial-example-metric (state1 state2)
(with-c-double (arg x) (abs (- (aref state1 0) (aref state2 0))))
(incf *sa-function-calls*)
(when (> *sa-function-calls* 100)
(error "too much"))
(* (exp (- (expt (1- x) 2))) (sin (* 8 x)))))
(defun S2 (generator parameters step-size) (defun trivial-example-print (state)
(with-c-double (parameters x) (princ (aref state 0)))
;;(format t "~&~d ~d" x step-size)
(let ((step-size 10.0d0)) ; this is coming in wrong, so we fix it
(let ((rand (uniform generator)))
(setf x (+ x (- (* 2 rand step-size) step-size)))))))
(defparameter *sa-example-print* nil)
;;; Print functions are a problem because it is likely that the C
;;; stdout and the CL *standard-output* are not the same stream.
;;; Also, it seems to ignore that a function is supplied, and avoids
;;; printing anything.
(defun P2 (arg)
(with-c-double (arg x)
(when *sa-example-print*
(format T "~&from P2: ~a" x))))
(def-energy-function E2)
(def-distance-function M2)
(def-step-function S2)
(def-print-function P2)
(defun simulated-annealing-example () (defun simulated-annealing-example ()
(let ((*sa-function-calls* 0)) (simulated-annealing
(rng-environment-setup) (list 15.5d0)
(cffi:with-foreign-object (initial :double) (list 200 10 10.0d0 1.0d0 0.002d0 1.005d0 2.0d-6) ; parameters
(setf (dcref initial) 15.5d0) (make-random-number-generator +mt19937+ 0)
(with-simulated-annealing-parameters (lambda (initial)
(params 200 10 10.0d0 1.0d0 0.002d0 1.005d0 2.0d-6) (make-marray 'double-float :dimensions 1 :initial-contents initial))
(simulated-annealing 'trivial-example-energy
(make-random-number-generator +mt19937+ 0) initial 'trivial-example-step
'E2 'S2 'M2 'P2 'trivial-example-metric
(cffi:foreign-type-size :double) 'trivial-example-print
params))))) 'copy))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment