From 2e40d74ece6b33ea48202d7b3e14fe95521cd5ee Mon Sep 17 00:00:00 2001 From: Liam Healy <liam@thinkpad.local> Date: Thu, 7 May 2009 23:06:55 -0400 Subject: [PATCH] RNG printing, don't assume :slug in defmcallback, simulated annealing Print random number generator instances with type. Don't assume that :slug is in the argument list of a defmcallback; make declare ignore form only if it's there. Update docstring for +taus2+. Continued development of the simulated annealing renovation. --- init/callback.lisp | 5 +- random/generators.lisp | 6 +- random/rng-types.lisp | 4 +- simulated-annealing.lisp | 116 ++++++++++++++++++++++++++++++--------- 4 files changed, 99 insertions(+), 32 deletions(-) diff --git a/init/callback.lisp b/init/callback.lisp index 7de3a841..3a4ab042 100644 --- a/init/callback.lisp +++ b/init/callback.lisp @@ -1,6 +1,6 @@ ;; Foreign callback functions. ;; Liam Healy -;; Time-stamp: <2009-04-04 22:44:06EDT callback.lisp> +;; Time-stamp: <2009-05-04 21:44:08EDT callback.lisp> ;; $Id$ (in-package :gsl) @@ -219,5 +219,6 @@ (,@(substitute `(,slug :pointer) :slug args)) ;; Parameters as C argument are always ignored, because we have ;; CL specials to do the same job. - (declare (ignore ,slug) (special ,dynamic-variable)) + (declare ,@(when (member :slug args) `((ignore ,slug))) + (special ,dynamic-variable)) (funcall ,dynamic-variable ,@(mapcar 'st-symbol (remove :slug args)))))) diff --git a/random/generators.lisp b/random/generators.lisp index 6343edd7..74cd95ac 100644 --- a/random/generators.lisp +++ b/random/generators.lisp @@ -1,6 +1,6 @@ ;; Generators of random numbers. ;; Liam Healy, Sat Jul 15 2006 - 14:43 -;; Time-stamp: <2009-02-21 17:23:26EST generators.lisp> +;; Time-stamp: <2009-05-07 22:42:30EDT generators.lisp> ;; $Id$ (in-package :gsl) @@ -29,6 +29,10 @@ :initialize-suffix ("set" :void) :initialize-args ((value :ulong))) +(defmethod print-object ((object random-number-generator) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "of type ~a" (name object)))) + ;;;;**************************************************************************** ;;;; Seed ;;;;**************************************************************************** diff --git a/random/rng-types.lisp b/random/rng-types.lisp index ec1f2abc..0bb816b7 100644 --- a/random/rng-types.lisp +++ b/random/rng-types.lisp @@ -1,6 +1,6 @@ ;; Random number generation ;; Liam Healy, Tue Jul 11 2006 - 23:39 -;; Time-stamp: <2009-02-16 18:49:40EST rng-types.lisp> +;; Time-stamp: <2009-05-07 22:28:16EDT rng-types.lisp> ;; $Id$ ;;; Random number generator types and information functions. @@ -240,7 +240,7 @@ described in the paper, P. L'Ecuyer, ``Tables of Maximally Equidistributed Combined LFSR Generators'', Mathematics of Computation, 68, 225 (1999), 261--269 - The generator *taus2* should now be used in preference to *taus*.") + The generator +taus2+ should now be used in preference to +taus+.") (def-rng-type +taus113+) diff --git a/simulated-annealing.lisp b/simulated-annealing.lisp index bf7a932c..acd7043b 100644 --- a/simulated-annealing.lisp +++ b/simulated-annealing.lisp @@ -1,10 +1,12 @@ ;; Simulated Annealing ;; Liam Healy Sun Feb 11 2007 - 17:23 -;; Time-stamp: <2009-05-03 18:47:17EDT simulated-annealing.lisp> +;; Time-stamp: <2009-05-07 23:01:05EDT simulated-annealing.lisp> ;; $Id$ (in-package :gsl) +;;; /usr/include/gsl/gsl_siman.h + ;;; This does not work. ;;; Step size passed to the step function is incorrect. ;;; Print function is ignored, but probably couldn't work if it weren't. @@ -50,6 +52,91 @@ ,t-min) ,@body)) +(defmacro def-energy-function (name) + "Define an energy or distance fuction for simulated annealing." + `(def-single-function ,name :double :pointer nil)) + +(defmacro def-step-function (name) + "Define a step fuction for simulated annealing." + (let ((generator (gensym "GEN")) + (arguments (gensym "ARGS")) + (step-size (gensym "SS"))) + `(cffi:defcallback ,name :void + ((,generator :pointer) (,arguments :pointer) (,step-size :double)) + (,name ,generator ,arguments ,step-size)))) + +(defmacro def-distance-function (name) + "Define a metric distance fuction for simulated annealing." + (let ((x (gensym "X")) + (y (gensym "Y"))) + `(cffi:defcallback ,name :double + ((,x :pointer) (,y :pointer)) + (,name ,x ,y)))) + +(defmacro def-print-function (name) + "Define a print function for simulated annealing." + `(def-single-function ,name :int :pointer nil)) + +;;;;**************************************************************************** +;;;; Callbacks +;;;;**************************************************************************** + +;;; A "state pointer" is in integer with a value of 0, 1, or 2. The +;;; users functions must suitably define state and be prepared to keep +;;; 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) + (cffi:pointer-address (cffi:mem-aref foreign-pointer :pointer))) + +;;; The user-energy-function should take one state pointers, and +;;; return a double-float. +;;; typedef double (*gsl_siman_Efunc_t) (void *xp); +(cffi:defcallback sa-energy-function :double ((state :pointer)) + (declare (special user-energy-function)) + (funcall user-energy-function (state-pointer state))) + +;;; The user-step-function should take a rng pointer, a state pointer, +;;; and a double-float, and return nothing. The rng pointer should be +;;; used in call to one of the distribution functions like #'uniform. +;;; typedef void (*gsl_siman_step_t) (const gsl_rng *r, void *xp, double step_size); +(cffi:defcallback sa-step-function :void + ((rng :pointer) (state :pointer) (step-size :double)) + (declare (special user-step-function)) + (funcall user-step-function rng (state-pointer state) step-size)) + +;;; typedef double (*gsl_siman_metric_t) (void *xp, void *yp); +;;; typedef void (*gsl_siman_print_t) (void *xp); + +;;; The user-copy-function should take two state pointers, and return nothing. +;;; typedef void (*gsl_siman_copy_t) (void *source, void *dest); +(cffi:defcallback sa-copy-function :void ((source :pointer) (destination :pointer)) + (declare (special user-copy-function)) + (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. +(cffi:defcallback sa-copy-constructor-function :pointer ((state :pointer)) + ) + + +;;; typedef void * (*gsl_siman_copy_construct_t) (void *xp); + +#| +typedef void (*gsl_siman_destroy_t) (void *xp); +|# + + + +;;;;**************************************************************************** +;;;; New +;;;;**************************************************************************** + (defmfun simulated-annealing (generator x0-p Ef take-step distance-function @@ -58,7 +145,7 @@ element-size parameters) "gsl_siman_solve" (((mpointer generator) :pointer) (x0-p :pointer) - ((cffi:get-callback Ef) :pointer) + ((cffi:get-callback simulated-annealing-energy) :pointer) ((cffi:get-callback take-step) :pointer) ((cffi:get-callback distance-function) :pointer) ((cffi:get-callback print-position) :pointer) @@ -103,31 +190,6 @@ The simulated annealing routines require several user-specified functions to define the configuration space and energy function.") -(defmacro def-energy-function (name) - "Define an energy or distance fuction for simulated annealing." - `(def-single-function ,name :double :pointer nil)) - -(defmacro def-step-function (name) - "Define a step fuction for simulated annealing." - (let ((generator (gensym "GEN")) - (arguments (gensym "ARGS")) - (step-size (gensym "SS"))) - `(cffi:defcallback ,name :void - ((,generator :pointer) (,arguments :pointer) (,step-size :double)) - (,name ,generator ,arguments ,step-size)))) - -(defmacro def-distance-function (name) - "Define a metric distance fuction for simulated annealing." - (let ((x (gensym "X")) - (y (gensym "Y"))) - `(cffi:defcallback ,name :double - ((,x :pointer) (,y :pointer)) - (,name ,x ,y)))) - -(defmacro def-print-function (name) - "Define a print function for simulated annealing." - `(def-single-function ,name :int :pointer nil)) - ;;;;**************************************************************************** ;;;; Example ;;;;**************************************************************************** -- GitLab