Lisp Game Programming 2 <Stage 1>

mapchipが１つだとスクロールが簡単に実現できた。

http://tomekame0126.hatenablog.com/entry/2014/07/03/055411

でも、地図のようなものはmapchipの組み合わせでできているため、Lispではどのようにスクロールを実現（市販のゲームのようなイメージ）できるか試してみる。

たぶん、mapchipにidを振っているから、idのリストを作って、そのリストを順番に読み込むパターンでいけるはず（と思う）。

まずは、前に作ったプログラムを応用し、お世話になったサイトのデータ（samplecg.bmp）を借用。

１枚に複数の画像がてんこ盛りの画像データを、キャラクターの大きさに合わせてidを振るように設定。

（すみません、画像データを使わせていただきます！）

http://mclass13.web.fc2.com/hsplecture/enemap2.htm

てなことで、一気にこんな感じのプログラムを２つ。

ab-stage1.lisp ⇒

;;;; The Common-Abogadro
;;; step1 <Game Frame> <Sprite Sheets> <Define Package> <Macro> <Character Object> <Draw>
;;; <Initialize> <Key State> <Game Field>

;; step1 <Sprite Sheets>
;; -----------------------------------------------------------------------------------------------
(load "C:\\work\\sprite-sheets.lisp")

;; step1 <Define Package>
;; -----------------------------------------------------------------------------------------------
(defpackage :game
(:use :common-lisp :lispbuilder-sdl :sprite-sheets)
(:nicknames :shooting)
(:export Common-abogadro))
(in-package :game)

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

;;step1 <Character Object>
;; -----------------------------------------------------------------------------------------------
(define-class object ()
(id x y width height) 0)
; id graphic id in image
; x upper left corner
; y upper left corner
; width from upper left corner
; height from upper left corner

(define-class entity (object)
(dx dy explode-cnt state) 0)
; dx x direction speed
; dy y direction speed
; explode-cnt explosion counter(wait)
; state ship 0:dead 1:alive 2:explosion 3:revival
; enemy 0:dead 1:alive 2:damage 3:explosion

;; step1 <Draw Images>
;; -----------------------------------------------------------------------------------------------
(defun Draw (obj)
"character draw"
(sdl:draw-surface-at-* *images* (x obj) (y obj) :cell (id obj)))

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

;; step1 <Update Key State>
;; -----------------------------------------------------------------------------------------------
(define-class keystate ()
(right left up down z lshift) nil)
; right right-key
; left left-key
; up up-key
; down down-key
; z z-key
; lshift lshift-key

(defgeneric Update-keystate (key boolean keystate))
(defmethod Update-keystate (key boolean keystate)
(cond ((sdl:key= key :SDL-KEY-RIGHT) (setf (right keystate) boolean))
((sdl:key= key :SDL-KEY-LEFT) (setf (left keystate) boolean))
((sdl:key= key :SDL-KEY-UP) (setf (up keystate) boolean))
((sdl:key= key :SDL-KEY-DOWN) (setf (down keystate) boolean))
((sdl:key= key :SDL-KEY-Z) (setf (z keystate) boolean))
((sdl:key= key :SDL-KEY-LSHIFT) (setf (lshift keystate) boolean))))

;; step 1 <Move Ship>
;; -----------------------------------------------------------------------------------------------
(defgeneric Move-ship (ship keystate))
(defmethod Move-ship (ship keystate)
(when (or (= (state ship) 1) ; When ship is alive or revival
(= (state ship) 3))
(cond ((right keystate) (progn (incf (x ship) (dx ship)) ; set ship id 1 (right turn)
(setf (id ship) 1)))
((left keystate) (progn (decf (x ship) (dx ship)) ; set ship id 2 (left turn)
(setf (id ship) 2)))
((up keystate) (decf (y ship) (dy ship)))
((down keystate) (incf (y ship) (dy ship))))))

;; step1 <Fix Ship Position>
;; -----------------------------------------------------------------------------------------------
(define-class game-field ()
(field-x field-y width height) 0)
; field-x game field upper left x
; field-y game field upper left y
; width game field width
; height game field height

