読者です 読者をやめる 読者になる 読者になる

`(kakko ,man)

Find a guide into tomorrow by taking lessons from the past

Lisp Game Programming 再履修 <その13> game map

再履修

正月のイベントもほぼ終わったので再開!

前回はアニメーションテストを行ったけど、アニメーションを表示するためのマップが必要なので、一度マップ表示に戻ろう。
今回から、共通に利用するファイルも用意する。
(ほぼ原作のままだけど、いらないもの?があったので、その分をカットしている)

blaster-common.lisp ⇒

(defpackage :blaster-common
  (:use :common-lisp)
  (:export #:game-map
           #:width #:height #:data
           #:In-map-p
           #:entity
           #:x #:y
           #:bomb
           #:owner #:power #:ticks #:explosion-step
           #:Bomb-kill-zone
           #:player
           #:dx #:dy #:name #:direction
           #:bomb-count #:bomb-power #:dropped-bombs
           #:moving-p #:status
           #:+cell-size+ #:+cell-half-size+ #:+player-step+))
(in-package :blaster-common)

(defmacro define-class (name superclasses slots)
  `(defclass ,name ,superclasses
    ,(mapcar (lambda (slot)
               (let ((keyword (intern (symbol-name slot) :keyword)))
               `(,slot :initarg ,keyword :accessor ,slot)))
             slots)))

(define-class game-map ()
  (width height data))

(defun In-map-p (x y map)
  (and (<= 0 x (1- (width map)))
       (<= 0 y (1- (height map)))))

(define-class entity ()
  (x y))

(define-class bomb (entity)
  (owner power ticks explosion-step))

(defun Bomb-kill-zone (bomb map)
  (let ((cells (list (cons (x bomb) (y bomb)))))
    (loop for (dx . dy) in '((1 . 0) (-1 . 0) (0 . 1) (0 . -1))
          do (loop for i from 1
                   repeat (power bomb)
                   for x = (+ (x bomb) (* i dx))
                   for y = (+ (y bomb) (* i dy))
                   while (and (In-map-p x y map)
                              (not (eql (aref (data map) y x) :wall)))
                   do (push (cons x y) cells)
                   when (eql (aref (data map) y x) :obstacle)
                   return nil))
    cells))

(define-class player (entity)
  (dx dy
   name
   direction
   bomb-count bomb-power dropped-bombs
   moving-p
   status))

(defparameter +cell-size+ 1000)
(defparameter +cell-half-size+ (floor +cell-size+ 2))  ; 500
(defparameter +player-step+ (floor +cell-size+ 5))     ; 200

server-step3.lisp

;;; The Common-Blaser :server
;;; Step1 <Define Packages> <Load Common> <Log File> <Spawn Player> <Handle Client> <Server Start Stop>
;;; Step2 modify : <Spawn Player> <Handle Client>
;;; Step3 <Make Map> modify : <Spawn Player> <Handle Client>
;;;  
;; Step1 <Load Common>
;; -----------------------------------------------------------------------------------------------
(load "C:\\work\\blaster-common.lisp")

;; Step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :blaster-server
  (:use :common-lisp :blaster-common)
  (:export #:Start #:Stop))
(in-package :blaster-server)

;; Step1 <Log File>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\gameserver.log")

(defun Level-string (level)
  (ecase level
    (:error "error")
    (:warning "warning")
    (:info "info")
    (:debug "debug")))

(defun Log-event (level strings &rest args)                 ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append
        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D [~A] ~A~C~C"
                year month date hour minute second          ; output Y M D H M S message
		(Level-string level)
                message
                #\return #\linefeed)))))                    ; output CR/LF for windows!

;; Step3 <Make Map>
;; -----------------------------------------------------------------------------------------------
(defvar *map*)
(defvar *max-player-count*)
(defvar *players*)

(defun Make-map (width height)                              ; map size height * width
  (let ((data (make-array (list height width) :initial-element nil)))
    (loop for i below width
          do (setf (aref data 0 i) :wall                    ; upper  line <-- wall
                   (aref data (1- height) i) :wall))        ; bottom line <-- wall
    (loop for j below height
          do (setf (aref data j 0) :wall                    ; left row    <-- wall
                   (aref data j (1- width)) :wall))         ; right row   <-- wall
    (loop for j from 2 to (- height 3) by 2                 ; 2nd line from top to (- height 3) by 2
          do (loop for i from 2 to (- width 3) by 2         ; 2nd row from left to (- width  3) by 2
                   do (setf (aref data j i) :wall)))        ; <-- wall
    (loop repeat 10
          do (setf (aref data
                         (+ (* (random (floor (- height 1) 2)) 2) 1) ; set where there are no walls
                         (+ (* (random (floor (- width 1) 2)) 2) 1)) ; random <= 5(MAX)
                   :obstacle))
    (make-instance 'game-map :width width :height height :data data)))

(defun Map->string (map)
  (with-output-to-string (stream)
    (loop for j below (height map)
          do (loop for i below (width map)
                   do (write-char (ecase (aref (data map) j i) ; output string to stream 
                                    ((nil) #\.)
                                    (:wall #\X)
                                    (:obstacle #\O))
                                  stream)))))

;; Step1 <Spawn Player>  Step 3 modify
;; -----------------------------------------------------------------------------------------------
(defun Spawn-player (player-name map)
  (let ((player (make-instance 'player
                               :name player-name
                               :x (random (width map))
                               :y (random (height map))
                               :dx 0
                               :dy 0
                               :direction :south
                               :moving-p nil
                               :status :playing)))
    (push player *players*)    ; add player to *players*
    player))

;; Step 2 modify
(defun Kill-player (player)
  (setf *players* (remove player *players*))) ; remove player from *players*

;; Step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defvar *server-socket*)

(defpackage :blaster-commands)

(defun Parse-command (line)
  (let ((trimmed (and line  ; delete spaces, newlines, and tabs at the beginning and end of the string
		      (string-trim '(#\space #\return #\linefeed) line))))
    (if (zerop (length trimmed))
        (values nil nil)
        (let ((tokens (split-sequence:split-sequence #\space trimmed))) ; split character string with space
          (values (intern (string-upcase (first tokens)) 'blaster-commands)  ; blaster-commands packsge <--
                  (rest tokens))))))                                         ; intern (first tokens)

;; Step1 <Handle Client>
;; -----------------------------------------------------------------------------------------------
(defun Handle-client (stream)
  (Log-event :info "New connection: ~A" stream) ; stream from blaster-client
  (loop with player = nil
        for line = (read-line stream nil nil)
        for input = (and line (string-trim '(#\space #\return #\linefeed) line))
        do (multiple-value-bind (command args)  ; command <-- (first tokens) <-- PLAY      
             (Parse-command line)               ; args    <-- (rest tokens)  <-- tomekame0126
	     (case command
	       ;; Step 2 modify
	       (blaster-commands::quit          ; command <-- (first tokens) <-- QUIT
	       	 (when player                   
		   (Kill-player player))        ; remove player from *players*
		   (return))                    ; thread finish
               (blaster-commands::play          ; command <-- (first tokens) <-- PLAY
                 (cond ((= (length *players*) *max-player-count*)   ; if player MAX!
                         (format stream "ERROR too many players~%") ; return ERROR!
                         (return))                                  ; thread finish 
		       (t
			;; Step 3  modify
		        (setf player (Spawn-player (first args) *map*)) ; new player spawn		
		        (format stream "OK ~A ~A ~A ~%"
		               (width *map*) (height *map*)	       
                               (Map->string *map*)))))))					       
           (finish-output stream))
  (close stream)
  (Log-event :info "Done processing ~A" stream))


;; Step1 <Server Start Stop>
;; -----------------------------------------------------------------------------------------------
(defvar *listen-thread*)

(defun Server-listen ()
  (let ((stream (usocket:socket-stream (usocket:socket-accept *server-socket*)))) ; socket <-- accept
    (bordeaux-threads:make-thread (lambda () (Handle-client stream))  ; thread <-- (handle-client socket)
                           :name "Game Server [client]")))

(defun Start (map-width map-height max-player-count &key (port 8080))
  (setf *map* (make-map map-width map-height))
  (setf *max-player-count* max-player-count
        *players* '())
  (setf *server-socket* (usocket:socket-listen "localhost" port    ; listen 
                                               :reuse-address t))
  (setf *listen-thread* (bordeaux-threads:make-thread (lambda ()   ; *listen-thread* <-- (handle-client socket) thread			   
                                                        (loop
						          (Server-listen)))
                                                  :name "Game Server [listen]"))
  (Log-event :info "Server started on port ~A" port)
  t)

(defun Stop ()  
  (usocket:socket-close *server-socket*)              ; stop listen
  (bordeaux-threads:destroy-thread *listen-thread*)   ; stop thread
  (log-event :info "Server stopped")
  t)

(defun Prompt ()
  (let ((command (read)))                             ; wait for input [stop]
    (if (eql command 'stop)
          (stop)
        (Prompt))))

;; Step 2  modify
(defun Operation ()
  (format t "blaster-server is now working!~%")
  (format t "if you want to shutdown the server,type [stop]~%")
  (Start 12 12 2)   ; map-width:12 ,map-height:12 ,max-player:2
  (Prompt))
    
(Operation)

client-step3.lisp

;;; The Common-Blaser :client
;;; Step1 <Game Frame> <Define Packages> <Load Common> <Parse-Response>
;;; Step2 <Game Window> 
;;; Step3 <Load-Imagaes> <Parse-Map> <Draw-Game> modify : <Game Window> <Game Frame>
;;;
;; Step1 <Load Common>
;; -----------------------------------------------------------------------------------------------
(load "C:\\work\\blaster-common.lisp")

;; Step1 <Define Package> :client
;; -----------------------------------------------------------------------------------------------
(defpackage :client
  (:use :common-lisp :blaster-common)
  (:export #:Common-blaster))
(in-package :client)

;; Step2 <Load-Images>
;; -----------------------------------------------------------------------------------------------
(defparameter *ground-image* nil)
(defparameter *wall-image* nil)
(defparameter *obstacle-image* nil)
(defparameter *player-image* nil)
(defparameter *dead-image* nil)
(defparameter *bomb-image* nil)
(defparameter *explosion-image* nil)

(defun Load-images ()
  (setf *ground-image* (sdl:load-image "C:\\work\\Images\\ground.png")
        *wall-image* (sdl:load-image "C:\\work\\Images\\wall.png")
        *obstacle-image* (sdl:load-image "C:\\work\\Images\\obstacle.png")
        *player-image* (sdl:load-image "C:\\work\\Images\\player.png")
        *dead-image* (sdl:load-image "C:\\work\\Images\\dead.png")
        *bomb-image* (sdl:load-image "C:\\work\\Images\\bomb.png")
        *explosion-image* (sdl:load-image "C:\\work\\Images\\explosion.png")))

;; Step1 <Parse-Response> 
;; -----------------------------------------------------------------------------------------------
(defun Parse-response (line)
  (let ((trimmed (and line 
		      (string-trim '(#\space #\return #\linefeed) line))))
    (if (zerop (length trimmed))
        (values nil nil)
        (let ((tokens (split-sequence:split-sequence #\space trimmed)))
          (values (string-upcase (first tokens))
                  (rest tokens))))))

;; Step2 <Parse-Map> 
;; -----------------------------------------------------------------------------------------------
(defun Parse-map (string width height)
  (let ((data (make-array (list height width) :initial-element nil))
        (index 0))
    (loop for j below height
          do (loop for i below width
                   do (setf (aref data j i)
                            (ecase (aref string index)
                              (#\. nil)
                              (#\X :wall)
                              (#\O :obstacle)))
                      (incf index)))
    (make-instance 'game-map :width width :height height :data data)))

;; Step2 <Draw-Game> 
;; -----------------------------------------------------------------------------------------------
(defun Draw-game (map)
  (sdl:clear-display (sdl:color :r 40 :g 40 :b 40))
  (loop for j below (height map)
        for y = 12 then (+ y 48)              ; window-height:600,map-height:576, difference:24 --> half:12 
        do (loop for i below (width map)
                 for x = 10 then (+ x 65)     ; window-width:800,map-width:780,   difference:20 --> half:10
                 do (sdl:draw-surface-at-* (case (aref (data map) j i)
                                             ((nil) *ground-image*)
                                              (:wall *wall-image*)
                                              (:obstacle *obstacle-image*))
                                            x y)))
  (sdl:update-display))

(defvar *server-socket*)
(defvar *server-stream*)

(defun Close-socket ()
  (close *server-stream*)
  (usocket:socket-close *server-socket*))	

;; Step2 <Game Window>  Step3 modify
;; -----------------------------------------------------------------------------------------------
(defun Play-game (map)      ; game main routine
  (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) ; use video and audio
    (sdl:window 800 600 :position 'center                ; size 800*600, position center
                      ; :position #(192 50)              ;               position x(192) y(50)
                        :title-caption "BLASTER"
                        :icon-caption  "BLASTER"  
                        :flags '(sdl:sdl-doublebuf sdl:sdl-sw-surface))
    (Load-images)

    (sdl:with-events (:poll)
      (:quit-event ()
	(Close-socket)	   
        t)

      (:idle ()
       (when (sdl:get-key-state :SDL-KEY-Q)  ;---> blaster-command::quit (Handle-client)
         (format *server-stream* "QUIT~%")
         (finish-output *server-stream*)
	 (Close-socket)
         (return-from Play-game))

      ;; Step3 modify  
      (Draw-game map)))))

;; Step1 <Game-Frame>  Step3 modify
;; -----------------------------------------------------------------------------------------------
(defun Common-blaster (server-host player-name &key (server-port 8080))
  (format t "Connecting to server ~A:~A...~%" server-host server-port)
  (setf *server-socket* (usocket:socket-connect server-host server-port))
  (setf *server-stream* (usocket:socket-stream *server-socket*))
 
  (format *server-stream* "PLAY ~A~%" player-name)  ;----> blaster-command::play (Handle-client)
  (finish-output *server-stream*)

  (let ((line (read-line *server-stream* nil nil)))
    (multiple-value-bind (response args)
        (Parse-response line)
        (cond ((null response)
               (format t "Connection error, stopping.~%"))
              ((string= response "ERROR")
                 (format t "Cannot join game:~A~%" (subseq line 5)))
              ((string= response "OK")
               (format t "Joining game, map ~Ax~A~%" (first args) (second args))

	       ;; Step3 modify
               (let* ((map-width (parse-integer (first args)))
                      (map-height (parse-integer (second args)))
                      (map (parse-map (third args) map-width map-height))) ; map <-- 'game-map instance
                 (Play-game map)))))))

;; Step1 <Define Package> :blaster-client
;; -----------------------------------------------------------------------------------------------
(defpackage :blaster-client
  (:use :common-lisp :client))
(in-package :blaster-client)

  (Common-blaster "localhost" "tomekame0126")

サーバを立ち上げて、
f:id:tomekame0126:20170122115132p:plain
クライアントを立ち上げると、
f:id:tomekame0126:20170122115251p:plain
期待どおりにマップの表示!
f:id:tomekame0126:20170122115450p:plain

まあ、今回は大したことやってないけど、次回は前回のアニメーションの機能をマップ上で実現しよう。
では。

Lisp Game Programming 再履修 <その12> animation test

再履修

前回 multithreading③ のプログラムコードの動きもメモっておこう。

f:id:tomekame0126:20161226215321j:plain
f:id:tomekame0126:20161226215329j:plain

次は、何にも表示していないウィンドウ内にマップを表示すること。
そして、マップ上で player を動かしてみることが次のテーマとなる。

ちょっと味付けを変えて、player を動かすアニメーションのテストをやっておこう。

まずは、このファイルを利用して、キー操作で動かす復習。
f:id:tomekame0126:20161230094730p:plain

では行ってみよう。
キー操作に関する2種類のプログラムコードを用意した。
注)common-shooter ではシューティング用として keystate クラスを作成してキースキャンを行っている。
http://tomekame0126.hatenablog.com/entry/2014/07/06/074832

注)dx と dy は今後のために付け加えてある。テストなので、グローバル変数イヤーマフ( *変数* )はとっている。

player-animation-test.lisp

(defpackage :animation
  (:use :common-lisp)
  (:export #:animation-test))
(in-package :animation)

(defmacro define-class (name superclasses slots)
  `(defclass ,name ,superclasses
    ,(mapcar (lambda (slot)
               (let ((keyword (intern (symbol-name slot) :keyword)))
               `(,slot :initarg ,keyword :accessor ,slot)))
             slots)))

(define-class player ()
  (id          ; image-id number
   direction   ; up down left right
   x y         ; position x y
   dx dy))     ; speed

(defparameter +player-step+ 4)
(defvar current 0)     ; current image-id number

(defun Move-player (player)
    (case (direction player)
      (:north 		                     ;  UP
       (setf (id player) 5)       
         (decf (y player) +player-step+))
      (:south                                ; DOWN
       (setf (id player) 0)      
        (incf (y player) +player-step+)) 
      (:west                                 ; LEFT
       (setf (id player) 10)     
        (decf (x player) +player-step+))
      (:east                                 ; RIGHT
       (setf (id player) 15)   
         (incf (x player) +player-step+)))
    (setf (direction player) nil))           ; dirention reset

(defvar playerimage)
(defvar imagecells)

(defun Load-images ()
  (setf playerimage (sdl:load-image "C:\\work\\Images\\player.png"))           
  (setf imagecells (loop for y from 0 to 300 by 100
		     append (loop for x from 0 to 200 by 50
                       collect (list x y 50 100)))) 				      
  (setf (sdl:cells playerimage) imagecells))

(defun Play-game ()
  (sdl:with-init ()
    (sdl:window 800 600 :title-caption "player-animation-test")

    (setf (sdl:frame-rate) 25)    

    (Load-images)

    (let ((player (make-instance 'player
			       :id 0
			       :direction :SOUTH
                               :x 350
                               :y 150
                               :dx  0
			       :dy  0)))

      (sdl:with-events ()
        (:quit-event () 
	 t)

        (:idle ()
        (cond ((sdl:get-key-state :SDL-KEY-UP)    (setf (direction player) :NORTH))	                                        
              ((sdl:get-key-state :SDL-KEY-DOWN)  (setf (direction player) :SOUTH))	                                        
              ((sdl:get-key-state :SDL-KEY-LEFT)  (setf (direction player) :WEST))                                               
              ((sdl:get-key-state :SDL-KEY-RIGHT) (setf (direction player) :EAST))                                                 
              ((sdl:get-key-state :SDL-KEY-Q)     (return-from Play-game)))

         (sdl:clear-display sdl:*black*)
          
         (Move-player player)
                     	 	 
         (sdl:draw-surface-at-* playerimage (x player) (y player) :cell (+ (id player) current))
         (when (>= (incf current) (floor (length imagecells) 4))
	   (setf current 0))

         (sdl:update-display))))))

(Play-game)

player-animation-test2.lisp

(defpackage :animation
  (:use :common-lisp)
  (:export #:animation-test))
(in-package :animation)

(defmacro define-class (name superclasses slots)
  `(defclass ,name ,superclasses
    ,(mapcar (lambda (slot)
               (let ((keyword (intern (symbol-name slot) :keyword)))
               `(,slot :initarg ,keyword :accessor ,slot)))
             slots)))

(define-class player ()
  (id
   direction
   x y
   dx dy))

(defparameter +player-step+ 4)
(defvar current 0)

(defun Move-player (player)
    (case (direction player)
      (:north                               ; UP
       (setf (id player) 5)       
         (decf (y player) +player-step+))
      (:south                               ; DOWN
       (setf (id player) 0)      
        (incf (y player) +player-step+)) 
      (:west                                ; LEFT
       (setf (id player) 10)     
        (decf (x player) +player-step+))
      (:east                                ; RIGHT
       (setf (id player) 15)   
         (incf (x player) +player-step+)))
    (setf (direction player) nil))         ; dirention reset

(defvar playerimage)
(defvar imagecells)

(defun Load-images ()
  (setf playerimage (sdl:load-image "C:\\work\\Images\\player.png"))           
  (setf imagecells (loop for y from 0 to 300 by 100
		     append (loop for x from 0 to 200 by 50
                       collect (list x y 50 100)))) 				      
  (setf (sdl:cells playerimage) imagecells))

(defun Play-game ()
  (sdl:with-init ()
    (sdl:window 800 600 :title-caption "player-animation-test")

    (setf (sdl:frame-rate) 25)    
    (sdl:enable-key-repeat 1 1)
    (Load-images)

    (let ((player (make-instance 'player
			       :id 0
			       :direction :SOUTH
                               :x 350
                               :y 150
                               :dx  0
			       :dy  0)))

      (sdl:with-events ()
        (:quit-event () 
	 t)
	
        (:key-down-event ()
          (cond ((sdl:key-down-p :SDL-KEY-UP)    (setf (direction player) :NORTH)) 
                ((sdl:key-down-p :SDL-KEY-DOWN)  (setf (direction player) :SOUTH))     
                ((sdl:key-down-p :SDL-KEY-LEFT)  (setf (direction player) :WEST))
                ((sdl:key-down-p :SDL-KEY-RIGHT) (setf (direction player) :EAST))
                ((sdl:key-down-p :SDL-KEY-Q)     (return-from Play-game))))
         
        (:idle ()
         (sdl:clear-display sdl:*black*)
          
         (Move-player player)
                     	 	 
         (sdl:draw-surface-at-* playerimage (x player) (y player) :cell (+ (id player) current))
         (when (>= (incf current) (floor (length imagecells) 4))
	   (setf current 0))

         (sdl:update-display))))))

(Play-game)

違いは、(:idle () 内でキー入力を拾うか、(:key-down-event () 内でキーの割り込みを拾うかの差。
うーん。違いのわかる男の○○○○ンド! 
注)○○○○はキーバイね。キーバインド。ゴールドブレではありません。念のため。
両方ともこんな感じに表示されて動く。
f:id:tomekame0126:20161230103002p:plain
f:id:tomekame0126:20161230103006p:plain

また、このファイルでは、爆発のアニメーションとサウンド関係の復習をする。
f:id:tomekame0126:20161230094736p:plain

player-explosion-test.lisp

(defpackage :animation
  (:use :common-lisp)
  (:export #:explosion-test))
(in-package :animation)

(defvar player)
(defvar player-cells)
(defvar current)

(defun Load-images ()        
  (setf player (sdl:load-image "C:\\work\\Images\\explosion.png"))           
  (setf player-cells (loop for y from 0 to 48 by 48
                       append (loop for x from 0 to 260 by 65
                         collect (list x y 65 48))))
  (setf (sdl:cells player) player-cells))

(defvar explosion-sound)

(defun Open-sounds ()
  (sdl-mixer:open-audio :chunksize 1024 :channels 2)
  (sdl-mixer:allocate-channels 16))

(defun Stop-sound ()
  (when (sdl-mixer:sample-playing-p nil)
    (sdl-mixer:halt-sample)))

(defun Close-sound ()
   (sdl-mixer:free explosion-sound)
   (sdl-mixer:close-audio))

(defun Load-sounds ()  
  (handler-case     
      (setf explosion-sound (sdl-mixer:load-sample "C:\\work\\SoundS\\explosion.wav")) 
    (error ()
      (format t "Cannot open sound device. disabling sounds ~%")))) 	   

(defun Play-sample (sample)
  (sdl-mixer:play-sample sample)) 

(defun Animation-test ()
  (sdl:with-init ()
    (sdl:window 800 600 :title-caption "explosion-test")

    (setf (sdl:frame-rate) 50)  
    (setf current 0)
    
    (Load-images)

    (Open-sounds)
    (Load-sounds)

      (sdl:with-events ()
        (:quit-event () 
	  (Stop-sound)
          (Close-sound)
	 t)

        (:key-down-event ()
         (when (sdl:key-down-p :SDL-KEY-Q)
           (sdl:push-quit-event)))

        (:idle ()
         (sdl:clear-display sdl:*black*) 
         (sdl:draw-surface-at-* player (- 400 25) 250 :cell current)  
	 (Play-sample explosion-sound)
         
         (when (>= (incf current) (length player-cells))
           (setf current 0))
         (sdl:update-display)))))

(Animation-test)

こんな感じに表示される。
f:id:tomekame0126:20161230104006p:plain

では、また。

注)画像等は以下のサイトの Blaster のデータを参考にしている。
  http://matthieu.villeneuve.free.fr/dev/games/

Lisp Game Programming 再履修 <その11> multithreading ③

再履修

ウィンドウを出すのは、このブログの一番最初にやったプログラムコードをそのまま(Play-game) に付け加えるだけ。
http://tomekame0126.hatenablog.com/entry/2014/06/26/222706

すなわち、これを

(defun Play-game ()         ; game main routine   
  (Close-socket))    

こんな感じにするだけ。
ウィンドウクローズボタンや q を押すことで終了する。

(defun Play-game ()     ; game main routine
  (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) ; use video and audio
    (sdl:window 800 600 :position 'center                ; size 800*600, position center
                      ; :position #(192 50)              ;               position x(192) y(50)
                        :title-caption "BLASTER"
                        :icon-caption  "BLASTER"  
                        :flags '(sdl:sdl-doublebuf sdl:sdl-sw-surface))

    (sdl:with-events (:poll)
      (:quit-event ()
	(Close-socket)	   
        t)

      (:idle ()
       (when (sdl:get-key-state :SDL-KEY-Q)  ;---> blaster-command::quit (Handle-client)
         (format *server-stream* "QUIT~%")
         (finish-output *server-stream*)
	 (Close-socket)
         (return-from Play-game))))))

これに合わせてモデファイしたサーバ側
Q が押されたら、(remove player *players*) を行うファンクションを追加している。
server-step2.lisp

;;; The Common-Blaser :server
;;; Step1 <Define Packages> <Log File> <Macro> <Spawn Player> <Handle Client> <Server Start Stop>
;;; Step2 modify : <Spawn Player> <Handle Client> 
;;; 
;; Step1 <Define Package> :blaster-server
;; -----------------------------------------------------------------------------------------------
(defpackage :blaster-server
  (:use :common-lisp)
  (:export #:Start #:Stop))
(in-package :blaster-server)

;; Step1 <Log File>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\gameserver.log")

(defun Level-string (level)
  (ecase level
    (:error "error")
    (:warning "warning")
    (:info "info")
    (:debug "debug")))

(defun Log-event (level strings &rest args)                 ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append
        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D [~A] ~A~C~C"
                year month date hour minute second          ; output Y M D H M S message
		(Level-string level)
                message
                #\return #\linefeed)))))                    ; output CR/LF for windows!

;; Step1 <Macro>
;; -----------------------------------------------------------------------------------------------
(defmacro define-class (name superclasses slots)
  `(defclass ,name ,superclasses
    ,(mapcar (lambda (slot)
               (let ((keyword (intern (symbol-name slot) :keyword)))
               `(,slot :initarg ,keyword :accessor ,slot)))
             slots)))

(define-class player ()
  (name))

;; Step1 <Spawn Player>
;; -----------------------------------------------------------------------------------------------
(defvar *max-player-count*)
(defvar *players*)

(defun Spawn-player (player-name)
  (let ((player (make-instance 'player
                               :name player-name)))
    (push player *players*)    ; add player to *players*
    player))

;; Step 2 modify
(defun Kill-player (player)
  (setf *players* (remove player *players*))) ; remove player from *players*

;; Step1 <Define Package> :blaster-command
;; -----------------------------------------------------------------------------------------------
(defvar *server-socket*)

(defpackage :blaster-commands)

;; Step1 <Handle Client>
;; -----------------------------------------------------------------------------------------------
(defun Parse-command (line)
  (let ((trimmed (and line  ; delete spaces, newlines, and tabs at the beginning and end of the string
		      (string-trim '(#\space #\return #\linefeed) line))))
    (if (zerop (length trimmed))
        (values nil nil)
        (let ((tokens (split-sequence:split-sequence #\space trimmed))) ; split character string with space
          (values (intern (string-upcase (first tokens)) 'blaster-commands)  ; blaster-commands packsge <--
                  (rest tokens))))))                                         ; intern (first tokens)

(defun Handle-client (stream)
  (Log-event :info "New connection: ~A" stream) ; stream from blaster-client
  (loop with player = nil
        for line = (read-line stream nil nil)
        for input = (and line (string-trim '(#\space #\return #\linefeed) line))
        do (multiple-value-bind (command args)  ; command <-- (first tokens) <-- PLAY	       
             (Parse-command line)               ; args    <-- (rest tokens)  <-- tomekame0126
	     (case command
               ;; Step 2 modify
	       (blaster-commands::quit    ;<--- "QUIT~%" (Common-blaster)
	       	 (when player                   ; when player is alive
		   (Kill-player player))        ; remove player
		   (return))
               (blaster-commands::play    ;<--- "PLAY ~A%" (Common-blaster)
                 (cond ((= (length *players*) *max-player-count*)   ; if player MAX!
                        (format stream "ERROR too many players~%")  ; return ERROR!
                        (return))                                   ; thread finish 
		       (t
		        (setf player (Spawn-player (first args)))   ; new player spawn
		        (format stream "OK ~%")  )))))					       
           (finish-output stream))
  (close stream)
  (Log-event :info "Done processing ~A" stream))

;; Step1 <Server Start Stop>
;; -----------------------------------------------------------------------------------------------
(defvar *listen-thread*)

(defun Server-listen ()
  (let ((stream (usocket:socket-stream (usocket:socket-accept *server-socket*)))) ; socket <-- accept
    (bordeaux-threads:make-thread (lambda () (Handle-client stream))  ; thread <-- (handle-client socket)
                           :name "Game Server [client]")))

(defun Start (max-player-count &key (port 8080))
  (setf *max-player-count* max-player-count  *players* '())

  (setf *server-socket* (usocket:socket-listen "localhost" port    ; listen 
                                               :reuse-address t))
  (setf *listen-thread* (bordeaux-threads:make-thread (lambda ()   ; *listen-thread* <-- thread:(handle-client stream) 			   
                                                        (loop
						          (Server-listen)))
                                                  :name "Game Server [listen]"))
  (Log-event :info "Server started on port ~A" port)
  t)

(defun Stop ()  
  (usocket:socket-close *server-socket*)              ; stop listen
  (bordeaux-threads:destroy-thread *listen-thread*)   ; stop thread
  (log-event :info "Server stopped")
  t)

(defun Prompt ()
  (let ((command (read)))                             ; wait for input [stop]
    (if (eql command 'stop)
          (stop)
        (Prompt))))  

(defun Operation ()
  (format t "blaster-server is now working!~%")
  (format t "if you want to shutdown the server,type [stop]~%")
  (Start 2)   ; max-player:2
  (Prompt))
    
(Operation)

続いて、Step 2 としてウィンドウ機能を追加したクライアント側
client-step2.lisp

;;; The Common-Blaser :client
;;; Step1 <Game Frame> <Define Packages> <Parse-Response> 
;;; Step2 <Game Window>
;;;
;; Step1 <Define Package> :client
;; -----------------------------------------------------------------------------------------------
(defpackage :client
  (:use :common-lisp)
  (:export #:Common-blaster))
(in-package :client)

;; Step1 <Parse-Response> 
;; -----------------------------------------------------------------------------------------------
(defun Parse-response (line)
  (let ((trimmed (and line  ; delete spaces, newlines, and tabs at the beginning and end of the string
		      (string-trim '(#\space #\return #\linefeed) line))))
    (if (zerop (length trimmed)) 
        (values nil nil)
        (let ((tokens (split-sequence:split-sequence #\space trimmed))) ; split character string with space
          (values (string-upcase (first tokens)) ; SAMPLE <-- sample etc 
                  (rest tokens))))))

(defvar *server-socket*)
(defvar *server-stream*)

(defun Close-socket ()
  (close *server-stream*)
  (usocket:socket-close *server-socket*))	

;; Step2 <Game Window> 
;; -----------------------------------------------------------------------------------------------
(defun Play-game ()     ; game main routine
  (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) ; use video and audio
    (sdl:window 800 600 :position 'center                ; size 800*600, position center
                      ; :position #(192 50)              ;               position x(192) y(50)
                        :title-caption "BLASTER"
                        :icon-caption  "BLASTER"  
                        :flags '(sdl:sdl-doublebuf sdl:sdl-sw-surface))

    (sdl:with-events (:poll)
      (:quit-event ()
	(Close-socket)	   
        t)

      (:idle ()
       (when (sdl:get-key-state :SDL-KEY-Q)  ;---> blaster-command::quit (Handle-client)
         (format *server-stream* "QUIT~%")
         (finish-output *server-stream*)
	 (Close-socket)
         (return-from Play-game))))))
	 
;; Step1 <Game-Frame> 
;; -----------------------------------------------------------------------------------------------
(defun Common-blaster (server-host player-name &key (server-port 8080))
  (format t "Connecting to server ~A:~A...~%" server-host server-port)
  (setf *server-socket* (usocket:socket-connect server-host server-port))
  (setf *server-stream* (usocket:socket-stream *server-socket*))
 
  (format *server-stream* "PLAY ~A~%" player-name)
  (finish-output *server-stream*)
  (let ((line (read-line *server-stream* nil nil))) ; read-line from blaster-server
    (multiple-value-bind (response args)        
        (Parse-response line)
        (declare (ignore args))                     ; <-- for later use!
        (cond ((null response)
               (format t "Connection error, stopping.~%"))
              ((string= response "ERROR")
	        (format t "Cannot join game:~A~%" (subseq line 5))) ; <-- too many players ~%
              ((string= response "OK")
	       (format t "Joining game ~%")
	       (Play-game))))))
	       
;; Step1 <Define Package> :blaster-client
;; -----------------------------------------------------------------------------------------------
(defpackage :blaster-client
  (:use :common-lisp :client))
(in-package :blaster-client)

  (Common-blaster "localhost" "tomekame0126")

f:id:tomekame0126:20161226202933p:plain
はいっ!予想どおりの結果です。

そしてサーバを立ち上げ、2人がアクセスして接続を切った後、サーバをシャットダウンしたログ。
f:id:tomekame0126:20161226212156p:plain

忘年会が続き、さすがに飲み疲れました。
今夜はここまで。

Lisp Game Programming 再履修 <その10> multithreading ②

再履修

Web サーバなら分かるけど、ゲームでは usocket や bordeaux-threads を使うシチュエーションはそうそうないのだろう。
なので、自分自身が後からこのプログラムコードを見たときに参考になるメモの意味合いで、理解を助けるためのイメージ図を残しておこう。
注)あくまでも自分向けです。へへ。

f:id:tomekame0126:20161226200404j:plain

server-step1.lisp や client-step1.lisp では、なんだっけ状態にあった「 intern 」や「 defpackage 」の使い方を何となく思い出したことが収穫だった。

プログラムコードの中で、パッケージを新たに宣言し、

(defpackage :blaster-commands)

その中で、blaster-commandsに、クライアントから送信されたコマンドの「 PLAY 」をインターン(大文字が必須)して、

(intern (string-upcase (first tokens)) 'blaster-commands)

コマンドをこんな感じで変更するのは、どこかで見たことはあったけど使うようなことはなかった。

(case command
  (blaster-command::play

よっしゃ! お次はウィンドウを出してみよう。

「いや~。Lisp って本当にいいもんですね!」
ご同輩、知ってますよね?このフレーズ。

Lisp Game Programming 再履修 <その9> multithreading ①

再履修

Lisp の再履修のために勉強材料としたサイトにあった別のプログラムコードを見たら、マルチスレッド化されたゲームのようだったのでちょっとつまみ食い。
でも、忘年会で食べすぎたのか、sbcl がエラーを吐きまくりで、結局つまみ食いどころか、Lisp のプログラムコードを見るのも嫌なくらい食べ過ぎてしまった。

再履修で試しに使った usocket と bordeaux-threads を組み合わせて、2人まで server にアクセスできるが、3人目は「ごめん。ムリ!」と拒否るものをでっち上げてみた。(追記:split-sequence も使ってます。便利ですね。)
ちょっと長いので何回かに分け、忘れたときのことを考え、後でメモも残しておこう。

まずは、サーバ
server-step1.lisp

;;; The Common-Blaser :server
;;; Step1 <Define Packages> <Log File> <Macro> <Spawn Player> <Handle Client> <Server Start Stop>
;;;  
;; Step1 <Define Package> :blaster-server
;; -----------------------------------------------------------------------------------------------
(defpackage :blaster-server
  (:use :common-lisp)
  (:export #:Start #:Stop))
(in-package :blaster-server)

;; Step1 <Log File>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\gameserver.log")

(defun Level-string (level)
  (ecase level
    (:error "error")
    (:warning "warning")
    (:info "info")
    (:debug "debug")))

(defun Log-event (level strings &rest args)                 ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append
        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D [~A] ~A~C~C"
                year month date hour minute second          ; output Y M D H M S message
		(Level-string level)
                message
                #\return #\linefeed)))))                    ; output CR/LF for windows!

;; Step1 <Macro>
;; -----------------------------------------------------------------------------------------------
(defmacro define-class (name superclasses slots)
  `(defclass ,name ,superclasses
    ,(mapcar (lambda (slot)
               (let ((keyword (intern (symbol-name slot) :keyword)))
               `(,slot :initarg ,keyword :accessor ,slot)))
             slots)))

(define-class player ()
  (name))

;; Step1 <Spawn Player>
;; -----------------------------------------------------------------------------------------------
(defvar *max-player-count*)
(defvar *players*)

(defun Spawn-player (player-name)
  (let ((player (make-instance 'player
                               :name player-name)))
    (push player *players*)    ; add player to *players*
    player))

;; Step1 <Define Package> :blaster-command
;; -----------------------------------------------------------------------------------------------
(defvar *server-socket*)

(defpackage :blaster-commands)

;; Step1 <Handle Client>
;; -----------------------------------------------------------------------------------------------
(defun Parse-command (line)
  (let ((trimmed (and line  ; delete spaces, newlines, and tabs at the beginning and end of the string
		      (string-trim '(#\space #\return #\linefeed) line))))
    (if (zerop (length trimmed))
        (values nil nil)
        (let ((tokens (split-sequence:split-sequence #\space trimmed))) ; split character string with space
          (values (intern (string-upcase (first tokens)) 'blaster-commands)  ; blaster-commands packsge <--
                  (rest tokens))))))                                         ; intern (first tokens)

(defun Handle-client (stream)
  (Log-event :info "New connection: ~A" stream) ; stream from blaster-client
  (loop with player = nil
        for line = (read-line stream nil nil)
        for input = (and line (string-trim '(#\space #\return #\linefeed) line))
        do (multiple-value-bind (command args)  ; command <-- (first tokens) <-- PLAY	       
             (Parse-command line)               ; args    <-- (rest tokens)  <-- tomekame0126
	     (case command
               (blaster-commands::play
                 (cond ((= (length *players*) *max-player-count*)   ; if player MAX!
                        (format stream "ERROR too many players~%")  ; return ERROR!
                        (return))                                   ; thread finish 
		       (t
		        (setf player (Spawn-player (first args)))   ; new player spawn
		        (format stream "OK ~%")  )))))					       
           (finish-output stream))
  (close stream)
  (Log-event :info "Done processing ~A" stream))

;; Step1 <Server Start Stop>
;; -----------------------------------------------------------------------------------------------
(defvar *listen-thread*)

(defun Server-listen ()
  (let ((stream (usocket:socket-stream (usocket:socket-accept *server-socket*)))) ; socket <-- accept
    (bordeaux-threads:make-thread (lambda () (Handle-client stream))  ; thread <-- (handle-client socket)
                           :name "Game Server [client]")))

(defun Start (max-player-count &key (port 8080))
  (setf *max-player-count* max-player-count  *players* '())

  (setf *server-socket* (usocket:socket-listen "localhost" port    ; listen 
                                               :reuse-address t))
  (setf *listen-thread* (bordeaux-threads:make-thread (lambda ()   ; *listen-thread* <-- thread:(handle-client stream) 			   
                                                        (loop
						          (Server-listen)))
                                                  :name "Game Server [listen]"))
  (Log-event :info "Server started on port ~A" port)
  t)

(defun Stop ()  
  (usocket:socket-close *server-socket*)              ; stop listen
  (bordeaux-threads:destroy-thread *listen-thread*)   ; stop thread
  (log-event :info "Server stopped")
  t)

(defun Prompt ()
  (let ((command (read)))                             ; wait for input [stop]
    (if (eql command 'stop)
          (stop)
        (Prompt))))  

(defun Operation ()
  (format t "blaster-server is now working!~%")
  (format t "if you want to shutdown the server,type [stop]~%")
  (Start 2)   ; max-player:2
  (Prompt))
    
(Operation)

立ち上げるとこんな感じになる。
f:id:tomekame0126:20161223104241p:plain

そして、クライアント
client-step1.lisp

;;; The Common-Blaser :client
;;; Step1 <Game Frame> <Define Packages> <Parse-Response> 
;;; 
;; Step1 <Define Package> :client
;; -----------------------------------------------------------------------------------------------
(defpackage :client
  (:use :common-lisp)
  (:export #:Common-blaster))
(in-package :client)

;; Step1 <Parse-Response> 
;; -----------------------------------------------------------------------------------------------
(defun Parse-response (line)
  (let ((trimmed (and line  ; delete spaces, newlines, and tabs at the beginning and end of the string
		      (string-trim '(#\space #\return #\linefeed) line))))
    (if (zerop (length trimmed)) 
        (values nil nil)
        (let ((tokens (split-sequence:split-sequence #\space trimmed))) ; split character string with space
          (values (string-upcase (first tokens)) ; SAMPLE <-- sample etc 
                  (rest tokens))))))

(defvar *server-socket*)
(defvar *server-stream*)

(defun Close-socket ()
  (close *server-stream*)
  (usocket:socket-close *server-socket*))	

(defun Play-game ()         ; game main routine   
  (Close-socket))    

;; Step1 <Game-Frame> 
;; -----------------------------------------------------------------------------------------------
(defun Common-blaster (server-host player-name &key (server-port 8080))
  (format t "Connecting to server ~A:~A...~%" server-host server-port)
  (setf *server-socket* (usocket:socket-connect server-host server-port))
  (setf *server-stream* (usocket:socket-stream *server-socket*))
 
  (format *server-stream* "PLAY ~A~%" player-name)
  (finish-output *server-stream*)
  (let ((line (read-line *server-stream* nil nil))) ; read-line from blaster-server
    (multiple-value-bind (response args)        
        (Parse-response line)
        (declare (ignore args))                     ; <-- for later use!
        (cond ((null response)
               (format t "Connection error, stopping.~%"))
              ((string= response "ERROR")
              ; (progn
	        (format t "Cannot join game:~A~%" (subseq line 5))) ; <-- too many players ~%
	      ;  (Close-socket)))
              ((string= response "OK")
	       (format t "Joining game ~%")
	       (Play-game))))))
	       
;; Step1 <Define Package> :blaster-client
;; -----------------------------------------------------------------------------------------------
(defpackage :blaster-client
  (:use :common-lisp :client))
(in-package :blaster-client)

  (Common-blaster "localhost" "tomekame0126")

1人目と2人目がアクセスするとこんな感じになる。
f:id:tomekame0126:20161223105929p:plain

3人目がアクセスすると・・・・ ごめん。ムリ!
注)Warning は同じ Emacs から起動しているためのもので、関係なし。
f:id:tomekame0126:20161223110318p:plain

クライアント側を落とした後(Emacsを終了させた後)にサーバを落とすとこんな感じ。
f:id:tomekame0126:20161223110731p:plain

アクセスログはこんな感じ。
明らかに 3人目が拒否られてるよね。
f:id:tomekame0126:20161223110915p:plain

ちょっと早いクリスマスプレゼントということで!
https://www.youtube.com/watch?v=tGfpMTaIX6A


H28.12.24 ちょっと修正
"Cannot join game" 周りの (Close-socket) が必要なさげなのでカットしてみた。

Lisp Game Programming 再履修 <その8> アクセスログ プチ整形

再履修

ささくれだった気持ちで書いていたせいか、ちょっと見逃していた。
クライアントサーバ型ゲームの実験をしていたら気がついたんだけど、前回のプログラムコードではアクセスが連続するとこんな感じになる。
f:id:tomekame0126:20161216132732p:plain

醜い(見にくい)じゃん!
なので、Windows 用にプチ整形実施。

これを

;; Step2 <Access Log>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\Server-log.log")

(defun Log-event (strings &rest args)                       ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append

        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~A ~%"
                year month date hour minute second          ; output Y M D H M S message
                message)))))

こんな感じに整形!
本当にプチです。へへ!

;; Step2 <Access Log>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\Server-log.log")

(defun Log-event (strings &rest args)                       ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append

        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~A~C~C"
                year month date hour minute second          ; output Y M D H M S message
                message
                #\return #\linefeed)))))                    ; output CR/LF for windows!

注)ログファイルの名前が違うのは、実験用のプログラムコードに組み込み、名前を変更して使用しているため。

すると、ちょっとは見やすくなったかな?
でも、なんかどうも、うーん。
f:id:tomekame0126:20161216134838p:plain

~% の動作のため、Unix系OS( LF ) 、Windows( CR/LF )、Mac( CR )の違いや処理系の違いを考慮して「場合分け」して書くのは「美しく」ないよね?
ポータビリティがプログラムコードの「キモ」だと思うけど。

Lisp Game Programming 再履修 <その7> アクセスログでララバイ

再履修

会社にある様々なシステムにアクセスすると、もれなくアクセス監査ログが数か月後についてくる。
それを確認するのがマネージャの仕事とは言え、年末でチョー忙しい(加えて町内会の役員業務もね)のにちょっとひどくね?
注)電○事件を受け、労務管理には皆ピリピリしている。36協定(サブロク協定)は知ってるよね?

でもPCに向かって仕事をしていると思っていたら、日々世界を股にかけて活躍している輩がいることもまた真実。

てなことで、前回のプログラムコードに更に手を入れ、悔し紛れにアクセスログを取るコードを組み込んでみよう。

こんな感じのプログラムコードが某所に転がっていた。

;; Step2 <Access Log>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\Server-log.log")

(defun Log-event (strings &rest args)                       ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append

        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~A ~%"
                year month date hour minute second          ; output Y M D H M S message
                message)))))

ここでの注意点は &rest の存在。× (defun Log-event (strings args) ⇒ ○ (defun Log-event (strings &rest args)

&rest の使い方の再履修
http://www.geocities.jp/m_hiroi/xyzzy_lisp/abclisp06.html

format の使い方の再履修
http://www.geocities.jp/m_hiroi/xyzzy_lisp/abclisp07.html

これがないと以下のような感じのエラーになる。
サーバー側
f:id:tomekame0126:20161211195049p:plain
クライアント側
f:id:tomekame0126:20161211195200p:plain
 
ではサーバー側のコード create-server.lisp

;;; Server Test
;;; Step1 <Define Packages> <Create Server>
;;; Step2 <Access Log>
;; -----------------------------------------------------------------------------------------------  

;; Step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :server
  (:use :common-lisp :usocket)
  (:export #:create-server))
(in-package :server)

;; Step2 <Access Log>
;; -----------------------------------------------------------------------------------------------
(defparameter *log-file* "C:\\work\\Server-log.log")

(defun Log-event (strings &rest args)                       ; <-- attention! args to list 
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time (get-universal-time))          ; get time
    (declare (ignore day daylight-p zone))                  ; need not day,daylight-p,zone
    (let ((message (apply #'format nil strings args)))      ; message <-- format function
      (with-open-file (stream *log-file*                    ; open log-file 
                       :direction :output                   ; output
                       :if-does-not-exist :create           ; if not exist create
                       :if-exists :append)                  ; if exist append

        (format stream "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~A ~%"
                year month date hour minute second          ; output Y M D H M S message
                message)))))

;; Step1 <Create Server>
;; -----------------------------------------------------------------------------------------------
(defun Create-server (&key (port 4000))
  (let* ((socket (usocket:socket-listen "localhost" port))
	 (connection (usocket:socket-accept socket :element-type 'character)))

    (Log-event "Connected to port ~A" port)

    (unwind-protect 
	 (progn
	   (format (usocket:socket-stream connection) "I am tomekame0126~%")
	   (force-output (usocket:socket-stream connection)))
      (progn
	(format t "Closing sockets~%")
	(usocket:socket-close connection)
	(usocket:socket-close socket)))))

(Create-server)

そうすると、こんな感じのログファイルが出来上がる。
f:id:tomekame0126:20161211200153p:plain

ささくれだった気持ちを抑えつつ、さっさと寝るか。
https://www.youtube.com/watch?v=WZN1Dq95wGo

あっ。若い時、ボーカルの彼に似ていると言われたことがあるのが自慢です。
職場でこのことを言ったら女性陣から大ブーイングでした。(爆)

今日の格言: 心に太陽を、唇に詩を。

Lisp Game Programming 再履修 <その6> usocket 小話

再履修

その筋では有名な usocket も使う機会がなかったため、どんなものか試したときのお話。
以下にある、cl-tcpip.lisp をサーバとクライアントに分け、チョットだけ手を入れて実行してみた。

https://gist.github.com/shortsightedsid/71cf34282dfae0dd2528

サーバ側 create-server.lisp ⇒ 

;;; Server Test
;;; Step1 <Define Packages> <Create Server>
;; -----------------------------------------------------------------------------------------------  

;; Step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :server
  (:use :common-lisp :usocket)
  (:export #:create-server))
(in-package :server)

;; Step1 <Create Server>
;; -----------------------------------------------------------------------------------------------
(defun Create-server (&key (port 4000))
  (let* ((socket (usocket:socket-listen "localhost" port))
	 (connection (usocket:socket-accept socket :element-type 'character)))
    (unwind-protect 
	 (progn
	   (format (usocket:socket-stream connection) "I am tomekame0126~%")
	   (force-output (usocket:socket-stream connection)))
      (progn
	(format t "Closing sockets~%")
	(usocket:socket-close connection)
	(usocket:socket-close socket)))))

(Create-server)

クライアント側 create-client.lisp

;;; Client Test
;;; Step1 <Define Packages> <Create Client>
;; -----------------------------------------------------------------------------------------------

;; Step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :client
  (:use :common-lisp :usocket)
  (:export #:create-client))
(in-package :client)

;; Step1 <Create Client>
;; -----------------------------------------------------------------------------------------------
(defun Create-client (&key (port 4000))
  (let ((socket (usocket:socket-connect "localhost" port :element-type 'character)))
    (unwind-protect 
	 (progn
	   (usocket:wait-for-input socket)
	   (format t "~A~%" (read-line (usocket:socket-stream socket))))
      (usocket:socket-close socket))))

(Create-client)

サーバ側を起動してから、クライアント側を実行したら・・・、あれっ?
f:id:tomekame0126:20161211135626p:plain

でも、サーバ側は落ちてるよね!
f:id:tomekame0126:20161211140315p:plain

ならば、defpackage ダブル増しでどうよ。(ただの「増し」だよね?勢いで書きました!)

;;; Client Test
;;; Step1 <Define Packages> <Create Client>
;;; Step2 <Package Test>
;; -----------------------------------------------------------------------------------------------

;; Step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :client
  (:use :common-lisp :usocket)
  (:export #:create-client))
(in-package :client)

;; Step1 <Create Client>
;; -----------------------------------------------------------------------------------------------
(defun Create-client (&key (port 4000))
  (let ((socket (usocket:socket-connect "localhost" port :element-type 'character)))
    (unwind-protect 
	 (progn
	   (usocket:wait-for-input socket)
	   (format t "~A~%" (read-line (usocket:socket-stream socket))))
      (usocket:socket-close socket))))

;; Step2 <Package Test>
;; -----------------------------------------------------------------------------------------------
(defpackage :start
  (:use :common-lisp :usocket :client))
(in-package :start)

(Create-client)

f:id:tomekame0126:20161211141633p:plain

ちゃんとサーバからお返事が返ってきました。

usocket での defpackage ダブル増しの小話でした。

Lisp Game Programming 再履修 <その5> Bordeaux-threads トライアル

再履修

Bordeaux-threads を sbclrc に書き加え、ライブラリとして使える状況になっているものの、未だ使ったことがない。
ならばと無理矢理使ってみたものの、微妙な結果に終わった。

defpackage の部分に、

;; -----------------------------------------------------------------------------------------------
(defpackage :game
  (:use :common-lisp :lispbuilder-sdl)
  (:nicknames :boulderdash)
  (:export #:Common-boulderdash))

:bordeaux-threads を追加し、

;; -----------------------------------------------------------------------------------------------
(defpackage :game
  (:use :common-lisp :lispbuilder-sdl :bordeaux-threads)
  (:nicknames :boulderdash)
  (:export #:Common-boulderdash))

Draw-game の部分で、

(defun Draw-game (level player-position status)
  (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+

clear-display を外し、

(defun Draw-game (level player-position status)
 ; (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+

ここのところを、

 ;<Draw Game>
  (Draw-game level player-position status)

clear-display と draw-game をスレッドにしたものに変更してみる。

;<Draw Game>
  (sdl:clear-display sdl:*black*)

  (let ((Drawthread (bordeaux-threads:make-thread #'(lambda ()                                     ; 1 thread not split screen
                                     (Draw-game level player-position status))
                                     :name "Drawthread")))  
	      	 (bordeaux-threads:join-thread Drawthread))                                        ; wait for end thread

当然、普通に動く!

じゃあさ。画面を2つに分けて描画する準備として、1つの thread が終わったら 次の thread が動くようにしたらどうよ。
まずは、Draw-game の部分を、

(defun Draw-game (level player-position status)
 ; (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+
        do (loop for x from (- (car player-position) (floor +screen-tile-width+ 2)); player-position -8
                 for screen-x from 0

画面を2つに分けて描画するため、player の位置を基準として、x-flag = 1 の時は右側とし、x-offset は左側を描画するときのスタート位置としてプログラムコードを変更し、

(defun Draw-game (level player-position status x-flag x-offset)
 ; (sdl:clear-display sdl:*black*)
  (loop for y from  (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+
        do (loop for x from (if (= x-flag 1)
		              (- (car player-position) (floor +screen-tile-width+ 2)); player-position -8
			      (car player-position))
                 for screen-x from x-offset

先に変更したこのコードを、

;<Draw Game>
  (sdl:clear-display sdl:*black*)

  (let ((Drawthread (bordeaux-threads:make-thread #'(lambda ()                                     ; 1 thread not split screen
                                     (Draw-game level player-position status))
                                     :name "Drawthread")))  
	      	 (bordeaux-threads:join-thread Drawthread))                                        ; wait for end thread

左右を分割して描画するコードに再変更する。

 ;<Draw Game>
  (sdl:clear-display sdl:*black*)

   (let ((Drawthread1 (bordeaux-threads:make-thread #'(lambda ()                     ; split screen to left or right
			               (Draw-game level player-position status 1 0)) ; 1 -> screen left side    0 -> offset 0
                                       :name "Drawthread1")))
	 (bordeaux-threads:join-thread Drawthread1))
	    
   (let ((Drawthread2 (bordeaux-threads:make-thread #'(lambda ()
				       (Draw-game level player-position status 2 8)) ; 2 -> screen right side   8 -> offset 8
				       :name "Drawthread2")))		  
	 (bordeaux-threads:join-thread Drawthread2))		 

これまた、当然普通に動く!!

では、ここでお立合い。
下のように、1つの thread が終了する前にもう1つの thread を動かして表示したらどうよ。

;<Draw Game>
  (sdl:clear-display sdl:*black*)

  (let ((Drawthread1 (bordeaux-threads:make-thread #'(lambda ()                     ; split screen to left or right
			              (Draw-game level player-position status 1 0)) ; 1 -> screen left side    0 -> offset 0
                                      :name "Drawthread1"))  
	(Drawthread2 (bordeaux-threads:make-thread #'(lambda ()
			              (Draw-game level player-position status 2 8)) ; 2 -> screen right side   8 -> offset 8
				      :name "Drawthread2")))		  
	      	 (bordeaux-threads:join-thread Drawthread1)                         ; wait for end threads
		 (bordeaux-threads:join-thread Drawthread2))		 

動きます。ただし・・・・・・・・!
画面が「あばれる君」になります。
ニュアンス的には、empty(描画しない部分)が、ランダムな位置に点滅するようなイメージで、目がチカチカすると言えばわかるかな?
本当はこんな感じで描画されるはずが、
f:id:tomekame0126:20161125215402p:plain

こんな感じになる。(左側の wall の位置が欠けている)
f:id:tomekame0126:20161204163259p:plain

いい歳ですが、まだまだ未熟者ということで。

Lisp Game Programming 再履修 <その4>

再履修

player が動きまわったときに、rock や diamond が落ちてくるロジックは以下

;; step3 <Handle-falling-objects>
;; -----------------------------------------------------------------------------------------------
(defun handle-falling-objects (level falling-objects player-position)
  (loop for y from (- (height level) 2) downto 0                       ; y : loop height-2 -> 0
     do (loop for x below (width level)                                ; x : loop width -> 0
       when (member (aref (data level) y x) '(rock diamond))           ; object(x,y) is 'rock or 'diamond
         do (cond ((and (eql (aref (data level) (1+ y) x) 'empty)      ; and under 'empty                         ①
                        (or (/= x (car player-position))               ;   or player(x) is not object(x)
                            (/= (1+ y) (cdr player-position))          ;      player(y) is not object((y+1)
                            (aref falling-objects y x)))               ;      object(x,y) = t
                    (rotatef (aref (data level) y x) (aref (data level) (1+ y) x)) ; object(x,y)<-->object(x,y+1)
                       (setf (aref falling-objects y x) nil            ; object(x,y) = nil 
                             (aref falling-objects (1+ y) x) t))       ; object(x,y+1) = t

                  ((and (eql (aref (data level) y (1- x)) 'empty)             ; left and under left 'empty    ②
                        (eql (aref (data level) (1+ y) (1- x)) 'empty)
                        (member (aref (data level) (1+ y) x) '(rock diamond)) ; under 'rock or 'diamond
                        (or (/= (1- x) (car player-position))                 ; or player(x) is not object(x-1)
                            (and (/= (1+ y) (cdr player-position))            ;    and player(y) is not object(y+1)
                                 (/= y (cdr player-position)))))              ;        player(y) is not object(y)
                    (rotatef (aref (data level) y x) (aref (data level) y (1- x))) ; object(x,y) <--> object(x-1,y)
                      (setf (aref falling-objects y x) nil             ; object(x,y) = nil 
                            (aref falling-objects y (1- x)) t))        ; object(x-1,y) = t

                  ((and (eql (aref (data level) y (1+ x)) 'empty)              ; right and under right 'empty   ③
                        (eql (aref (data level) (1+ y) (1+ x)) 'empty)
                        (member (aref (data level) (1+ y) x) '(rock diamond))  ; and under 'rock or 'diamond
                        (or (/= (1+ x) (car player-position))                  ; or player(x) is not object(x+1)
                            (and (/= (1+ y) (cdr player-position))             ;    and player(y) is not object(y+1) 
                                 (/= y (cdr player-position)))))               ;        player(y) is not object(y)
                    (rotatef (aref (data level) y x) (aref (data level) y (1+ x))) ; object(x,y) <--> object(x+1,y)
                      (setf (aref falling-objects y x) nil             ; object(x,y) = nil
                            (aref falling-objects y (1+ x)) t))        ; object(x+1,y) = t
                  (t
                    (setf (aref falling-objects y x) nil))))))         ; otherwise object(x,y) = nil

後から見たときに、どんなロジックだったかを確認する忘備録として①、②、③の部分を残しておくことにする。

① ⇒
f:id:tomekame0126:20161203070509j:plain
② ⇒
f:id:tomekame0126:20161203070544j:plain
③ ⇒
f:id:tomekame0126:20161203070624j:plain

てな感じで、今回のプログラムコードの全体像は以下のとおり

Common-boulderdash ⇒

;;; The Common-Boulderdash
;;; Step1 <Define Packages> <Load Images>  <Game Level Class> <Exchange Char For Element>
;;;        <Map Parse> <Map Load> <Draw Game> <Initialize> <Game Frame>
;;; Step2 <Game Frame> <--- idle() + get-key-state
;;; Step3 <Handle-falling-objects> 
;; -----------------------------------------------------------------------------------------------  

;; step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :game
  (:use :common-lisp :lispbuilder-sdl)
  (:nicknames :boulderdash)
  (:export #:Common-boulderdash))
(in-package :game)

;; step1 <Load Images>
;; -----------------------------------------------------------------------------------------------  
(defvar *dirt-image* nil)
(defvar *wall-image* nil)
(defvar *rock-image* nil)
(defvar *diamond-image* nil)
(defvar *door-image* nil)
(defvar *player-image* nil)
(defvar *victory-image* nil)
(defvar *death-image* nil)

(defun Load-images ()
  (setf *dirt-image* (sdl:load-image "C:\\work\\Images\\dirt.png" :color-key(sdl:color :r 0 :g 0 :b 0))
        *wall-image* (sdl:load-image "C:\\work\\Images\\wall.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *rock-image* (sdl:load-image "C:\\work\\Images\\rock.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *diamond-image* (sdl:load-image "C:\\work\\Images\\diamond.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *door-image* (sdl:load-image "C:\\work\\Images\\door.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *player-image* (sdl:load-image "C:\\work\\Images\\player.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *victory-image* (sdl:load-image "C:\\work\\Images\\victory.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *death-image* (sdl:load-image "C:\\work\\Images\\death.png" :color-key(sdl:color :r 0 :g 0 :b 0))))

;; step1 <Game Level Class>
;; -----------------------------------------------------------------------------------------------  
(defclass level ()
  ((width :initarg :width :accessor width)
   (height :initarg :height :accessor height)
   (data :initarg :data :accessor data)
   (entry-position :initarg :entry-position :accessor entry-position)
   (exit-position :initarg :exit-position :accessor exit-position)
   (diamond-count :initarg :diamond-count :accessor diamond-count)))

;; step1 <Exchange Char For Element>
;; -----------------------------------------------------------------------------------------------  
(defun Char->element (char)
  (ecase char
    (#\space 'empty)
    (#\# 'wall)
    (#\- 'dirt)
    (#\o 'rock)
    (#\* 'diamond)
    (#\@ 'entry)
    (#\& 'exit)))

;; step1 <Map Parse>
;; -----------------------------------------------------------------------------------------------  
(defun Parse-map (lines)
  (let* ((width (length (first lines)))                                     ;  width <- length of 1 line
         (height (length lines))                                            ;  height <- number of lines 
         (data (make-array (list height width)))                            ;  data <- (height width)
         (entry nil)
         (exit nil)
         (diamond-count 0))

    (loop for y below height                                                ; decf height
          for line in lines                                                 ; line <- lines
          do (loop for x below width                                        ; decf width
                   for element = (Char->element (aref line x)) ; as -> for  ; exchange char for element
                   do (setf (aref data y x) element)                        ; data <- element
                   when (eql element 'entry)
                     do (setf entry (cons x y))                             ; set entry position (x,y)
                        (setf (aref data y x) 'empty)                       ; data <- empty
                   when (eql element 'exit)
                     do (setf exit (cons x y))                              ; set exit position (x,y) 
                   when (eql element 'diamond)
                     do (incf diamond-count)))                              ; diamond +1

    (make-instance 'level                                                   ; level instance
                   :width width
                   :height height
                   :data data
                   :entry-position entry
                   :exit-position exit
                   :diamond-count diamond-count)))                          ; all of the diamond

;; step1 <Map Load>
;; -----------------------------------------------------------------------------------------------  
(defun Load-map (level)
  (let ((filename (format nil "C:\\work\\Levels\\level~2,'0d.txt" level))) ; filename <- level01~03.txt
    (with-open-file (stream filename)                                      ; fileopen level01~03.txt  
      (loop for line = (read-line stream nil nil)   ; as -> for            ; read 1 line
            until (null line)                                              ; if true loop stop
            collect line into lines                                        ; lines <- line
            finally (return (Parse-map lines))))))                         ; goto Parse-map()

;; step1 <Draw Game>
;; -----------------------------------------------------------------------------------------------  
(defparameter +tile-size+ 32)
(defparameter +screen-tile-width+ 16)
(defparameter +screen-tile-height+ 15) 
(defparameter +screen-width+ (* +screen-tile-width+ +tile-size+))          ; screen size 512*480
(defparameter +screen-height+ (* +screen-tile-height+ +tile-size+))

(defun Draw-game (level player-position status)
  (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+
        do (loop for x from (- (car player-position) (floor +screen-tile-width+ 2)); player-position -8
                 for screen-x from 0
                 repeat +screen-tile-width+                                ; drawing range 16*15
                 when (and (< -1 x (width level))                          ; within map
                           (< -1 y (height level)))                                   
                 do (let ((element (aref (data level) y x)))               ; set char to element
                      (unless (eql element 'empty)
                        (sdl:draw-surface-at-* (case element               ; draw element except for empty
                                               (wall *wall-image*)
				               (dirt *dirt-image*)
					       (rock *rock-image*)
					       (diamond *diamond-image*)
					       (exit *door-image*))
					         (* screen-x +tile-size+)    ; position x
                                                 (* screen-y +tile-size+)))) ; position y
                 do (when (and (= x (car player-position))
                               (= y (cdr player-position)))                  ; according to player status
                      (sdl:draw-surface-at-* (ecase status                   ; draw char image 
                                             (:playing *player-image*)
                                             (:victory *victory-image*)
                                             (:dead *death-image*))
                                               (* screen-x +tile-size+)      ; position x
                                               (* screen-y +tile-size+)))))) ; position y

;; step1 <Initialize>
;; -----------------------------------------------------------------------------------------------  
(defun Initialize ()
  "graphics initialize"
  (setf (sdl:frame-rate) 60)                      ; frame rate set
  (setf *random-state* (make-random-state t))     ; random set
  (sdl:show-cursor nil))                          ; cursor not show

;; step3 <Handle-falling-objects>
;; -----------------------------------------------------------------------------------------------
(defun handle-falling-objects (level falling-objects player-position)
  (loop for y from (- (height level) 2) downto 0                       ; y : loop height-2 -> 0
     do (loop for x below (width level)                                ; x : loop width -> 0
       when (member (aref (data level) y x) '(rock diamond))           ; object(x,y) is 'rock or 'diamond
         do (cond ((and (eql (aref (data level) (1+ y) x) 'empty)      ; and under 'empty                         ①
                        (or (/= x (car player-position))               ;   or player(x) is not object(x)
                            (/= (1+ y) (cdr player-position))          ;      player(y) is not object((y+1)
                            (aref falling-objects y x)))               ;      object(x,y) = t
                    (rotatef (aref (data level) y x) (aref (data level) (1+ y) x)) ; object(x,y)<-->object(x,y+1)
                       (setf (aref falling-objects y x) nil            ; object(x,y) = nil 
                             (aref falling-objects (1+ y) x) t))       ; object(x,y+1) = t

                  ((and (eql (aref (data level) y (1- x)) 'empty)             ; left and under left 'empty    ②
                        (eql (aref (data level) (1+ y) (1- x)) 'empty)
                        (member (aref (data level) (1+ y) x) '(rock diamond)) ; under 'rock or 'diamond
                        (or (/= (1- x) (car player-position))                 ; or player(x) is not object(x-1)
                            (and (/= (1+ y) (cdr player-position))            ;    and player(y) is not object(y+1)
                                 (/= y (cdr player-position)))))              ;        player(y) is not object(y)
                    (rotatef (aref (data level) y x) (aref (data level) y (1- x))) ; object(x,y) <--> object(x-1,y)
                      (setf (aref falling-objects y x) nil             ; object(x,y) = nil 
                            (aref falling-objects y (1- x)) t))        ; object(x-1,y) = t

                  ((and (eql (aref (data level) y (1+ x)) 'empty)              ; right and under right 'empty   ③
                        (eql (aref (data level) (1+ y) (1+ x)) 'empty)
                        (member (aref (data level) (1+ y) x) '(rock diamond))  ; and under 'rock or 'diamond
                        (or (/= (1+ x) (car player-position))                  ; or player(x) is not object(x+1)
                            (and (/= (1+ y) (cdr player-position))             ;    and player(y) is not object(y+1) 
                                 (/= y (cdr player-position)))))               ;        player(y) is not object(y)
                    (rotatef (aref (data level) y x) (aref (data level) y (1+ x))) ; object(x,y) <--> object(x+1,y)
                      (setf (aref falling-objects y x) nil             ; object(x,y) = nil
                            (aref falling-objects y (1+ x)) t))        ; object(x+1,y) = t
                  (t
                    (setf (aref falling-objects y x) nil))))))         ; otherwise object(x,y) = nil

;; step1 <Game Frame>
;; -----------------------------------------------------------------------------------------------
(defun Common-boulderdash (level)
  "main routine"
  (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) ; use video and audio
    (sdl:window 512 480 :position 'center                ; size 512*480, position center
                      ; :position #(192 50)              ;               position x(192) y(50)
                        :title-caption "BOULDERDASH"
                        :icon-caption  "BOULDERDASH"  
                        :flags '(sdl:sdl-doublebuf sdl:sdl-sw-surface))

    ; <Initialize>
      (Initialize)                                       ; graphics initialize

    ; <Load Images>
      (Load-images)                                      ; load images

    ;(Load-map 01)
      (let* ((level (load-map level))
             (player-position (copy-tree (entry-position level)))
             (diamond-count 0)	     
             (falling-objects (make-array (list (height level) (width level)) :initial-element nil))
             (status :playing)
             (frame 0))

      (sdl:with-events (:poll) 	
        (:quit-event ()
          t)

	(:key-down-event (:key key)  ; do nothing
	  (case key))
 
	(:key-up-event (:key key)    ; do nothing
	  (case key)) 
	
        (:idle ()
         ; Game body
	  (when (= (mod frame 5) 0) 
	    (let((next-position (copy-tree player-position)))                        ; update next-position(x,y)
              (cond ((sdl:get-key-state :SDL-KEY-UP)    (decf (cdr next-position)))  ; up   -> y -1
                    ((sdl:get-key-state :SDL-KEY-DOWN)  (incf (cdr next-position)))  ; down -> y +1
	            ((sdl:get-key-state :SDL-KEY-LEFT)  (decf (car next-position)))  ; left -> x -1
	            ((sdl:get-key-state :SDL-KEY-RIGHT) (incf (car next-position)))  ; right-> x +1
	   	    ((sdl:get-key-state :SDL-KEY-Q)     (return-from Common-boulderdash))) ; game window close
	      (let ((element (aref (data level) (cdr next-position) (car next-position))))
                (when (eql status :playing)
                  (when (member element '(empty dirt diamond exit))
                    (setf player-position next-position)                  ; set the player to next-position
                    (when (eql element 'diamond)                          ; if there is a diamond in that position 
                      (incf diamond-count))                               ; diamond +1 
                    (unless (eql element 'exit)                           ; if not exit position ,  empty that position
                      (setf (aref (data level) (cdr next-position) (car next-position)) 'empty)))))))

	  (when (= (mod frame 5) 2)
            (handle-falling-objects level falling-objects player-position)) ; rock or diamond falls

	  (when (eql (aref (data level) (cdr player-position) (car player-position)) 'rock) ; if rock falls player-position
            (setf status :dead))                                                            ; set player status dead

	  (when (and (equal player-position (exit-position level)) ; eql <--- compare atom  'rock etc  
                     (>= diamond-count (diamond-count level)))     ; equal <--- compare list (x y) etc
            (setf status :victory))

	   ;<Draw Game>
            (Draw-game level player-position status)
            (incf frame)   ; frame +1

          (sdl:update-display))))))

(Common-boulderdash 1)

レベルを変えて遊ぶときは、(Common-boulderdash ?)の?の部分に1~3の数字を入れることは言わずもがな!


diamond を全てゲットしてゴールにたどり着いた時の画面がこちら
f:id:tomekame0126:20161203072009p:plain

途中で rock の下敷きになるとこんな感じ
f:id:tomekame0126:20161203072552p:plain

Tomi Neste tneste さん。勉強になりました。

Lisp Game Programming 再履修 <その3>

再履修

師走に入って何かと慌ただしくなる前にドンドン行ってみよう。
前回の続きから。

Draw-game 関数の特徴は、player を画面の中心に表示し、player が移動するのと連動して、周りの表示を変化させていくというもの。

では、具体的に見てみよう。

まず、y には player の現在位置から上にイメージファイル 7 つ分引いた値をセットし、これが描画の「上端」になる。
同時に、「上端」のウィンドウ内の表示位置を screen-x = 0 つまり表示するウィンドウの上枠ギリギリにセットし、高さ分(15 回)繰り返す。

また、x には player の現在位置から左にイメージファイル 8 つ分引いた値をセットし、これが描画の「左端」になる。
同じように、「左端」のウィンドウ内の表示位置を screen-y = 0 つまり表示するウィンドウの左枠ギリギリにセットし、横幅分(16 回)繰り返す。

そして、level インスタンス内にセットした width と x 、height と y を比較してウィンドウ内の範囲に描画を限定し、data(配列:22 × 40)に格納した elementを取り出す。
element が 'empty 以外であれば、そのイメージに合ったイメージファイルを描画する。

同時に、x y が player-position と同じであれば、player の現在の status に応じたイメージデータを描画するというもの。

;; step1 <Draw Game>
;; -----------------------------------------------------------------------------------------------  
(defparameter +tile-size+ 32)
(defparameter +screen-tile-width+ 16)
(defparameter +screen-tile-height+ 15) 
(defparameter +screen-width+ (* +screen-tile-width+ +tile-size+))          ; screen size 512*480
(defparameter +screen-height+ (* +screen-tile-height+ +tile-size+))

(defun Draw-game (level player-position status)
  (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+
        do (loop for x from (- (car player-position) (floor +screen-tile-width+ 2)); player-position -8
                 for screen-x from 0
                 repeat +screen-tile-width+                                ; drawing range 16*15
                 when (and (< -1 x (width level))                          ; within map
                           (< -1 y (height level)))
                 do (let ((element (aref (data level) y x)))               ; set char to element
                      (unless (eql element 'empty)
                        (sdl:draw-surface-at-* (case element               ; draw element except for empty
                                               (wall *wall-image*)
				               (dirt *dirt-image*)
					       (rock *rock-image*)
					       (diamond *diamond-image*)
					       (exit *door-image*))
					         (* screen-x +tile-size+)    ; position x
                                                 (* screen-y +tile-size+)))) ; position y
                 do (when (and (= x (car player-position))
                               (= y (cdr player-position)))                  ; according to player status
                      (sdl:draw-surface-at-* (ecase status                   ; draw char image 
                                             (:playing *player-image*)
                                             (:victory *victory-image*)
                                             (:dead *death-image*))
                                               (* screen-x +tile-size+)      ; position x
                                               (* screen-y +tile-size+)))))) ; position y

ここで注意が 1 つ。
case(ecase)で判断する際、'wall や 'dirt ではなく、単に wall や dirt として '(クオート)をつけない。この部分はノーマークだった。へへへ!

注)詳しくは、「実践 Common Lisp」 の 286 ページを参照してくださいね!本屋さんの立ち読みで調べました。
  あっ、店員さんの目があるのでちゃんと買いましたよ、もちろん。
  居酒屋での飲み会1回分くらいかな?薄い財布から「野口くん」が去っていきました。


さてと、player を移動させるためのキー入力に必要な関数を確認しておく。
今回、この関数は、(:idle () のループの中に書き込む。
Common-shooter や Common-abodagro では (:key-down-event (:key key) や (:key-up-event (:key key) の場所に配置したが、シューティングと違ってリアルタイムなキー割り込みは必要ないし、もしリアルタイムな処理が必要であれば、根本から設計の変更が必要になる。(と思うけど、自信なし。)

こんな感じ。

	(:key-down-event (:key key)  ; do nothing
	  (case key))
 
	(:key-up-event (:key key)    ; do nothing
	  (case key)) 

        (:idle ()
         ; Game body
	  (when (= (mod frame 5) 0) 
	    (let((next-position (copy-tree player-position)))                        ; update next-position(x,y)
              (cond ((sdl:get-key-state :SDL-KEY-UP)    (decf (cdr next-position)))  ; up   -> y -1
                    ((sdl:get-key-state :SDL-KEY-DOWN)  (incf (cdr next-position)))  ; down -> y +1
	            ((sdl:get-key-state :SDL-KEY-LEFT)  (decf (car next-position)))  ; left -> x -1
	            ((sdl:get-key-state :SDL-KEY-RIGHT) (incf (car next-position)))  ; right-> x +1
	   	    ((sdl:get-key-state :SDL-KEY-Q)     (return-from Common-boulderdash))) ; game window close
	      (let ((element (aref (data level) (cdr next-position) (car next-position))))
                (when (eql status :playing)
                  (when (member element '(empty dirt diamond exit))
                    (setf player-position next-position)                  ; set the player to next-position
                    (when (eql element 'diamond)                          ; if there is a diamond in that position 
                      (incf diamond-count))                               ; diamond +1 
                    (unless (eql element 'exit)                           ; if not exit position ,  empty that position
                      (setf (aref (data level) (cdr next-position) (car next-position)) 'empty)))))))

	  (when (and (equal player-position (exit-position level)) ; eql <--- compare atom  'rock etc  
                     (>= diamond-count (diamond-count level)))     ; equal <--- compare list (x y) etc
            (setf status :victory))

frame はループカウンターとして設定し、5 回毎ループしたときにキー入力の判定を行う。
playerの現在位置( x, y ) を next-position に player-positon のリストの木構造をまるっとコピーする。
それぞれのキーに応じて、next-position の ( x, y ) を増減する。q キーの場合はゲームウインドウをクローズする。
element に next-position の( x, y ) の内容('rock etc ) をセットし、player の status が :playing の時に element が 'empty 'dirt 'diamond 'exit の場合、next-positon を player-position にセットする。
その時、player の現在位置が 'diamond がある時は diamond-counter +1 とし、'exit でない場合は、next-position の場所を 'empty とする。

また、player-position と exit-posion が equal でかつ diamond-count が level インスタンスに格納された diamond-count (Parse-map で diamond-count にマップ内の 'diamond の総数をセット済)より >= の時(つまり全部取った場合)は status を :victory にセットする。

コメントアウトしていた、diamond-count の部分を復活させ、キー入力可能としたプログラムコードは以下。

stap2.lisp

;;; The Common-Boulderdash
;;; Step1 <Define Packages> <Load Images>  <Game Level Class> <Exchange Char For Element>
;;;        <Map Parse> <Map Load> <Draw Game> <Initialize> <Game Frame>
;;; Step2 <Game Frame> <--- idle() + get-key-state 
;; -----------------------------------------------------------------------------------------------  

;; step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :game
  (:use :common-lisp :lispbuilder-sdl)
  (:nicknames :boulderdash)
  (:export #:Common-boulderdash))
(in-package :game)

;; step1 <Load Images>
;; -----------------------------------------------------------------------------------------------  
(defvar *dirt-image* nil)
(defvar *wall-image* nil)
(defvar *rock-image* nil)
(defvar *diamond-image* nil)
(defvar *door-image* nil)
(defvar *player-image* nil)
(defvar *victory-image* nil)
(defvar *death-image* nil)

(defun Load-images ()
  (setf *dirt-image* (sdl:load-image "C:\\work\\Images\\dirt.png" :color-key(sdl:color :r 0 :g 0 :b 0))
        *wall-image* (sdl:load-image "C:\\work\\Images\\wall.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *rock-image* (sdl:load-image "C:\\work\\Images\\rock.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *diamond-image* (sdl:load-image "C:\\work\\Images\\diamond.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *door-image* (sdl:load-image "C:\\work\\Images\\door.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *player-image* (sdl:load-image "C:\\work\\Images\\player.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *victory-image* (sdl:load-image "C:\\work\\Images\\victory.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *death-image* (sdl:load-image "C:\\work\\Images\\death.png" :color-key(sdl:color :r 0 :g 0 :b 0))))

;; step1 <Game Level Class>
;; -----------------------------------------------------------------------------------------------  
(defclass level ()
  ((width :initarg :width :accessor width)
   (height :initarg :height :accessor height)
   (data :initarg :data :accessor data)
   (entry-position :initarg :entry-position :accessor entry-position)
   (exit-position :initarg :exit-position :accessor exit-position)
   (diamond-count :initarg :diamond-count :accessor diamond-count)))

;; step1 <Exchange Char For Element>
;; -----------------------------------------------------------------------------------------------  
(defun Char->element (char)
  (ecase char
    (#\space 'empty)
    (#\# 'wall)
    (#\- 'dirt)
    (#\o 'rock)
    (#\* 'diamond)
    (#\@ 'entry)
    (#\& 'exit)))

;; step1 <Map Parse>
;; -----------------------------------------------------------------------------------------------  
(defun Parse-map (lines)
  (let* ((width (length (first lines)))                                     ;  width <- length of 1 line
         (height (length lines))                                            ;  height <- number of lines 
         (data (make-array (list height width)))                            ;  data <- (height width)
         (entry nil)
         (exit nil)
         (diamond-count 0))

    (loop for y below height                                                ; decf height
          for line in lines                                                 ; line <- lines
          do (loop for x below width                                        ; decf width
                   for element = (Char->element (aref line x)) ; as -> for  ; exchange char for element
                   do (setf (aref data y x) element)                        ; data <- element
                   when (eql element 'entry)
                     do (setf entry (cons x y))                             ; set entry position (x,y)
                        (setf (aref data y x) 'empty)                       ; data <- empty
                   when (eql element 'exit)
                     do (setf exit (cons x y))                              ; set exit position (x,y) 
                   when (eql element 'diamond)
                     do (incf diamond-count)))                              ; diamond +1

    (make-instance 'level                                                   ; level instance
                   :width width
                   :height height
                   :data data
                   :entry-position entry
                   :exit-position exit
                   :diamond-count diamond-count)))                          ; all of the diamond

;; step1 <Map Load>
;; -----------------------------------------------------------------------------------------------  
(defun Load-map (level)
  (let ((filename (format nil "C:\\work\\Levels\\level~2,'0d.txt" level))) ; filename <- level01~03.txt
    (with-open-file (stream filename)                                      ; fileopen level01~03.txt  
      (loop for line = (read-line stream nil nil)   ; as -> for            ; read 1 line
            until (null line)                                              ; if true loop stop
            collect line into lines                                        ; lines <- line
            finally (return (Parse-map lines))))))                         ; goto Parse-map()

;; step1 <Draw Game>
;; -----------------------------------------------------------------------------------------------  
(defparameter +tile-size+ 32)
(defparameter +screen-tile-width+ 16)
(defparameter +screen-tile-height+ 15) 
(defparameter +screen-width+ (* +screen-tile-width+ +tile-size+))          ; screen size 512*480
(defparameter +screen-height+ (* +screen-tile-height+ +tile-size+))

(defun Draw-game (level player-position status)
  (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+
        do (loop for x from (- (car player-position) (floor +screen-tile-width+ 2)); player-position -8
                 for screen-x from 0
                 repeat +screen-tile-width+                                ; drawing range 16*15
                 when (and (< -1 x (width level))                          ; within map
                           (< -1 y (height level)))                                   
                 do (let ((element (aref (data level) y x)))               ; set char to element
                      (unless (eql element 'empty)
                        (sdl:draw-surface-at-* (case element               ; draw element except for empty
                                               (wall *wall-image*)
				               (dirt *dirt-image*)
					       (rock *rock-image*)
					       (diamond *diamond-image*)
					       (exit *door-image*))
					         (* screen-x +tile-size+)    ; position x
                                                 (* screen-y +tile-size+)))) ; position y
                 do (when (and (= x (car player-position))
                               (= y (cdr player-position)))                  ; according to player status
                      (sdl:draw-surface-at-* (ecase status                   ; draw char image 
                                             (:playing *player-image*)
                                             (:victory *victory-image*)
                                             (:dead *death-image*))
                                               (* screen-x +tile-size+)      ; position x
                                               (* screen-y +tile-size+)))))) ; position y

;; step1 <Initialize>
;; -----------------------------------------------------------------------------------------------  
(defun Initialize ()
  "graphics initialize"
  (setf (sdl:frame-rate) 60)                      ; frame rate set
  (setf *random-state* (make-random-state t))     ; random set
  (sdl:show-cursor nil))                          ; cursor not show

;; step1 <Game Frame>
;; -----------------------------------------------------------------------------------------------
(defun Common-boulderdash ()
  "main routine"
  (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) ; use video and audio
    (sdl:window 512 480 :position 'center                ; size 512*480, position center
                      ; :position #(192 50)              ;               position x(192) y(50)
                        :title-caption "BOULDERDASH"
                        :icon-caption  "BOULDERDASH"  
                        :flags '(sdl:sdl-doublebuf sdl:sdl-sw-surface))

    ; <Initialize>
      (Initialize)                                       ; graphics initialize

    ; <Load Images>
      (Load-images)                                      ; load images

    ;(Load-map 01)
      (let* ((level (load-map 1))
             (player-position (copy-tree (entry-position level)))
             (diamond-count 0)
             (status :playing)
             (frame 0))

      (sdl:with-events (:poll) 	
        (:quit-event ()
          t)

	(:key-down-event (:key key)  ; do nothing
	  (case key))
 
	(:key-up-event (:key key)    ; do nothing
	  (case key)) 

        (:idle ()
         ; Game body
	  (when (= (mod frame 5) 0) 
	    (let((next-position (copy-tree player-position)))                        ; update next-position(x,y)
              (cond ((sdl:get-key-state :SDL-KEY-UP)    (decf (cdr next-position)))  ; up   -> y -1
                    ((sdl:get-key-state :SDL-KEY-DOWN)  (incf (cdr next-position)))  ; down -> y +1
	            ((sdl:get-key-state :SDL-KEY-LEFT)  (decf (car next-position)))  ; left -> x -1
	            ((sdl:get-key-state :SDL-KEY-RIGHT) (incf (car next-position)))  ; right-> y +1
	   	    ((sdl:get-key-state :SDL-KEY-Q)     (return-from Common-boulderdash))) ; game window close
	      (let ((element (aref (data level) (cdr next-position) (car next-position))))
                (when (eql status :playing)
                  (when (member element '(empty dirt diamond exit))
                    (setf player-position next-position)                  ; set the player to next-position
                    (when (eql element 'diamond)                          ; if there is a diamond in that position 
                      (incf diamond-count))                               ; diamond +1 
                    (unless (eql element 'exit)                           ; if not exit position ,  empty that position
                      (setf (aref (data level) (cdr next-position) (car next-position)) 'empty)))))))

	  (when (and (equal player-position (exit-position level)) ; eql <--- compare atom  'rock etc  
                     (>= diamond-count (diamond-count level)))     ; equal <--- compare list (x y) etc
            (setf status :victory))

	   ;<Draw Game>
            (Draw-game level player-position status)
            (incf frame)   ; frame +1

          (sdl:update-display))))))

(Common-boulderdash)

OK! 動いた!
f:id:tomekame0126:20161127214539p:plain

こんだけ書いておけば、後でプログラムコードを見たときに思い出すのも早いだろうな。

Common-shooter や Common-abogadro でも詳細に書いておけばよかった!
https://github.com/tomekame0126


教訓:過去の自分は今の自分にあらず!

Lisp Game Programming 再履修 <その2>

再履修

いつも行くガソリンスタンドのバイトの兄ちゃん(工学部3年)と話しをしたら、「今、Pythonの勉強してるんすよ!」って。
「ふーん。俺、Lisp・・・・」と言いかけてやめた。
ライブラリが充実していて、一押しだそうな。

随分遠くに来ちゃった感があるな。(遠い目)と、「たそがれ感満載」でスタンドを後にした際、頭の中ではこの音楽が流れていた。

https://www.youtube.com/watch?v=g7l67VKDL8w

今時の若い人は知らないだろうなぁ。いい歌手だったなぁ。(また遠い目)
注)よくカラオケで歌いました。(爆)

いかんいかん。気を取り直して行ってみよう。少数派には少数派の美学があらぁな!

Lispbuilder-sdl を利用したゲームを作成する時のゲームフレームやイメージデータの読み込みの方法は過去にブログに掲載している。

ゲームフレーム ⇒

http://tomekame0126.hatenablog.com/entry/2014/06/26/222706

イメージデータの読み込み ⇒

http://tomekame0126.hatenablog.com/entry/2014/06/28/024155


なので、今回はこのプログラムの特徴的な関数を見てみよう。

;; step1 <Exchange Char For Element>
;; -----------------------------------------------------------------------------------------------  
(defun Char->element (char)
  (ecase char
    (#\space 'empty)
    (#\# 'wall)
    (#\- 'dirt)
    (#\o 'rock)
    (#\* 'diamond)
    (#\@ 'entry)
    (#\& 'exit)))

このコードは、読み込んだマップデータのキャラクタを実際のイメージデータの名前に合わせるためのもので、lisp では文字を扱う場合 #\ を文字前につける。(当然です)
注)¥はバックスラッシュで表示されるはず

http://www.fireproject.jp/feature/common-lisp/data-structure/string.html

順番は前後するが、次はこれ、マップのロード。

;; step1 <Map Load>
;; -----------------------------------------------------------------------------------------------  
(defun Load-map (level)
  (let ((filename (format nil "C:\\work\\Levels\\level~2,'0d.txt" level))) ; filename <- level01~03.txt
    (with-open-file (stream filename)                                      ; fileopen level01~03.txt  
      (loop for line = (read-line stream nil nil)   ; as -> for            ; read 1 line
            until (null line)                                              ; if true loop stop
            collect line into lines                                        ; lines <- line
            finally (return (Parse-map lines))))))                         ; goto Parse-map()

マップ(level01.txt level02.txt level03.txt)のどれかを level で指定 ( or 1 2 3) し、マップファイルをOPEN。
そして、1行ずつ読み込み(行の最後のnullまで)、1行ずつlinesに集めていく。

イケてるのは loop の使い方。
collect で集めた lines をそのまま return で Parse-map 関数に投げるなんざ、「 Lisp ってのはこう書くのさ! 」ってコードが語っている。職人だね。


loop ⇒
http://smpl.seesaa.net/article/29800843.html


with-open-file ⇒
http://d.hatena.ne.jp/hiro_nemu/20090425/1240667723


最後は、lines にまとめたデータを Parse-map 関数に returnして、この関数から脱出。(脱獄ではない!)

注); as -> for とあるのは、もともとは for の部分が as として書かれていたため、いつも使っている for にしただけ

そして、読み込んだ lines の構文解析

;; step1 <Map Parse>
;; -----------------------------------------------------------------------------------------------  
(defun Parse-map (lines)
  (let* ((width (length (first lines)))                                     ;  width <- length of 1 line
         (height (length lines))                                            ;  height <- number of lines 
         (data (make-array (list height width)))                            ;  data <- (height width)
         (entry nil)
         (exit nil))
       ;  (diamond-count 0))

    (loop for y below height                                                ; decf height
          for line in lines                                                 ; line <- lines
          do (loop for x below width                                        ; decf width
                   for element = (Char->element (aref line x)) ; as -> for  ; exchange char for element
                   do (setf (aref data y x) element)                        ; data <- element
                   when (eql element 'entry)
                     do (setf entry (cons x y))                             ; set entry position (x,y)
                        (setf (aref data y x) 'empty)                       ; data <- empty
                   when (eql element 'exit)
                     do (setf exit (cons x y))))                             ; set exit position (x,y) 
                 ;  when (eql element 'diamond)
                 ;    do (incf diamond-count)))                             ; diamond +1

    (make-instance 'level                                                   ; level instance
                   :width width
                   :height height
                   :data data
                   :entry-position entry
                   :exit-position exit)))
                 ;  :diamond-count diamond-count)))

  
lines リストの1行目の length(40) を width とし、リスト全体の length(22) を height に設定。
data は 22 × 40 の配列として設定。
entry(スタート)と exit(ゴール)には nil (初期値) を設定しておく。

ループでは増分の方向を負として、22 から 0 に向かって y を減らしつつ、lines から1 line 読み込む。
読み込んだら、40 から 0 に向かって x を減らしつつ、element に line の x 番目を読み込む。

element を data(22×40)にセットし、element が 'entry のときは nil に設定していた entry にその位置(コンス)をセット。
また 'exit であれば exit にその位置(コンス)をセットする。

最後は、level のインスタンス
width(横幅 : 40)、height(高さ : 22) data(配列:'empty etc)、entry(入口位置:コンス)、exit(出口位置:コンス)の情報をもつインスタンスを生成。

あっ、diamond-count は今の段階ではコメントアウトしないと SBCL が warning を出すため、うざったいから止めてます。

今日はこんな感じ。

Lisp Game Programming 再履修 <その1>

再履修

今年は町内会の役員業務に忙殺され、しばらくLispでのプログラム作成から離れていたら、「Lispってなんですか?」みたいな状態になってしまった。

年齢相応のボケも進み、気力も続かないため、過去に作成されたLispのゲームプログラムをリメイクして、老いた脳みそを活性化させることにする。

インターネットで、「良い物件」を物色していたらこんなサイトが見つかった。

http://matthieu.villeneuve.free.fr/dev/games/

小手調べに「Boulder Dash」というゲームの構造を分析してみることにするが、「PAL」というライブラリを使用しているため、「Lispbuilder-SDL」で書き直すことで、Lispプログラムの再履修としよう。

まずは、ゲームの画面のみを表示するプログラムを「Lispbuilder-SDL」でリメイクするが、「Boulder Dash」をダウンロードすると画像ファイルと以下のようなマップデータが3つ用意されている。
画像ファイルとマップファイルを読み込んで表示してみよう。

level01.txt ⇒

########################################
#------ --*-o -----o-o------- ----o----#
#-o@o------ ---------o*--o---- ----- --#
#---------- -- -----o-o--o--------o----#
#o-  ---------o------o--o----o---o-----#
#o oo---------oo--o--------o------o-o -#
#---o--o--------o-----o- o--------o-oo-#
###############################---o--o-#
#- ---o--*- --o-o----------*-o ------o-#
#--*-----o----- --------o  o--*----o---#
#---o--o-o--------------oo-o--o--------#
#- o----o--------oo -------o--o-*---- -#
#-o-- --o-  -----o-o*--*----o---o--*-o-#
#-*o--------------ooo--o--------*-----o#
#--------###############################
#  --------- ---*----o-----o---o-------#
#oo---------oo--o--------o------o-o --&#
#-o--o--------o-----o-  ----*---o-oo---#
#----o*-- --------o------o-o*------o---#
#--- -- -o--o-oo---------o-o*------o--o#
#-*----o----- --------- -o--o-o------o-#
########################################

step1.lisp

;;; The Common-Boulderdash
;;; Step1 <Define Packages> <Load Images>  <Game Level Class> <Exchange Char For Element>
;;;        <Map Parse> <Map Load> <Draw Game> <Initialize> <Game Frame>
;; -----------------------------------------------------------------------------------------------  

;; step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :game
  (:use :common-lisp :lispbuilder-sdl)
  (:nicknames :boulderdash)
  (:export #:Common-boulderdash))
(in-package :game)

;; step1 <Load Images>
;; -----------------------------------------------------------------------------------------------  
(defvar *dirt-image* nil)
(defvar *wall-image* nil)
(defvar *rock-image* nil)
(defvar *diamond-image* nil)
(defvar *door-image* nil)
(defvar *player-image* nil)
(defvar *victory-image* nil)
(defvar *death-image* nil)

(defun Load-images ()
  (setf *dirt-image* (sdl:load-image "C:\\work\\Images\\dirt.png" :color-key(sdl:color :r 0 :g 0 :b 0))
        *wall-image* (sdl:load-image "C:\\work\\Images\\wall.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *rock-image* (sdl:load-image "C:\\work\\Images\\rock.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *diamond-image* (sdl:load-image "C:\\work\\Images\\diamond.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *door-image* (sdl:load-image "C:\\work\\Images\\door.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *player-image* (sdl:load-image "C:\\work\\Images\\player.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *victory-image* (sdl:load-image "C:\\work\\Images\\victory.png":color-key(sdl:color :r 0 :g 0 :b 0))
        *death-image* (sdl:load-image "C:\\work\\Images\\death.png" :color-key(sdl:color :r 0 :g 0 :b 0))))

;; step1 <Game Level Class>
;; -----------------------------------------------------------------------------------------------  
(defclass level ()
  ((width :initarg :width :accessor width)
   (height :initarg :height :accessor height)
   (data :initarg :data :accessor data)
   (entry-position :initarg :entry-position :accessor entry-position)
   (exit-position :initarg :exit-position :accessor exit-position)))
  ; (diamond-count :initarg :diamond-count :accessor diamond-count)))

;; step1 <Exchange Char For Element>
;; -----------------------------------------------------------------------------------------------  
(defun Char->element (char)
  (ecase char
    (#\space 'empty)
    (#\# 'wall)
    (#\- 'dirt)
    (#\o 'rock)
    (#\* 'diamond)
    (#\@ 'entry)
    (#\& 'exit)))

;; step1 <Map Parse>
;; -----------------------------------------------------------------------------------------------  
(defun Parse-map (lines)
  (let* ((width (length (first lines)))                                     ;  width <- length of 1 line
         (height (length lines))                                            ;  height <- number of lines 
         (data (make-array (list height width)))                            ;  data <- (height width)
         (entry nil)
         (exit nil))
       ;  (diamond-count 0))

    (loop for y below height                                                ; decf height
          for line in lines                                                 ; line <- lines
          do (loop for x below width                                        ; decf width
                   for element = (Char->element (aref line x)) ; as -> for  ; exchange char for element
                   do (setf (aref data y x) element)                        ; data <- element
                   when (eql element 'entry)
                     do (setf entry (cons x y))                             ; set entry position (x,y)
                        (setf (aref data y x) 'empty)                       ; data <- empty
                   when (eql element 'exit)
                     do (setf exit (cons x y))))                             ; set exit position (x,y) 
                 ;  when (eql element 'diamond)
                 ;    do (incf diamond-count)))                             ; diamond +1

    (make-instance 'level                                                   ; level instance
                   :width width
                   :height height
                   :data data
                   :entry-position entry
                   :exit-position exit)))
                 ;  :diamond-count diamond-count)))

;; step1 <Map Load>
;; -----------------------------------------------------------------------------------------------  
(defun Load-map (level)
  (let ((filename (format nil "C:\\work\\Levels\\level~2,'0d.txt" level))) ; filename <- level01~03.txt
    (with-open-file (stream filename)                                      ; fileopen level01~03.txt  
      (loop for line = (read-line stream nil nil)   ; as -> for            ; read 1 line
            until (null line)                                              ; if true loop stop
            collect line into lines                                        ; lines <- line
            finally (return (Parse-map lines))))))                         ; goto Parse-map()

;; step1 <Draw Game>
;; -----------------------------------------------------------------------------------------------  
(defparameter +tile-size+ 32)
(defparameter +screen-tile-width+ 16)
(defparameter +screen-tile-height+ 15) 
(defparameter +screen-width+ (* +screen-tile-width+ +tile-size+))          ; screen size 512*480
(defparameter +screen-height+ (* +screen-tile-height+ +tile-size+))

(defun Draw-game (level player-position status)
  (sdl:clear-display sdl:*black*)
  (loop for y from (- (cdr player-position) (floor +screen-tile-height+ 2)); player-positon -7
        for screen-y from 0  
        repeat +screen-tile-height+
        do (loop for x from (- (car player-position) (floor +screen-tile-width+ 2)); player-position -8
                 for screen-x from 0
                 repeat +screen-tile-width+                                ; drawing range 16*15
                 when (and (< -1 x (width level))                          ; within map
                           (< -1 y (height level)))
                 do (let ((element (aref (data level) y x)))               ; set char to element
                      (unless (eql element 'empty)
                        (sdl:draw-surface-at-* (case element               ; draw element except for empty
                                               (wall *wall-image*)
				               (dirt *dirt-image*)
					       (rock *rock-image*)
					       (diamond *diamond-image*)
					       (exit *door-image*))
					         (* screen-x +tile-size+)    ; position x
                                                 (* screen-y +tile-size+)))) ; position y
                 do (when (and (= x (car player-position))
                               (= y (cdr player-position)))                  ; according to player status
                      (sdl:draw-surface-at-* (ecase status                   ; draw char image 
                                             (:playing *player-image*)
                                             (:victory *victory-image*)
                                             (:dead *death-image*))
                                               (* screen-x +tile-size+)      ; position x
                                               (* screen-y +tile-size+)))))) ; position y

;; step1 <Initialize>
;; -----------------------------------------------------------------------------------------------  
(defun Initialize ()
  "graphics initialize"
  (setf (sdl:frame-rate) 60)                      ; frame rate set
  (setf *random-state* (make-random-state t))     ; random set
  (sdl:show-cursor nil))                          ; cursor not show

;; step1 <Game Frame>
;; -----------------------------------------------------------------------------------------------
(defun Common-boulderdash ()
  "main routine"
  (sdl:with-init (sdl:sdl-init-video sdl:sdl-init-audio) ; use video and audio
    (sdl:window 512 480 :position 'center                ; size 512*480, position center
                      ; :position #(192 50)              ;               position x(192) y(50)
                        :title-caption "BOULDERDASH"
                        :icon-caption  "BOULDERDASH"  
                        :flags '(sdl:sdl-doublebuf sdl:sdl-sw-surface))

    ; <Initialize>
      (Initialize)                                       ; graphics initialize

    ; <Load Images>
      (Load-images)                                      ; load images

    ;(Load-map 01)
      (let* ((level (load-map 1))
             (player-position (copy-tree (entry-position level)))
           ;  (diamond-count 0)
             (status :playing))
           ;  (frame 0))

      (sdl:with-events (:poll)
        (:quit-event ()
          t)
        (:idle ()
         ; Game body
     
	  ;<Draw Game>
          (Draw-game level player-position status)

          (sdl:update-display))))))

(Common-boulderdash)

こんな感じで表示される。
ブログラム内容の確認は次回!

f:id:tomekame0126:20161125215402p:plain

Lisp Game Programming 1 and 2 <information>

先に作成した、Common-shooterやCommon-abogadroのソースコードは全てブログに掲載している。

でも、各々のSTEP毎にプログラムを試しながら動作を確認するためには、使用するファイルをまとめ

て置いておいたほうがいいだろうと考えた。

このため、GitHubにファイルをまとめ、ダウンロードできるようにしたので、もし誰か試したい人がいた

ら使ってみてください。

1.Common-shooter
https://github.com/tomekame0126/Common-shooter


2.Common-abogadro
https://github.com/tomekame0126/Common-abogadro


ちなみに、Common-abogadroでは、BGMの音声ファイルを MID・OGG・MP3 の3種類を用意したので、プロ

グラムを変更して試してみてください。


standaloneのファイルも用意したのでかなり大きいファイルのため、ダウンロードに時間がかかります。


どこかで誰かの役に立てば幸いです。へへ!

Lisp Game Programming 2 <Bug>

Road to the Programmer

0での除算でエラーが出ていることから、0の場合は除算しなければいいとの安易な対応を実施。
エラー箇所を以下のように変更

;; Step13 <Set Enemy Shot angle>
;; ---------------------------------------------------------------------------------------------
(defvar *range-x*)
(defvar *range-y*)
(defvar *distance*)

(defun Set-enemy-shot-angle (shotangle ship enemy enemy-shot)
  (let ((angle (nth shotangle (shotdata-battery-angle (aref *shot-pattern-data* (pattern-number enemy)))))
	(rotation-angle (shotdata-direction-battery-angle (aref *shot-pattern-data* (pattern-number enemy))))
   	(speed (shotdata-shotspeed (aref *shot-pattern-data* (pattern-number enemy))))
        (ship-x  (+ (x ship) (/ (width ship) 2)))                  ; ship x position
   	(ship-y  (+ (y ship) (/ (height ship) 2)))                 ; ship y position
   	(ene-shot-x (+ (x enemy-shot) (/ (width enemy-shot) 2)))   ; enemy-shot x position
   	(ene-shot-y (+ (y enemy-shot) (/ (height enemy-shot) 2)))) ; enemy-shot y position
    (case (shotdata-battery-direction (aref *shot-pattern-data* (pattern-number enemy)))
      ((0)  ; beneath
        (when (= rotation-angle 0)  ; not rotation
	     (setf (dx enemy-shot) (* (cos (degree-radian angle)) speed)) ; dx from angle list
	     (setf (dy enemy-shot) (* (sin (degree-radian angle)) speed))); dy from angle list
	(when (/= rotation-angle 0) ; rotation
	     (if (= shotangle 0)
	       (setf (angle-store enemy) (+ (angle-store enemy) rotation-angle)))	
	     (setf (dx enemy-shot) (* (cos (degree-radian (+ angle (angle-store enemy)))) speed)) ; dx from angle list
	     (setf (dy enemy-shot) (* (sin (degree-radian (+ angle (angle-store enemy)))) speed)))); dy from angle list
      ((1)  ; direction of ship
        (when (/= ship-x ene-shot-x)                                ;<------------------ Bug Fix
	  (setf *range-x* (- ship-x ene-shot-x))                    ; 
          (setf *range-y* (- ship-y ene-shot-y)))                   ;  
        (setf *distance* (sqrt (+ (* *range-x* *range-x*) (* *range-y* *range-y*))))
        (setf (first-x enemy) (* (/ *range-x* *distance*) speed))    ; x distance from enemy to ship
        (setf (first-y enemy) (* (/ *range-y* *distance*) speed))    ; y distance form enemy to ship
        (if (< (atan (/ (first-y enemy) (first-x enemy))) 0)         ; find angle in Arc tangent
          (setf (first-angle enemy) (radian-degree (+ (atan (/ (first-y enemy) (first-x enemy))) (/ pi 2))))
          (setf (first-angle enemy) (radian-degree (- (atan (/ (first-y enemy) (first-x enemy))) (/ pi 2)))))
        (when (= rotation-angle 0)  ; not rotation	  
	   (setf (dx enemy-shot) (* (cos (degree-radian (+ angle (first-angle enemy)))) speed))
	   (setf (dy enemy-shot) (* (sin (degree-radian (+ angle (first-angle enemy)))) speed)))
        (when (/= rotation-angle 0) ; rotation 
	     (if (= shotangle 0)
	       (setf (angle-store enemy) (+ (angle-store enemy) rotation-angle)))	   
	   (setf (dx enemy-shot) 
		 (* (cos (degree-radian (+ angle (first-angle enemy) (angle-store enemy)))) speed)) ; dx from angle list
	   (setf (dy enemy-shot)
		 (* (sin (degree-radian (+ angle (first-angle enemy) (angle-store enemy)))) speed))))))); dy from angle list

とりあえず、エラー出ないで遊べるじゃんって当たり前か。
ちなみに、Clozure cl 1.11でも問題なし。
根本的な設計の見直しは気が向いたらかな?

それにしても、プログラミング環境の構築や作成したプログラムの実行の際にはウィルス対策ソフトのブロックを考慮すべきですな。
ウィルス対策ソフトでそれぞれ影響の度合いは違うと思うけど、今回はこんな感じ。
※使っているウィルス対策ソフトはAVG AntiVirus Free Edition

1.Clozure cl ⇒ 以下のメッセージを出して立ち上げ不能

 Can't allocate required TLS indexes.
 First available index value was 32

 Process inferior-lisp exited abnormally with code 1

2.SBCL ⇒ lispbuilder-sdlをインストールする際に必要な、alexandriaのコンパイルエラー

気づくのが遅いっていうツッコミは無しでお願い。
また、以前に作成した実行ファイルでは途中でフリーズしたけど、Bugを修正した結果、実行ファイルもまともに動くことも確認できた。

原因がわかってスッキリさわやか○カ○―ラ。へへへ!