robot/robot-ltk.lisp

;;;; robot-ltk.lisp

(in-package #:robot-ltk)

(defparameter *originx* 5)
(defparameter *originy* 5)
(defparameter *cell-size* 32)
(defparameter *active-robot-colour* :green)
(defparameter *inactive-robot-colour* :red)
(defparameter *painted-colour* :yellow)
(defparameter *grid-colour* :grey)
(defparameter *dot-radius* 2)
(defparameter *led-size* 32)
(defparameter *yes-led-on-colour* :green)
(defparameter *no-led-on-colour* :red)
(defparameter *window-title* "Робот")

(defclass robot-map (frame)
  ((cells :accessor robot-map-cells)
   (robot :accessor robot-map-robot)))

(defun draw-cells (canvas app)
  (let* ((world (robot-app-world app))
         (columns (landscape-width (landscape world)))
         (rows (landscape-height (landscape world))))
    (let ((cells (make-array (list rows columns))))
      (dotimes (i rows)
        (dotimes (j columns)
          (let ((r (make-rectangle canvas
                                   (+ *originx* (* j *cell-size*))
                                   (+ *originy* (* i *cell-size*))
                                   (+ *originx* (* (1+ j) *cell-size*))
                                   (+ *originy* (* (1+ i) *cell-size*)))))
            (configure r :outline :gray)
            (setf (aref cells i j) r))))
      (update-cells cells app)
      cells)))

(defun draw-dotted-cells (canvas app)
  (loop for (x y) in (dotted-cells (landscape (robot-app-world app)))
        for x0 = (- (+ (* (+ x 1/2) *cell-size*) *originx*) *dot-radius*)
        for y0 = (- (+ (* (+ y 1/2) *cell-size*) *originy*) *dot-radius*)
        for x1 = (+ x0 (* 2 *dot-radius*))
        for y1 = (+ y0 (* 2 *dot-radius*))
        for handle = (create-oval canvas x0 y0 x1 y1)
        do (itemconfigure canvas handle :fill :black)))

(defun update-cells (cells app)
  (loop for (x y) in (painted-cells (robot-app-world app))
        do (configure (aref cells y x) :fill *painted-colour*))
  cells)

(defun draw-walls (canvas app)
  (let* ((world (robot-app-world app))
         (hwall (landscape-hwalls (landscape world)))
         (vwall (landscape-vwalls (landscape world))))
    (loop for (nx ny) in hwall
          for y = (+ *originy* (* ny *cell-size*))
          for x1 = (+ *originx* (* nx *cell-size*))
          for x2 = (+ x1 *cell-size*)
          for line = (create-line canvas (list x1 y x2 y))
          do (itemconfigure canvas line :fill :red)
             (itemconfigure canvas line :width :3))
    (loop for (nx ny) in vwall
          for x = (+ *originx* (* nx *cell-size*))
          for y1 = (+ *originy* (* ny *cell-size*))
          for y2 = (+ y1 *cell-size*)
          for line = (create-line canvas (list x y1 x y2))
          do (itemconfigure canvas line :fill :red)
             (itemconfigure canvas line :width :3))))

(defun robot-oval-coords (world-x world-y)
  (let* ((r (/ *cell-size* 4))
         (x0 (+ (+ *originx* (* (+ world-x 1/2) *cell-size*)) (- r)))
         (y0 (+ (+ *originy* (* (+ world-y 1/2) *cell-size*)) (- r))))
    (list x0 y0 (+ x0 (* 2 r)) (+ y0 (* 2 r)))))

(defun create-robot (canvas)
  (let ((robot-sprite (apply #'make-oval canvas (robot-oval-coords 0 0))))
    (configure robot-sprite :state :hidden)
    robot-sprite))

(defun update-robot (robot-sprite app)
  (let ((robot (robot (robot-app-world app))))
    (when robot
      (setf (coords robot-sprite) (apply #'robot-oval-coords (robot-position (robot-app-world app))))
      (configure robot-sprite
                 :state :normal
                 :fill (if (robot-active-p robot)
                           *active-robot-colour*
                           *inactive-robot-colour*))))
  robot-sprite)

(defun draw-robot (canvas app)
  (update-robot (create-robot canvas) app))

(defun create-robot-map (app master)
  (let* ((landscape (landscape (robot-app-world app)))
         (map (make-instance 'robot-map :master master))
         (canvas (make-instance 'canvas
                                :master map
                                :height (+ (* (landscape-height landscape) *cell-size*)
                                           (* 2 *originy*))
                                :width (+ (* (landscape-width landscape) *cell-size*)
                                          (* 2 *originx*)))))
    (configure canvas :background :white)
    (setf (robot-map-cells map) (draw-cells canvas app))
    (draw-walls canvas app)
    (draw-dotted-cells canvas app)
    (setf (robot-map-robot map) (draw-robot canvas app))
    (pack canvas)
    map))

(defun robot-app-update-map (app)
  (with-atomic
    (let ((map (robot-app-component :map app)))
      (update-cells (robot-map-cells map) app)
      (update-robot (robot-map-robot map) app))))

(defun create-five-buttons (master caption labels-commands)
  (loop with main-frame = (make-instance 'frame :master master)
        with frame = (make-instance 'frame :master main-frame)
        with label = (make-instance 'label :master main-frame :text caption)
        for (text command) in labels-commands
        for position in '((0 1) (1 0) (1 1) (1 2) (2 1))
        for button = (make-instance 'button
                                    :master frame
                                    :text text
                                    :command command
                                    :style "Robot.TButton")
        do (apply #'grid button position)
        finally (grid label 0 0) (grid frame 1 0) (return main-frame)))

(defclass robot-led (frame)
  ((oval :accessor led-oval)
   (on-colour :reader on-colour :initarg :on-colour)))

(defun create-led (master caption on-colour)
  (let* ((led (make-instance 'robot-led
                             :master master
                             :height *led-size*
                             :width *led-size*
                             :on-colour on-colour))
         (label (make-instance 'label
                               :master led
                               :text caption))
         (canvas (make-canvas led :width (+ *led-size* 2) :height (+ *led-size* 2)))
         (oval (make-oval canvas 1 1 (1+ *led-size*) (1+ *led-size*))))
    (grid label 0 0)
    (grid canvas 1 0)
    (setf (led-oval led) oval)
    (set-robot-led-mode :off led)
    led))

(defun set-robot-led-mode (mode led)
  (with-atomic
    (configure (led-oval led) :fill (if (eql mode :on)
                                        (on-colour led) 
                                        :white))))

(defclass robot-data (frame)
  ((data-label :reader data-label)))

(defun create-robot-data (master caption callback)
  (let* ((frame (make-instance 'robot-data :master master))
         (button (make-instance 'button :master frame :text caption :command callback :style "Robot.TButton"))
         (label (make-instance 'label :master frame)))
    (grid button 0 0 :padx 10)
    (grid label 0 1)
    (setf (slot-value frame 'data-label) label)
    frame))

(defun set-robot-data (data component)
  (with-atomic
    (setf (text (data-label component)) data)))

(defparameter *buttons* '((motion ("↑" :up) ("←" :left) ("К" :paint) ("→" :right) ("↓" :down))
                          (query ("↑" :wall-up-p) ("←" :wall-left-p) ("К?" :paintedp) ("→" :wall-right-p) ("↓" :wall-down-p))
                          (alt-query ("↑" :clear-up-p) ("←" :clear-left-p) ("С?" :blankp) ("→" :clear-right-p) ("↓" :clear-down-p))
                          (temperature ("℃" :temperature))
                          (radiation ("☢" :radiation))))

(defun all-callbacks (app)
  (loop for (category . buttons) in *buttons*
        collect (cons category (loop for (text callback-name) in buttons
                                     do (robot-app-callback callback-name app)
                                     collect (list text (robot-app-callback callback-name app))))))

(defun create-robot-app (app)
  (send-wish "ttk::style configure Robot.TButton -width 5")
  (wm-title *tk* *window-title*)
  (let* ((main-frame (make-instance 'frame :master *tk*))
         (callbacks (all-callbacks app)))
    (grid (setf (robot-app-component :map app) (create-robot-map app main-frame)) 0 0 :columnspan 2)
    (grid (create-five-buttons main-frame "Идти" (cdr (assoc 'motion callbacks))) 1 0 :columnspan 2 :pady "10")
    (grid (create-five-buttons main-frame "Занято?" (cdr (assoc 'query callbacks))) 2 0 :padx 5)
    (grid (create-five-buttons main-frame "Свободно?" (cdr (assoc 'alt-query callbacks))) 2 1 :padx 5)
    (grid (setf (robot-app-component :yes-led app) (create-led main-frame "Да" *yes-led-on-colour*)) 3 0 :sticky :e :padx 5)
    (grid (setf (robot-app-component :no-led app) (create-led main-frame "Нет" *no-led-on-colour*)) 3 1 :sticky :w :padx 5)
    (grid (setf (robot-app-component :temperature app) (apply #'create-robot-data main-frame (cadr (assoc 'temperature callbacks)))) 4 0)
    (grid (setf (robot-app-component :radiation app) (apply #'create-robot-data main-frame (cadr (assoc 'radiation callbacks)))) 4 1)
    (grid main-frame 0 0 :padx 12 :pady 3)))

;; TODO Use mailboxes
(defun ltk-background (&optional thunk)
  (let ((box (make-mailbox)))
    (make-thread (lambda ()
                   (setf *robot-app-running-p* t)
                   (unwind-protect
                     (with-ltk ()
                       (mailbox-send-message box *wish*)
                       (when thunk
                         (funcall thunk))))
                   (setf *robot-app-running-p* nil))
                 :name "LTK")
    (mailbox-receive-message box)))

(defun show-robot-app (app &key (background t))
  (let ((do-stuff (lambda ()
                    (create-robot-app app))))
    (setf (robot-app-wish app) (if background
                                   (ltk-background do-stuff)
                                   (prog1
                                     *wish*
                                     (with-ltk ()
                                       (funcall do-stuff)))))))