(defgeneric Fix-ship-position (ship game-field))
(defmethod Fix-ship-position (ship game-field)
"ship always inside game-field"
(when (< (x ship) (field-x game-field)) (setf (x ship) (field-x game-field)))
(when (< (y ship) (field-y game-field)) (setf (y ship) (field-y game-field)))
(when (> (x ship) (- (width game-field) 32)) (setf (x ship) (- (width game-field) 32)))
(when (> (y ship) (- (height game-field) 32)) (setf (y ship) (- (height game-field) 32))))

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

; <Initialize>
(Initialize) ; graphics initialize

; <Charactor Object>
(let ((ship (make-instance 'entity :id 0 :x 304 :y 416 :width 32 :height 32 :dx 4 :dy 4 :state 1))
(keystate (make-instance 'keystate))
(game-field (make-instance 'game-field :field-x 160 :field-y 16 :width 480 :height 464)))

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

; <Update Key State>
(:key-down-event (:key key)
(if (sdl:key= key :SDL-KEY-ESCAPE)
(sdl:push-quit-event)
(Update-keystate key t keystate)))
(:key-up-event (:key key)
(Update-keystate key nil keystate)
(setf (id ship) 0)) ; set ship id 0 (normal form)

(:idle ()
; <Clear Display>
(sdl:clear-display sdl:*black*)

; <Move Ship>
(Move-ship ship keystate)

; <Fix Ship Position>
(Fix-ship-position ship game-field)

; <Draw Images>
(when (= (state ship) 1)
(Draw ship)) ; draw ship

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

sprite-sheets.lisp ⇒

(defpackage :sprite-sheets
　(:use :common-lisp)
　(:export #:*images*
#:Set-imageid))

(in-package :sprite-sheets)

;; step1 <Sprite Sheets>
;; -----------------------------------------------------------------------------------------------
(defparameter *path-samplecg* "C:\\work\\graphics\\samplecg.bmp") ; set path to samplecg.bmp
(defvar *images*)
(defvar *imagecells*)

(defun Set-imageid ()
　"load image data and set id"
　(setf *images* (sdl:load-image *path-samplecg* :color-key(sdl:color :r 0 :g 0 :b 0)))
　(let* ((temp1cells (append (loop for x from 0 to 64 by 32 ;id 0 - 2
　　　　　　　　　　collect (list x 0 32 32))))
　　　(temp2cells (loop for y from 0 to 16 by 16 ;id 3 - 6
　　　　　　　　　　append (loop for x from 96 to 112 by 16
　　　　　　　　　　 collect (list x y 16 16))))
　　　(temp3cells (append (loop for x from 128 to 224 by 32 ;id 7 -10
　　　　　　　　　 collect (list x 0 32 32))))
　　　(temp4cells (append (loop for x from 0 to 224 by 32 ;id 11-18
　　　　　　　　　 collect (list x 32 32 32))))
　　　(temp5cells (append (loop for x from 0 to 224 by 32 ;id 19-26
　　　　　　　　　 collect (list x 64 32 64))))
　　　 (temp6cells (loop for y from 128 to 384 by 64 ;id 27-46
　　　　　　　　　 append (loop for x from 0 to 192 by 64
　　　　　　　　　　 collect (list x y 64 64))))
　　　(temp7cells (append (loop for x from 0 to 128 by 64 ;id 47-49
　　　　　　　　　 collect (list x 448 64 32))))
　　　(temp8cells (append (loop for x from 0 to 96 by 32 ;id 50-53
　　　　　　　　　 collect (list x 480 32 32 ))))
　　　(temp9cells (loop for y from 0 to 192 by 64 ;id 54-69
　　　　　　　　　　append (loop for x from 256 to 448 by 64
　　　　　　　　　　　collect (list x y 64 64))))
　　　(temp10cells (loop for y from 256 to 384 by 96 ;id 70-75
　　　　　　　　　　append (loop for x from 256 to 448 by 96
　　　　　　　　　　　collect (list x y 96 96))))
　　　(temp11cells (append (loop for x from 192 to 384 by 64 ;id 76-79
　　　　　　　　　　　collect (list x 448 64 64))))
　　　(temp12cells (loop for y from 448 to 480 by 32 ;id 80-85
　　　　　　　　　　append (loop for x from 448 to 512 by 32
　　　　　　　　　　　collect (list x y 32 32)))))
　　　(setf *imagecells* (append temp1cells temp2cells temp3cells temp4cells
temp5cells temp6cells temp7cells temp8cells
temp9cells temp10cells temp11cells temp12cells)))
　(setf (sdl:cells *images*) *imagecells*))