Verified Commit d42db270 authored by Andrew Kravchuk's avatar Andrew Kravchuk
Browse files

[WIP] initial import

parents
### https://raw.github.com/github/gitignore/0f88fa75def7ed7d96935b8630793e51953df9b0/Global/Emacs.gitignore
# -*- mode: gitignore; -*-
*~
\#*\#
/.emacs.desktop
/.emacs.desktop.lock
*.elc
auto-save-list
tramp
.\#*
# Org-mode
.org-id-locations
*_archive
# flymake-mode
*_flymake.*
# eshell files
/eshell/history
/eshell/lastdir
# elpa packages
/elpa/
# reftex files
*.rel
# AUCTeX auto folder
/auto/
# cask packages
.cask/
dist/
# Flycheck
flycheck_*.el
# server auth directory
/server/
# projectiles files
.projectile
### https://raw.github.com/github/gitignore/0f88fa75def7ed7d96935b8630793e51953df9b0/CommonLisp.gitignore
*.FASL
*.fasl
*.lisp-temp
allegro.log
#!/usr/bin/env -S sbcl --script
(load (merge-pathnames ".sbclrc" (user-homedir-pathname)))
(ql:quickload "deploy")
(push (truename ".") asdf:*central-registry*)
(asdf:make :d2clone-kit)
(asdf:defsystem :d2clone-kit
:description "Generic Diablo 2 clone game engine."
:author "Andrew Kravchuk <awkravchuk@gmail.com>"
:license "GPLv3"
:depends-on (:iterate
:make-hash
:trivial-gray-streams
:alexandria
:trivial-garbage
:cl-containers
:parse-float
:float-features
:babel
:qbase64
:chipz
:uiop
:xmls
:cl-csv
:cl-liballegro
:livesupport)
:pathname "src"
:serial t
:components ((:file "package")
(:file "config")
(:file "log")
(:file "events")
(:file "fs")
(:file "tiled")
(:file "aseprite")
(:file "systems")
(:file "point-system")
(:file "console-system")
(:file "camera-system")
(:file "map-system")
(:file "sprite-system")
(:file "player-system")
(:file "renderer")
(:file "d2clone-kit"))
;; :around-compile (lambda (next)
;; (proclaim '(optimize (debug 0)
;; (safety 0)
;; (speed 3)))
;; (funcall next))
:defsystem-depends-on (:asdf-shared-library ;; XXX : replace this GPL crap with asdf-linguist
:deploy)
:build-operation "deploy:deploy-op"
:build-pathname "d2clone"
:entry-point "d2clone-kit:main")
TODO : внутриигровая консоль с прямым доступом к REPL! sdl2-ttf, swank?.. https://github.com/astine/swank-client/blob/master/swank-description.markdown
:boot хук в deploy?..
https://github.com/borodust/bodge-nuklear/blob/master/src/example.lisp#L29 !!!
cl-nuklear в ~/Progs :|
чот у nuklear интеграция с SDL какая-то позорная, чорное окно мне рисует ((
можно попробовать чонибудь плюсовое с https://github.com/Islam0mar/cl-cxx
TODO : префабы / инстансинг для спрайтов и фрагментов карт
https://gamedev.stackexchange.com/questions/163914/how-to-design-prefabs-in-entity-component-systems
https://www.reddit.com/r/gamedev/comments/80490i/efficient_prefabsinstancing_with_ecs/
по идее, чтобы было как можно меньше промахов по кэшу, нужно хранить в одном-единственном объекте всю нужную инфу, а компоненты уже должны на этот префаб как-то ссылаться
!!! для вдохновения на архитектуренг: https://github.com/toptea/roguelike_tutorial
см. тж. https://github.com/benmoran56/esper
наверное, надо начать с ресурсной системы, чтобы префабы могли быть кейвордами/символами, напр. префаб 'zombie -> assets.zip/sprites/zombie.ase
а потом, наверное, хранить в отдельной хэшмапе префабы и копировать их при создании компонента (из соображений быстродействия)
для ресурсной системы, видимо, нужны gray streams
DONE чтение из pak-архивов через https://liballeg.org/a5docs/trunk/physfs.html (см. тж. https://icculus.org/physfs/physfstut.txt )
(заврапать в grey streams, из cl-liballegro экспортится всё, что нужно :3)
TODO : конпеляция в travis-ci, чтобы виндусовые сборки делать: https://docs.travis-ci.com/user/reference/windows/ . Ну или appveyor.com , он free for OpenSource
TODO : сконпелировать под шиндус через nuget?
TODO : готовая event system?
https://github.com/Shinmera/deeds
таск менеджер: https://github.com/Shinmera/simple-tasks
XXX use https://github.com/danlentz/manardb ?
TODO : в будущем, для ускорения CLOS: https://github.com/guicho271828/inlined-generic-function (экспериментальное!) или https://github.com/alex-gutev/static-dispatch
DONE : change event loop to that https://git.io/JeutQ ?
> I would recommend you to not use cl-sdl2's event loop at all. Instead you can integrate cbaggers/live-support into your code with a custom event loop. You can look at one of my projects for such an event loop. Most of one is in this file
TODO : физика!!!!!!!
cl-ode + ode. отд. компонент для 3d позиции, из которой будут высчитываться целочисленные 2d point.
-> получается, нужны зависимости у систем!
у не-ground тайлов на карте просто создавать физ. объектом кубик :3
ещё, кстати, видимо придётся слоям на карте придавать артрибут height, только хз, как с ним правильно рендерить.
компонент "персонаж": target - 3d позиция (или отд. компонент, и хранить его entity?)
в начале движения в ode прилагаем соотв. силу. по направлению к target. незадолго перед концом движения - противоположную силу, тип тормозим. когда с учётом эпсилон попадаем в target, убираем (зануляем).
ну или сделать через servo: http://www.ode.org/ode-latest-userguide.html#sec_7_5_0
ещё, как вариант, использовать что-то 2d-шное (box2d или chipmunk), всё равно tiled толком не поддерживает высоту.
А, не, высоту можно кое-как проэмулировать с vertical layer offset: https://discourse.mapeditor.org/t/tiled-0-14-0-released/769
однако же кодить и поддерживать эту залупу я точно заебусь, поэтому начну пока с 2d.
с сишным интерфейсом только chipmunk ._.
про плеера см. https://chipmunk-physics.net/forum/viewtopic.php?t=316
и https://chipmunk-physics.net/forum/viewtopic.php?f=1&t=3676
TODO : docstring в defcomponent?
+ убрать параметр system у макроса?, всё равно у одной системы не м/б несколько компонентов
TODO Реклама, лол. Видос с бодрой музыкой и дергающимися скринами кода с подписями:
LINGUISTIC ABSTRACTION (тут скрин из camera-system пачки вложенных with. ну или из map-system draw)
MACRO-DEFINING MACRO (тут, понятно, скрин макроса defcomponent и ещё defoptions)
(in-package :d2clone-kit)
(defmethod read-binary ((type (eql 'ase-string)) stream)
(let* ((size (read-binary 'word stream))
(string (make-array size :element-type '(unsigned-byte 8))))
(read-sequence string stream)
(babel:octets-to-string string)))
(define-binary-struct ase-binary-header
(file-size :type 'dword)
(magic :type 'word)
(frames :type 'word)
(width :type 'word)
(height :type 'word)
(color-depth :type 'word)
(flags :type 'dword)
(speed :type 'word)
(_reserved1 :type 'bytes :length 8)
(transparent-index :type 'byte)
(_reserved2 :type 'bytes :length 3)
(colors :type 'word)
(pixel-width :type 'byte)
(pixel-height :type 'byte)
(grid-x :type 'word)
(grid-y :type 'word)
(grid-width :type 'word)
(grid-height :type 'word)
(_reserved3 :type 'bytes :length 84))
(define-binary-struct ase-binary-frame
(bytes :type 'dword)
(magic :type 'word)
(old-chunks :type 'word)
(duration :type 'word)
(_reserved1 :type 'bytes :length 2)
(new-chunks :type 'dword))
(define-binary-struct ase-binary-chunk-header
(size :type 'dword)
(type :type 'word))
(defun ase-binary-frame-chunks (frame)
(if (zerop (ase-binary-frame-new-chunks frame))
(ase-binary-frame-old-chunks frame)
(ase-binary-frame-new-chunks frame)))
(defstruct ase-chunk
(type nil :type symbol :read-only t))
(defstruct (ase-layer-chunk (:include ase-chunk (type 'layer)))
(id 0 :type fixnum)
(name "" :type string))
(defstruct ase-tag
(from 0 :type fixnum)
(to 0 :type fixnum)
(name "" :type string))
(defstruct (ase-tags-chunk (:include ase-chunk (type 'tags)))
(tags nil :type (vector ase-tag)))
(defstruct (ase-cel-chunk (:include ase-chunk (type 'cel)))
(layer-id 0 :type fixnum)
(data nil :type (vector (unsigned-byte 8))))
(defstruct ase-frame
(duration 0 :type fixnum)
(chunks nil :type (vector (or ase-chunk null))))
(defstruct ase-file
(width 0 :type fixnum)
(height 0 :type fixnum)
(speed 0 :type fixnum) ;; ms between frame
(frames nil :type (vector ase-frame)))
(defgeneric read-chunk (type stream))
(defvar *layer-id*)
(declaim (type fixnum *layer-id*))
(defmethod read-chunk ((type (eql #x2004)) stream)
(read-binary 'word stream) ;; flags
(let ((type (read-binary 'word stream)))
(declare (type fixnum type))
(unless (zerop type)
(error "group layers not supported")))
(read-binary 'word stream) ;; child level
(read-binary 'word stream) ;; default width
(read-binary 'word stream) ;; default height
(let ((blend-mode (read-binary 'word stream)))
(declare (type fixnum blend-mode))
(unless (zerop blend-mode)
(error "layer blend modes not supported")))
(read-binary 'byte stream) ;; opacity
(read-binary 3 stream)
(let ((name (read-binary 'ase-string stream)))
(make-ase-layer-chunk
:id (prog1 *layer-id* (incf *layer-id*))
:name name)))
(declaim (ftype (function (virtual-binary-stream fixnum) (vector (unsigned-byte 8))) pass))
(defun pass (binary-stream size)
(declare (ignore size))
(let* ((buffer (slot-value binary-stream 'buffer))
(position (slot-value binary-stream 'position))
(stream-length (length (the vector buffer)))
(stream-offset (the fixnum position))
(input-size (- stream-length stream-offset)))
(make-array
input-size
:element-type '(unsigned-byte 8)
:displaced-to buffer
:displaced-index-offset stream-offset)))
(defun decompress (binary-stream size)
(let ((data (pass binary-stream size)))
(chipz:decompress
nil 'chipz:zlib
(make-array
(length data)
:element-type '(unsigned-byte 8)
:initial-contents data)
:buffer-size size)))
(deftype sprite-dimension ()
`(integer 0 ,(isqrt (truncate most-positive-fixnum 4))))
(defmethod read-chunk ((type (eql #x2005)) stream)
(let ((layer-id (read-binary 'word stream)))
(read-binary 'word stream) ;; X position
(read-binary 'word stream) ;; Y position
(read-binary 'byte stream) ;; opacity
(let ((process
(ecase (read-binary 'word stream)
(0 #'pass)
(1 (error "linked cels not supported"))
(2 #'decompress))))
(read-binary 7 stream)
(let ((width (the sprite-dimension (read-binary 'word stream)))
(height (the sprite-dimension (read-binary 'word stream))))
(make-ase-cel-chunk
:layer-id layer-id
:data (funcall process stream (* 4 width height)))))))
(defmethod read-chunk ((type (eql #x2018)) stream)
(let* ((num-tags (read-binary 'word stream))
(tags (make-array num-tags)))
(read-binary 8 stream)
(dotimes (tag-index num-tags)
(let ((from (read-binary 'word stream))
(to (read-binary 'word stream))
(direction (read-binary 'byte stream))
(dummy (read-binary 8 stream))
(color (read-binary 3 stream))
(extra (read-binary 'byte stream))
(name (read-binary 'ase-string stream)))
(declare (ignore direction dummy color extra))
(setf (elt tags tag-index)
(make-ase-tag :from from :to to :name name))))
(make-ase-tags-chunk :tags tags)))
(defmethod read-chunk (type stream)
(declare (ignore type stream))
nil)
(defconstant +header-magic+ #xA5E0)
(defconstant +frame-magic+ #xF1FA)
(defun load-aseprite (stream)
(let* ((*layer-id* 0)
(header (read-binary 'ase-binary-header stream)))
(unless (= (ase-binary-header-magic header) +header-magic+)
(error "Invalid ASE file"))
(unless (= (ase-binary-header-color-depth header) 32)
(error "Only RGBA color mode supported"))
(make-ase-file
:width (ase-binary-header-width header)
:height (ase-binary-header-height header)
:speed (ase-binary-header-speed header)
:frames
(loop
with frames-count = (ase-binary-header-frames header)
with frames = (make-array frames-count)
for frame-index below frames-count
for frame = (let ((binary-frame (read-binary 'ase-binary-frame stream)))
(unless (= (ase-binary-frame-magic binary-frame) +frame-magic+)
(error "Invalid ASE frame"))
(make-ase-frame
:duration (ase-binary-frame-duration binary-frame)
:chunks
(loop
with chunks-count = (ase-binary-frame-chunks binary-frame)
with chunks = (make-array chunks-count)
for chunk-index below chunks-count
for chunk = (let ((chunk-header (read-binary
'ase-binary-chunk-header stream)))
(read-chunk
(ase-binary-chunk-header-type chunk-header)
(make-instance
'virtual-binary-stream
:buffer
(read-binary
(the fixnum
(- (ase-binary-chunk-header-size chunk-header)
6 ;; sizeof chunk-header
))
stream))))
do (setf (elt chunks chunk-index) chunk)
finally (return chunks))))
do (setf (elt frames frame-index) frame)
finally (return frames)))))
(in-package :d2clone-kit)
(defclass camera-system (system)
((name :initform 'camera)
(entity :initform nil)))
(defcomponent camera camera)
(defmethod system-load ((system camera-system))
(declare (ignore system))
t)
(defmethod system-quit ((system camera-system))
(setf (slot-value system 'entity) -1)
t)
(defmethod make-component ((system camera-system) entity &rest parameters)
(declare (ignore parameters))
(setf (slot-value system 'entity) entity)
nil)
(defmacro with-camera (bindings &rest body)
(with-gensyms (camera-entity)
`(let ((,camera-entity (slot-value (system-ref 'camera) 'entity)))
(with-point ,camera-entity ,bindings
,@body))))
(declaim
(inline absolute->screen)
(ftype (function (coordinate coordinate) (values fixnum fixnum)) absolute->screen))
(defun absolute->screen (x y)
(with-config-options (display-width display-height)
(with-camera (camera-x camera-y)
(values
(+ (- x camera-x) (ceiling display-width 2))
(+ (- y camera-y) (ceiling display-height 2))))))
(declaim
(inline visiblep)
(ftype (function (fixnum fixnum &optional fixnum) boolean) visiblep))
(defun visiblep (x y &optional (delta 0))
(with-config-options (display-width display-height)
(with-camera (camera-x camera-y)
(and
(<= (abs (- camera-x x))
(+ (ceiling display-width 2) delta))
(<= (abs (- camera-y y))
(+ (ceiling display-height 2) delta))))))
(declaim
(inline range-visible-p)
(ftype (function (fixnum fixnum fixnum fixnum) boolean) range-visible-p))
(defun range-visible-p (x y width height)
(with-config-options (display-width display-height)
(with-camera (camera-x camera-y)
(let ((relative-x (- camera-x x))
(relative-y (- camera-y y))
(half-screen-width (ceiling display-width 2))
(half-screen-height (ceiling display-height 2)))
(and
(>= relative-x (- half-screen-width))
(< relative-x (+ width half-screen-width))
(>= relative-y (- half-screen-height))
(< relative-y (+ height half-screen-height)))))))
(in-package :d2clone-kit)
;; TODO : макрос defsetting (ну или там defconfig), который будет заводить special переменные?
;; ну иди symbol-macrolet . плюс ещё типы дефайнить!
(defvar *config*)
(defun init-config ()
(setf *config* (al:load-config-file "config.ini"))
(when (cffi:null-pointer-p *config*)
(setf *config* (al:create-config))))
(declaim (inline save-config))
(defun save-config ()
(al:save-config-file "config.ini" *config*))
(declaim
(inline (setf config))
(ftype (function (t (or keyword null) keyword) t) (setf config)))
(defun (setf config) (value section key)
(al:set-config-value
*config* (string (or section :||)) (string key)
(write-to-string value))
(save-config)
value)
(declaim
(inline config)
(ftype (function ((or keyword null) keyword &optional t) t) config))
(defun config (section key &optional default)
(if-let (value (al:get-config-value
*config* (string (or section :||)) (string key)))
(read-from-string value)
(setf (config section key) default)))
(defun close-config ()
(save-config)
(al:destroy-config *config*)
(setf *config* nil))
(defmacro defoptions (&rest options)
(let* ((section-names (mapcar #'car options))
(key-names (mapcar #'cadr options))
(option-names (mapcar #'(lambda (s k) (symbolicate s :- k))
section-names key-names))
(option-types (mapcar #'(lambda (o) (getf o :type)) options))
(option-defaults (mapcar #'(lambda (o) (getf o :default)) options))
(macrolet-clauses (mapcar
#'(lambda (o s k type d)
`(,o . ((the ,type
(config ,(make-keyword s) ,(make-keyword k) ,d)))))
option-names section-names key-names
option-types option-defaults)))
`(defmacro with-config-options (options &rest body)
(let ((macrolet-clauses
(remove-if-not
#'(lambda (c) (find (car c) options))
'(,@macrolet-clauses))))
`(symbol-macrolet (,@macrolet-clauses)
,@body)))))
(defoptions
(display width :type fixnum :default 800)
(display height :type fixnum :default 600)
(display windowed :type boolean :default t)
(display vsync :type boolean :default nil)
(display fps :type boolean :default nil)
(display multisampling :type fixnum :default 0)
)
(in-package :d2clone-kit)
(defclass console-system (system)
((name :initform 'console)
(shownp
:initform nil
:accessor shownp)
(context
:initform nil)
))
(defmethod system-load ((system console-system))
;; (setf (slot-value sys 'context) (nk:make-context))
t)
(defmethod system-draw ((system console-system) renderer) ;; gui arg?
(when (shownp sys)
;; (with-slots (context) sys
;; (nk:render-nuklear
;; ))
))
(defmethod system-update ((system console-system) dt)
(when (shownp sys)
;; (with-slots (context) sys
;; (claw:c-with ((rect (:struct %nk:rect)))
;; (unless (zerop
;; (%nk:begin context "console" (%nk:rect (rect &) 50 50 200 200)
;; (nk:panel-mask :border :scroll-auto-hide)))
;; (%nk:layout-row-static nk-context 30 80 1)
;; (%nk:button-label nk-context "button")
;; ;; инпут - nk_edit_string
;; ;; метка - nk_label
;; ;; текст - nk_edit_buffer ?..
;; ;; NK_EDIT_NO_CURSOR , не NK_EDIT_SELECTABLE, не NK_EDIT_CLIPBOARD
;; ;; NK_EDIT_READ_ONLY
;; )
;; )
)
)
(defmethod system-event ((system console-system) event-type event)
;; (when (and (keyboard-event-downp evt)
;; (= (keyboard-event-keycode evt) sdl2-ffi:+sdlk-backquote+))
;; (setf (shownp sys) (not (shownp sys))))
)
(in-package :d2clone-kit)
(defunl handle-event (event)
(let ((event-type
(cffi:foreign-slot-value event '(:union al:event) 'al::type)))
(if (eq event-type :display-close)
(broadcast-quit)
(broadcast-event event-type event))))
(defunl game-loop (event-queue &key (repl-update-interval 0.3))
;; TODO : init systems DSL style
(make-instance 'point-system)
(let ((camera-entity (make-entity)))
(make-component (make-instance 'camera-system) camera-entity)
(make-component (system-ref 'point) camera-entity 0 0))
(let ((map-entity (