Chrome dino-ai(in-progress)

dino.lisp

(defpackage #:dino-ai
  (:use #:common-lisp #:cl-autogui)
  (:export #:dino-jump
           #:dino-play))

(in-package #:dino-ai)

(defvar *f5-key* 71)
(defvar *space-key* 65)
(defvar *down-key* 116)
(defparameter *scan-interval* 1/60)

;; game over text position (position of 'G' and 'R')
(defvar *game-over-points* '((385 175) (480 220) (575 173)))
;; dino on the ground
(defvar *dino-stand-points* '((207 238) (242 223)))
;; dino get-down
(defvar *dino-down-points* '((209 240) (262 243)))
;; the block search squre (x y weight height)
(defvar *block-search-squre* '(265 220 500 35))
;; Position to click (focus the game)
(defvar *mouse-focus-point* '(190 150))
;; the y of middle flying bird
(defvar *middle-bird-y* 220)

(defun first-pixel->color (snap-data)
  (funcall
   #'(lambda (data) (mapcar
                #'(lambda (i) (aref data 0 0 i))
                '(0 1 2 3)))
   snap-data))

(defun points-exists? (points
                       &key color (test #'(lambda (a b) (not (equal a b)))))
  (let* ((all-points
          (if color
              points
              (push '(50 150) points)))
         (all-colors
          (apply #'x-getcolor all-points))
         (base-color (or color (pop all-colors)))
         (other-colors all-colors))
    (every #'identity (mapcar #'(lambda (c) (funcall test base-color c)) other-colors))))

(defun game-over? ()
  (points-exists? *game-over-points*))

(defun find-block ()
  "find properties of the first block in front of dino, (x y)"
  (let* ((x (first *block-search-squre*))
         (y (second *block-search-squre*))
         (w (third *block-search-squre*))
         (h (fourth *block-search-squre*))
         (snap-data (x-snapshot :x x :y y :width w :height h))
         (first-color (first-pixel->color snap-data)))
    (x-snapsearch first-color  :x x :y y :width w :height h
                  :test #'(lambda (a b) (not (equal a b)))
                  :snap-data snap-data)))

(defun dino-jump ()
  ;;(format t "Jump?~%")
  (let ((stand? (points-exists? *dino-stand-points*))
        (down? (points-exists? *dino-down-points*)))
    (if  (or stand? down?) ; only jump if dino is on the ground.
         (progn (x-key-up *down-key*)
                (x-press *space-key*)
                (sleep 0.1)); let the dino fly~
         ;;(format t "NO JUMP, tg: ~S stand:~S down:~S ~%" time-gap stand? down?)
         )))

(defun dino-down ()
  (when (points-exists? *dino-stand-points*) ; only get-down if dino is on the ground.
    (x-key-down *down-key*)))

(defparameter *distance-stack* nil)

(defun dino-restart ()
  ;; move to dino and click
  (setf *distance-stack* nil)
  (x-click :x (car *mouse-focus-point*) :y (cadr *mouse-focus-point*))
  (sleep 1)
  (x-press *f5-key*)
  (sleep 1)
  (x-press *space-key*)
  ;; move away, annoying mouse
  (x-move (- (car *mouse-focus-point*) 150) (cadr *mouse-focus-point*)))

(defun find-gap (predicate lst &key (test #'>))
  (if (or
       (null lst)
       (null (cdr lst))
       (not (funcall predicate (car lst)))
       (not (funcall predicate (cadr lst))))
      -1
      (if (funcall test (car lst) (cadr lst))
          1
          (1+ (find-gap predicate (cdr lst) :test test)))))

(defun chunk-list (predicate lst &key (test #'>))
  (labels ((rec (lst acc)
             (let* ((n (find-gap predicate lst :test test))
                    (rest (when (not (equal -1 n)) (nthcdr n lst))))
               (if (and (consp rest) (not (zerop n)))
                   (rec rest (cons (subseq lst 0 n) acc))
                   (nreverse (cons lst acc))))))
    (if lst (rec lst nil) nil)))

(defun map-a/b (fn lst)
  (if (cdr lst)
      (cons (funcall fn (car lst) (cadr lst))
            (when (cddr lst) (map-a/b fn (cdr lst))))
      nil))

;; (mapcar #'(lambda (dists) (round (/ (apply #'+ dists) (length dists)))) (chunk-list *distance-stack*))


(defun avg-speed ()
  "px per second"
  (when (< (length *distance-stack*) 2) (return-from avg-speed 1))
  ;; cut *distance-stack*, only save recent 100 values, for memory good.
  (when (> (length *distance-stack*) 1000)
    (setf *distance-stack* (subseq *distance-stack* 0 1000)))
  (let ((block-dist-group (chunk-list #'numberp *distance-stack*)))
    ;;(format t "Dist-Group-Sizes: ~S ~%" (mapcar #'length dist-group))
    (labels ((cal-avg (lst)
               (if (> (length lst) 0)
                   (/ (apply #'+ lst) (length lst))
                   0))
             (cal-speed (dist-list)
               (cal-avg (map-a/b
                         #'(lambda (a b) (/ (- b a) *scan-interval*))
                         dist-list))))
      (round
       (cal-avg
        (mapcar #'cal-speed block-dist-group))))))

(defun cal-jump-distance (&key (speed (avg-speed)))
  (format t "SPEED: ~S~%" speed)
  (round (* 90 (expt (/ speed 400) 1))))

(defun jump? (distance speed)
  (when (and (numberp distance) (numberp speed) (not (zerop speed)))
    (<= (/ distance speed) 0.1)))

(defun dino-play ()
  "Awesome! http://imgur.com/kjRnw5G"
  (dino-restart)
  (loop
     (when (game-over?) (return))
     (let* ((block-position (find-block))
            (block-distance (when block-position
                              (- (car block-position) (first *block-search-squre*))))
            (block-y (cadr block-position))
            (speed (avg-speed))
            (should-jump (jump? block-distance speed)))
       (when block-distance (push block-distance *distance-stack*))
       (format t "DS: ~S SJ: ~S SPD: ~S BY: ~S~%" block-distance should-jump speed block-y)
       (cond
         ((null block-position) nil)
         ((= 220 block-y) (dino-down))
         ((= block-distance 0) nil)
         (should-jump (dino-jump))))
     (sleep *scan-interval*)))