robot/robot-world.lisp

;;;; robot-world.lisp

(in-package #:robot-impl)

(defvar *robot-app-running-p* nil)

(define-condition robot-app-not-running (error) ())

(defclass robot ()
  ((active-p :accessor robot-active-p :initform t)))

(defclass landscape ()
  ((width :reader landscape-width :initarg :width)
   (height :reader landscape-height :initarg :height)
   (hwalls :reader landscape-hwalls :initarg :hwalls)
   (vwalls :reader landscape-vwalls :initarg :vwalls)
   (dotted-cells :reader dotted-cells :initarg :dotted-cells)
   (temperature :reader temperature-map :initarg :temperature :initform nil)
   (radiation :reader radiation-map :initarg :radiation :initform nil)))

(defclass world ()
  ((landscape :reader landscape :initarg :landscape)
   (robot :reader robot :initarg :robot)
   (robot-position :accessor robot-position :initarg :robot-position)
   (painted-cells :accessor painted-cells :initform '())))

(defclass visible-world (world)
  ((wish :accessor world-wish)
   (robot-sprite :accessor robot-sprite)
   (canvas :accessor world-canvas)
   (cells :accessor world-cells :initform (make-hash-table :test 'equal))
   (yes-led :accessor yes-led)
   (no-led :accessor no-led)))

(defclass app ()
  ((world :accessor robot-app-world :initarg :world)
   (components :accessor app-components :initform (make-hash-table :test 'equal))
   (callbacks :accessor app-callbacks :initform (make-hash-table :test 'equal))
   (wish :accessor robot-app-wish)))

(defvar *app*)

(defparameter *app-callbacks* '#.(loop for command in '(up down left right paint
                                                           wall-up-p wall-down-p wall-left-p wall-right-p
                                                           clear-up-p clear-down-p clear-left-p clear-right-p
                                                           paintedp blankp
                                                           temperature radiation)
                                       nconc (list (intern (symbol-name command) "KEYWORD") command)))

(defparameter *robot-app-components* '(:map
                                        :yes-led
                                        :no-led
                                        :temperature-indicator
                                        :radiation-indicator))

(defun make-app (world &optional (callbacks *app-callbacks*))
  (loop with app = (make-instance 'app :world world)
        for (name callback) on callbacks by #'cddr
        do (setf (gethash name (app-callbacks app)) callback)
        finally (return app)))

(defun robot-app-component (component-name app)
  (values (gethash component-name (app-components app))))

(defun (setf robot-app-component) (component component-name app)
  (setf (gethash component-name (app-components app)) component))

(defun robot-app-callback (callback-name app)
  (values (gethash callback-name (app-callbacks app))))

;;; copypasted from PCL
(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
      `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
        ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
           ,@body)))))

(defparameter *default-world* 'world0)

(defun fresh-world (&key height width horizontal-walls vertical-walls temperature radiation dotted robot-position)
  (macrolet ((remdup (&rest vars)
               `(setf ,@(loop for var in vars
                              append `(,var (remove-duplicates ,var :test #'equal))))))
    (remdup horizontal-walls vertical-walls dotted)
    (lambda ()
      (make-instance 'world
        :landscape (make-instance 'landscape
                                  :height height
                                  :width width
                                  :hwalls horizontal-walls
                                  :vwalls vertical-walls
                                  :dotted-cells dotted
                                  :temperature temperature
                                  :radiation radiation)
        :robot (make-instance 'robot)
        :robot-position robot-position))))

(defmacro defworld (name &key height width horizontal-walls vertical-walls temperature radiation dotted robot-position)
  "Определить функцию без аргументов, возвращающую мир робота."
  (let ((temperature-array-s (gensym "TEMPERATURE-ARRAY-"))
        (radiation-array-s (gensym "RADIATION-ARRAY-")))
    (once-only (height width horizontal-walls vertical-walls temperature radiation dotted robot-position)
      `(let ((,temperature-array-s (and ,temperature (make-array '(,height ,width) :initial-contents ,temperature)))
             (,radiation-array-s (and ,radiation (make-array '(,height ,width) :initial-contents ,radiation))))
         (defun ,name ()
           (let ((world-maker (fresh-world :height ,height
                                           :width ,width
                                           :horizontal-walls ,horizontal-walls
                                           :vertical-walls ,vertical-walls
                                           :temperature ,temperature-array-s
                                           :radiation ,radiation-array-s
                                           :dotted ,dotted
                                           :robot-position ,robot-position)))
             (funcall world-maker)))))))

(defworld world0
  :height 9
  :width 9
  :robot-position '(4 4))