robot/commands.lisp

;;;; commands.lisp

(in-package #:robot-impl)

(defparameter *motion-delay* 0.5)

(defmacro defcommand (name &body body)
  (let ((docstring nil)
        (true-body body)
        (maybe-docstring (first body)))
    (when (stringp maybe-docstring)
      (setf docstring maybe-docstring
            true-body (rest body)))
    `(defun ,name ()
       ,docstring
       (unless *robot-app-running-p*
         (error "Робот не запущен."))
       (let ((*wish* (robot-app-wish *app*)))
         ,@true-body))))

(defmacro defmotion (name position docstring)
  `(defcommand ,name
     ,docstring
     (let ((world (robot-app-world *app*)))
       (when (robot-active-p (robot world))
         (set-robot-data "" (robot-app-component :temperature *app*))
         (set-robot-data "" (robot-app-component :radiation *app*))
         (sleep *motion-delay*)
         (destructuring-bind (x y) (robot-position world)
           (destructuring-bind (new-x new-y) (list ,@position)
             (if (or (loop for (x-wall y-wall) in (landscape-hwalls (landscape world))
                           thereis (and (< (min y new-y) y-wall)
                                        (>= (max y new-y) y-wall)
                                        (= x-wall x)))
                     (loop for (x-wall y-wall) in (landscape-vwalls (landscape world))
                           thereis (and (< (min x new-x) x-wall)
                                        (>= (max x new-x) x-wall)
                                        (= y-wall y))))
                 (setf (robot-active-p (robot world)) nil)
                 (when (and (<= 0 new-x (1- (landscape-width (landscape world))))
                            (<= 0 new-y (1- (landscape-height (landscape world)))))
                   (setf (robot-position world) (list ,@position)))))))
       (robot-app-update-map *app*)
       (if (robot-active-p (robot world))
           t
           nil))))

(defmotion up (x (1- y)) "Идти на одну клетку вверх.")
(defmotion down (x (1+ y)) "Идти на одну клетку вниз.")
(defmotion left ((1- x) y) "Идти на одну клетку влево.")
(defmotion right ((1+ x) y) "Идти на одну клетку вправо.")

(defcommand paint
  "Закрасить клетку."
  (let ((world (robot-app-world *app*)))
    (when (robot-active-p (robot world))
      (sleep *motion-delay*)
      (pushnew (robot-position world) (painted-cells world) :test #'equal)
      (robot-app-update-map *app*)
      t)))

(defun show-reply (reply app)
  (let ((*wish* (robot-app-wish *app*)))
    (set-robot-led-mode :off (robot-app-component :yes-led app))
    (set-robot-led-mode :off (robot-app-component :no-led app))
    (sleep *motion-delay*)
    (set-robot-led-mode :on (robot-app-component (if reply :yes-led :no-led) app)))
  reply)

(defun %wall-up-p (world)
  (member (robot-position world)
          (landscape-hwalls (landscape world))
          :test #'equal))

(defun %wall-left-p (world)
  (member (robot-position world)
          (landscape-vwalls (landscape world))
          :test #'equal))

(defun %wall-down-p (world)
  (destructuring-bind (x y) (robot-position world)
    (member (list x (1+ y))
            (landscape-hwalls (landscape world))
            :test #'equal)))

(defun %wall-right-p (world)
  (destructuring-bind (x y) (robot-position world)
    (member (list (1+ x) y)
            (landscape-vwalls (landscape world))
            :test #'equal)))

(defun %cell-painted-p (world)
  (member (robot-position world) (painted-cells world)))

(defmacro deftemplike (name name1 component default docstring)
  `(progn
     (defun ,name1 (world)
       (let ((map (temperature-map (landscape world))))
         (if (null map)
             ,default
             (apply #'aref map (robot-position world)))))
     (defcommand ,name
       ,docstring
       (let ((value (,name1 (robot-app-world *app*))))
         (set-robot-data value (robot-app-component ,component *app*))
         value))))

(deftemplike temperature %temperature :temperature 20 "Температура")
(deftemplike radiation %radiation :radiation 0 "Радиация")

(defmacro defquery (name form docstring)
  `(defcommand ,name
     ,docstring
     (let ((world (robot-app-world *app*)))
       (if (robot-active-p (robot world))
           (if (show-reply ,form *app*)
               (values t t)
               (values nil t))
           (values nil nil)))))

(defmacro def-two-queries (yes-name no-name true-name docstring1 docstring2)
  `(progn
     (defquery ,yes-name (,true-name world) ,docstring1)
     (defquery ,no-name (not (,true-name world)) ,docstring2)))

(defmacro def-wall-queries (direction docstring1 docstring2)
  (let ((yes-name (intern (format nil "WALL-~A-P" direction)))
        (no-name (intern (format nil "CLEAR-~A-P" direction)))
        (true-name (intern (format nil "%WALL-~A-P" direction))))
    `(def-two-queries ,yes-name ,no-name ,true-name ,docstring1 ,docstring2)))

(def-two-queries paintedp blankp %cell-painted-p "Клетка закрашена?" "Клетка незакрашена?")
(def-wall-queries up "Есть стена сверху?" "Нет стены сверху?")
(def-wall-queries down "Есть стена снизу?" "Нет стены снизу?")
(def-wall-queries left "Есть стена слева?" "Нет стены слева?")
(def-wall-queries right "Есть стена справа?" "Нет стены справа?")

(defun start (&optional (world *default-world*))
  "Запустить мир робота."
  (if *robot-app-running-p*
      (progn
        (warn "Робот уже запущен.")
        nil)
      (progn
        (setf *app* (make-app (funcall world)))
        (show-robot-app *app*)
        t)))