ICFPC 2014 の Lambda man の AI

icfpc-2014-lambda-man-ai.scm

(define rnd 123456)

(define (flatten xs)
  (if (null? xs)
      ()
      (append (car xs) (flatten (cdr xs)))))

(define (field-ref field w y x)
  (vector-ref field (+ (* y w) x)))
(define (field-set field w y x value)
  (vector-set field (+ (* y w) x) value))
(define (wall? field w y x)
  (= (field-ref field w y x) map-wall))

(define (filter-neighbors y x path pred)
  (filter pred
          (list (cons (cons (- y 1) x) (cons direction-up path))
                (cons (cons y (- x 1)) (cons direction-left path))
                (cons (cons (+ y 1) x) (cons direction-down path))
                (cons (cons y (+ x 1)) (cons direction-right path)))))

(define (bfs-step field h w queue rest-steps goal? rest-results results) ; => [[Direction]]
  (define (push-next-states new-queue y x path)
    (fold queue-push new-queue
          (filter-neighbors y x path
                            (lambda (state) (not (wall? field w (caar state) (cdar state)))))))
  (if (or (<= rest-steps 0) (<= rest-results 0) (queue-empty? queue))
      (reverse (map reverse results))
      (let* ([state-and-queue (queue-pop queue)]
             [state (car state-and-queue)]
             [y (caar state)]
             [x (cdar state)]
             [path (cdr state)]
             [new-queue (cdr state-and-queue)])
        (if (wall? field w y x)  ; visited?
            (bfs-step field h w new-queue rest-steps goal? rest-results results)  ; continue
            (let ([new-field (field-set field w y x map-wall)]) ; update visited
              (if (goal? field y x)
                  (bfs-step new-field h w new-queue (- rest-steps 1) goal? (- rest-results 1) (cons path results))
                  (bfs-step new-field h w (push-next-states new-queue y x path) (- rest-steps 1) goal? rest-results results)))))))

(define (pill-score dir pill-paths)
  (let ([first-path (find (lambda (path) (= (car path) dir)) pill-paths)])
    (if (null? first-path)
        0
        (+ 1 (div 1000 (+ 1 (length first-path)))))))

(define (ghost-score dir ghost-paths lambda-man)
  (let ([first-path (find (lambda (path) (= (car path) dir)) ghost-paths)])
    (if (null? first-path)
        0
        (let ([base-score (* (+ 1 (div 1000000 (+ 1 (length first-path)))))]
              [vitality (get-lambda-man-vitality lambda-man)])
           (if (> vitality 300)
               (div base-score 100)
               (* base-score -1))))))

(define wall-penalty -300000)

(define (wall-score dir field w y x)
  (if (= dir direction-up)
      (if (wall? field w (- y 1) x) wall-penalty 0)
      (if (= dir direction-right)
          (if (wall? field w y (+ x 1)) wall-penalty 0)
          (if (= dir direction-down)
              (if (wall? field w (+ y 1) x) wall-penalty 0)
              (if (wall? field w y (- x 1)) wall-penalty 0)))))

(define (fruit-score dir fruit-paths)
  (if (any (lambda (path) (and (not (null? path)) (= (car path) dir))) fruit-paths) 3000 0))

(define (power-pill-score dir power-pill-paths)
  (let ([first-path (find (lambda (path) (= (car path) dir)) power-pill-paths)])
    (if (null? first-path)
        0
        (* (+ 1 (div 900000 (+ 1 (length first-path))))))))

(define (direction-scores dir pill-paths ghost-paths fruit-paths power-pill-paths lambda-man field w y x)
  (+ (pill-score dir pill-paths)
     (ghost-score dir ghost-paths lambda-man)
     (fruit-score dir fruit-paths)
     (power-pill-score dir power-pill-paths)
     (wall-score dir field w y x)))

(define (calculate-scores pill-paths ghost-paths fruit-paths power-pill-paths lambda-man field w y x)
  (map (lambda (dir) (direction-scores dir pill-paths ghost-paths fruit-paths power-pill-paths lambda-man field w y x)) direction-list))

(define (find-indices value xs)
  (define (iter xs index result)
    (if (null? xs)
        result
        (iter (cdr xs) (+ index 1)
          (if (= (car xs) value) (cons index result) result))))
  (iter xs 0 ()))

(define (calculate-next-direction field h w y x lambda-man ghosts fruit-status)
  (set! rnd (remainder (* 48271 rnd) 2147483647))
  (let* ([initial-state (cons (cons y x) ())]
         [ghost-find-steps (if (> (get-lambda-man-vitality lambda-man) 300) 64 32)]
         [pill-find-steps (if (> fruit-status 0) 100 600)]
         [fruit-find-steps (if (> fruit-status 0) 500 0)]
         [power-pill-find-steps 8]
         [queue (queue-push (make-queue) initial-state)]
         [goal? (lambda (field y x)
                  (let ([cell (field-ref field w y x)])
                    (or (= cell map-pill) (= cell map-power-pill))))]
         [power-pill? (lambda (field y x) (= (field-ref field w y x) map-power-pill))]
         [pill-paths (bfs-step field h w queue pill-find-steps goal? 10 ())]
         [power-pill-paths (bfs-step field h w queue power-pill-find-steps power-pill? 1 ())]
         [visible-ghosts (filter (lambda (g) (not (= (get-ghost-vitality g) ghost-vitality-invisible))) ghosts)]
         [ghost-locations (map get-ghost-location visible-ghosts)]
         [ghost? (lambda (field y x) (any (lambda (g) (and (= y (cdr g)) (= x (car g)))) ghost-locations))]
         [ghost-paths (bfs-step field h w queue ghost-find-steps ghost? 10 ())]
         [fruit? (lambda (field y x) (and (= y fruit-y) (= x fruit-x)))]
         [fruit-paths (bfs-step field h w queue fruit-find-steps fruit? 1 ())]
         [scores (calculate-scores pill-paths ghost-paths fruit-paths power-pill-paths lambda-man field w y x)]
         [max-score (fold max -10000000 scores)]
         [best-directions (find-indices max-score scores)])
    (if (null? best-directions)
        (remainder (div rnd 65536) 4) ; random direction
        (car best-directions))))

(define (step ai-state world-state) ; => (ai-state . direction)
  (let* ([current-map (get-current-map world-state)]
         [h (length current-map)]
         [w (length (car current-map))]
         [lambda-man (get-lambda-man-status world-state)]
         [location (get-lambda-man-location lambda-man)]
         [y (position-y location)]
         [x (position-x location)]
         [field (vector-set (car ai-state) (+ (* y w) x) map-empty)]
         [ghosts (get-all-ghosts-status world-state)]
         [fruit-status (get-fruit-status world-state)]
         [next-direction (calculate-next-direction field h w y x lambda-man ghosts fruit-status)])
    (cons (list field) next-direction)))

(define initial-map (get-current-map $1))
(define initial-field (list->vector (flatten initial-map)))
(define initial-ai-state (list initial-field))

(define (find-fruit-position current-map)
  (define (iter-row row x)
    (if (null? row)
        -1
        (if (= (car row) map-fruit)
            x
            (iter-row (cdr row) (+ x 1)))))
  (define (iter rows y)
    (if (null? rows)
        (cons 0 0) ;; fruit not found ;-p
        (let ((x (iter-row (car rows) 0)))
          (if (>= x 0)
              (cons y x)
              (iter (cdr rows) (+ y 1))))))
  (iter current-map 0))

(define fruit-position (find-fruit-position initial-map))
(define fruit-y (car fruit-position))
(define fruit-x (cdr fruit-position))

(cons initial-ai-state step)