LOR contest:Lisp - dim13/lor GitHub Wiki

В отличие от других решений, решение на Lisp удалось сделать в одном файле. После загрузки пакета достаточно вызвать функцию advserver для сервера и hclient для клиента. Программа для робота запускается, как команда клиента collect.

(require 'trivial-sockets)

;; World definition and inspection

(defmacro def-world (&rest attr-names)
  `(progn
      ,@(mapcar #'(lambda (attr-name) `(defparameter ,attr-name nil)) attr-names)
      (defun clear-world ()
         (setf ,@(mapcan #'(lambda (attr-name) (list attr-name nil)) attr-names)))
      (defun pack-world ()
         (list 'setf
                 ,@(mapcan
                     #'(lambda (attr-name)
                          (list `(quote ,attr-name) `(list 'quote ,attr-name))) attr-names)))))

(def-world
  bound-x bound-y wall-points thing-points entry-point hero-point hero-carries-thing-p)

(defparameter world-image-name "1")

(defconstant +directions+
    '((#c(1 0) . go-east)
      (#c(-1 0) . go-west)
      (#c(0 -1) . go-north)
      (#c(0 1) . go-south)))

(defun show-world ()
  (loop
    for y upto bound-y
    do (loop
         for x upto bound-x
         for point = (complex x y)
         do (princ
              (cond
                 ((member point wall-points) #\#)
                 ((eql point hero-point) #\@)
                 ((member point thing-points) #\$)
                 (t " ")))
         finally (terpri)))
  (format t "~A~%~A~%~D item(s) here~%"
             (if (or hero-carries-thing-p
                        (remove entry-point thing-points))
                  "Game is in progress"
                  "You won!")
             (if hero-carries-thing-p
                  "You carry an item"
                  "Your hands are empty")
             (count hero-point thing-points)))

;; New Path finder

(defun make-program (directions)
  (mapcar
    #'(lambda (direction)
         `(on-server
            (quote (,(if (numberp direction)
                             (cdr (assoc direction +directions+))
                             direction)))))
    `(,@(reverse directions)
      pickup-thing
      ,@(mapcar #'- directions)
      drop-thing)))

(defun collect ()
  (loop
    with path-table = (make-hash-table)
    for front = () then (cdr front)
    and point = hero-point then (car front)
    while point
    do (loop
         for direction in (mapcar #'car +directions+)
         for neighbour = (+ point direction)
         unless (or
                    (< (realpart neighbour) 0)
                    (> (realpart neighbour) bound-x)
                    (< (imagpart neighbour) 0)
                    (> (imagpart neighbour) bound-y)
                    (member neighbour wall-points)
                    (gethash neighbour path-table))
         do (setf (gethash neighbour path-table) (cons direction (gethash point path-table)))
         (push neighbour front))
    finally
    (return
      `(progn
         ,@(mapcan
              #'(lambda (point)
                    (make-program (gethash point path-table)))
              thing-points)))))

;; Command interpreter

(defun reload-world ()
  (clear-world)
  (with-open-file (file world-image-name)
    (loop
      initially (setq bound-x 0)
      for line = (read-line file nil nil)
      and y upfrom 0
      while line
      do (loop
           for c across line
            and x upfrom 0
           do (case c
               (#\# (push (complex x y) wall-points))
               (#\$ (push (complex x y) thing-points))
               (#\. (setf hero-point (setf entry-point (complex x y)))))
            finally (setq bound-x (max bound-x x)))
      finally (setq bound-y y))))

(defun load-world (file-name)
  (setf world-image-name file-name)
  (reload-world))

;; Go commands
(defmacro def-commands (directions)
  `(progn
     ,@(mapcar #'(lambda (pair)
                        `(defun ,(cdr pair) ()
                          (let ((new-point (+ hero-point ,(car pair))))
                             (unless (member new-point wall-points)
                                (setf hero-point new-point)))))
                  directions)))

(def-commands #.+directions+)

(defun pickup-thing ()
  (when
    (and (member hero-point thing-points)
          (not hero-carries-thing-p))
    (setf hero-carries-thing-p t
            thing-points (remove hero-point thing-points :count 1))))

(defun drop-thing ()
  (when hero-carries-thing-p
     (setf hero-carries-thing-p nil)
     (push hero-point thing-points)))

;; Network layer

(defun send (stream command)
     (write-line (format nil "~S~%" command) stream)
     (force-output stream))

;; Server

(defun advserver (file-name port)
  (load-world file-name)
  (trivial-sockets:with-server
    (server (:port port :reuse-address t))
    (loop
     (with-open-stream
      (stream (trivial-sockets:accept-connection server))
      (eval (read stream))
      (send stream (pack-world))))))

;; Client

(defparameter host "localhost")
(defparameter port 7766)

(defun on-server (server-program)
  (with-open-stream
    (stream (trivial-sockets:open-stream host port))
    (send stream server-program)
    (eval (read stream))
    (show-world)))

(defun hclient (l-host l-port)
  (setf host l-host port l-port)
  (on-server '(reload-world))
  (loop
    (princ "> ") (force-output)
    (eval (eval (read)))))