Metaheuristic search procedures, a toy servlet for using the user as a comparison function, and some functions for rendering triangles into SVG

metaheuristic-web.rkt

#lang web-server

; Three things happened in somewhat rapid succession:
; 1. I was playing with stateless servlets
; 2. I came across a copy of Essentials of Metaheuristics on my drive
; 3. I remembered seeing some web pages which generated abstract art
;    for the user by having them choose which of a population they found
;    most asthetically pleasing.
;
; At that point, this seemed like a great idea.
; - jay kominek

(require web-server/servlet-env)

; makes a terminate? procedure that will stop the search after count iterations
(define (make-count-terminator count)
  (lambda (candidate state)
    (if (null? state)
        0
        (if (> state count)
            #f
            (add1 state)))))

; turn a total order expressed as less-than? into a procedure
; appropriate for choose-best. (in case you'd like the machine
; to do your comparing for you.)
(define (total-order->choose-best less-than?)
  (lambda (seq)
    (for/fold ([best (sequence-ref seq 0)])
      ([candidate (sequence-tail seq 1)])
      (if (less-than? candidate best)
          best
          candidate))))

; A few simple metaheuristic procedures
; see Essentials of Metaheuristics by Sean Luke
; http://cs.gmu.edu/~sean/book/metaheuristics/

(define (hill-climbing initial-candidate tweak-candidate choose-best terminate?)
  (let loop ([best initial-candidate]
             [termination-result (terminate? initial-candidate null)])
    (if (not termination-result)
        best
        (loop (choose-best (list best (tweak-candidate best)))
              (terminate? best termination-result)))))

(define (steepest-ascent-hill-climbing initial-candidate tweak-candidate choose-best copies terminate?)
  (let loop ([S initial-candidate]
             [termination-result (terminate? initial-candidate null)])
    (if (not termination-result)
        S
        (let ([candidate-pool (for/list ([x (in-range copies)]) (tweak-candidate S))])
          (loop (choose-best (cons S candidate-pool))
                (terminate? S termination-result))))))

; has a builtin termination when t ≤ 0
(define (simulated-annealing initial-candidate tweak-candidate choose-best initial-t t-decrement)
  (define best initial-candidate)
  (let loop ([S initial-candidate]
             [best initial-candidate]
             [t initial-t])
    (if (<= t 0)
        best
        (let* ([R (tweak-candidate S)]
               [new-S (if (< (random) (exp (/ t)))
                          R
                          (choose-best (list S R)))])
          (loop new-S
                (if (equal? best new-S)
                    best
                    (choose-best (list best new-S)))
                (- t t-decrement))))))



;;; some stuff for svg images made of random triangles

; colors are 3 elt vectors
(define (random-color)
  (vector (random) (random) (random)))
; triangles are 4 elt lists, first elt is a color, remaining are 2 elt vectors
(define (random-triangle)
  (cons (random-color)
        (list (vector (random) (random))
              (vector (random) (random))
              (vector (random) (random)))))
(define (random-triangle-list)
  (for/list ([x (in-range 3 (+ 4 (random 10)))])
    (random-triangle)))

(define (triangle->svg-polygon triangle)
  `(polygon ([points ,(string-join (map (lambda (p) (format "~a,~a" (vector-ref p 0) (vector-ref p 1)))
                                        (cdr triangle))
                                   " ")]
             [style ,(let ([color (car triangle)])
                       (format "fill:rgb(~a,~a,~a);fill-opacity:0.25;stroke-width:0"
                               (inexact->exact (round (* 255 (vector-ref color 0))))
                               (inexact->exact (round (* 255 (vector-ref color 1))))
                               (inexact->exact (round (* 255 (vector-ref color 2))))))])))

(define (triangle-list->svg triangle-list)
  `(svg ([xmlns "http://www.w3.org/2000/svg"]
         [version "1.1"]
         [height "128px"] [width "128px"]
         [viewBox "0 0 1 1"])
        ,@(map triangle->svg-polygon triangle-list)))

; just smoosh the values around while keeping them clipped to [0.0,1.0]
(define (tweak-vector vec)
  (vector-map (lambda (v) (min 1.0 (max 0.0 (+ v (/ (- (random) 0.5) 3.333))))) vec))
(define (tweak-triangle t)
  (map tweak-vector t))
(define (tweak-triangle-list t-list)
  (if (< (random) 0.25)
      (if (> (random) 0.5)
          (cons (random-triangle)
                (map tweak-triangle t-list))
          (let ([victim (random (length t-list))])
            (append (take t-list victim) (drop t-list (add1 victim)))))
      (map tweak-triangle t-list)))
  

; given a procedure which renders the values under consideration as xexpr,
; determines the best option out of a sequence by asking a user.
(define (web-picker thing->xexpr)
  (lambda (seq)
    (send/suspend/dispatch
     (lambda (embed-url)
       (response/xexpr
        `(html
          (body (h2 "Pick the best one")
                (ul
                 ,@(for/list ([n seq])
                     `(li (a ([href ,(embed-url (lambda (req) n))])
                             ,(thing->xexpr n))))))))))))



; servlet which sets up the search
(define (start req)
  (response/xexpr
   `(html (body "The best image is: "
                ,(triangle-list->svg
                  (steepest-ascent-hill-climbing (random-triangle-list) 
                                                 tweak-triangle-list
                                                 (web-picker triangle-list->svg)
                                                 5
                                                 (make-count-terminator 100)))))))

(serve/servlet start #:stateless? #t)