Просмотр кода страницы LOR-contest/Lisp

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

<pre>
(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)))))
</pre>


[[Category:LOR-contest]]
[[Category:Lisp]]