fork download
copy 
  1. ; your code goes here
  2. (in-package :cl-user)
  3. (defpackage :simulated-annealing
  4.   (:use :cl))
  5. (in-package :simulated-annealing)
  6.  
  7. (defclass solution ()
  8.   ((queens :initarg :queens :accessor solution-queens)
  9.    (energy :initarg :energy :initform 0 :accessor solution-energy)
  10.    (size :initarg :size :accessor solution-size)))
  11.  
  12. (defparameter default-size 5)
  13.  
  14. (defun make-solution (&optional (size default-size))
  15.   (loop
  16.      with solution = (make-instance 'solution
  17.                                     :size size
  18.                                     :queens (loop for i from 0 below size collect i))
  19.      repeat size
  20.      do (tweak-solution solution)
  21.      finally (return solution)))
  22.  
  23. (defun tweak-solution (solution)
  24.   (loop
  25.      with size = (solution-size solution)
  26.      with queens = (solution-queens solution)
  27.      with x = (random size)
  28.      for y = (random size)
  29.      while (= x y)
  30.      finally (rotatef (nth x queens)
  31.                       (nth y queens))))
  32.  
  33. (defun print-solution (solution &optional (stream *standard-output*))
  34.   (loop
  35.      with size = (solution-size solution)
  36.      for queen in (solution-queens solution)
  37.      do (loop for y from 0 below size
  38.            do (format stream "~a " (if (= y queen) "Q" ".")))
  39.        (terpri stream)))
  40.  
  41. (defun compute-energy (solution)
  42.   (flet ((make-board ()
  43.            (loop
  44.               with size = (solution-size solution)
  45.               with board = (make-array (list size size) :initial-element 0)
  46.               for x from 0 below size
  47.               for y in (solution-queens solution)
  48.               do (setf (aref board x y) 1)
  49.               finally (return board))))
  50.     (loop
  51.        with board = (make-board)
  52.        with size = (solution-size solution)
  53.        with conflicts = 0
  54.        with diags = '((-1 -1) (1 1) (-1 1) (1 -1))
  55.        for x from 0 below size
  56.        for y in (solution-queens solution)
  57.        do (loop for delta in diags
  58.              do (loop
  59.                    with tempx = x
  60.                    with tempy = y
  61.                    do
  62.                      (incf tempx (first delta))
  63.                      (incf tempy (second delta))
  64.                    until (or (< tempx 0)
  65.                              (< tempy 0)
  66.                              (>= tempx size)
  67.                              (>= tempy size))
  68.                    do (incf conflicts (aref board tempx tempy))))
  69.        finally (setf (slot-value solution 'energy) conflicts))))
  70.  
  71. (defun copy-solution (solution)
  72.   (let ((copy (make-instance 'solution :size (solution-size solution)) ))
  73.     (with-slots (queens energy) copy
  74.       (setf queens (copy-list (solution-queens solution)))
  75.       (setf energy (solution-energy solution)))
  76.     copy))
  77.  
  78.  
  79. (defun main ()
  80.   (let ((current (make-solution))
  81.         (working nil)
  82.         (best (make-instance 'solution :energy 100)))
  83.     (compute-energy current)
  84.     (setf working (copy-solution current))
  85.     (loop
  86.        with alpha = 0.99
  87.        with final-temperature = 0.5
  88.        with steps-per-change = 100
  89.        for temperature = 30.0 then (* temperature alpha)
  90.        while (> temperature final-temperature)
  91.        do
  92.          (loop for i from 0 below steps-per-change
  93.             with use-new = nil
  94.             do
  95.               (tweak-solution working)
  96.               (compute-energy working)
  97.               (if (<= (solution-energy working) (solution-energy best))
  98.                   (setf use-new t)
  99.                   (let ((test (random 1.0))
  100.                         (delta (- (solution-energy working)
  101.                                   (solution-energy current))))
  102.                     (when (> (exp (/ (- delta) temperature)) test)
  103.                       (setf use-new t))))
  104.               (if use-new
  105.                   (progn
  106.                     (setf use-new nil)
  107.                     (setf current (copy-solution working))
  108.                     (when (<  (solution-energy current)
  109.                               (solution-energy best))
  110.                       (setf best (copy-solution current))))
  111.                   (setf working (copy-solution current)))))
  112.     (print-solution best)))
  113.  
  114. (main)
  115.  
Success #stdin #stdout 3.98s 535040KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
. Q . . . 
. . . Q . 
Q . . . . 
. . Q . . 
. . . . Q
https://ideone.com/MTba5u
language:
Common Lisp (clisp 2.49.92)
created:
8 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!