aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Pouar Dragon <pouar@pouar.net>2020-10-22 14:39:14 -0500
committerGravatar Pouar Dragon <pouar@pouar.net>2020-10-22 14:39:14 -0500
commit451ea0a099e7c6530ce0929643b2baf0440d2bf5 (patch)
tree2e4e7dab8ac0303d5de257475fc5b44d6ba10872
parentfix warning (diff)
figured out how to handle this
-rw-r--r--core/libexec/classes.lisp21
-rw-r--r--core/libexec/declares.lisp2
-rw-r--r--core/libexec/functions.lisp90
-rw-r--r--core/libexec/generic-functions.lisp13
-rw-r--r--core/libexec/mcclim.lisp2
-rw-r--r--core/libexec/methods.lisp4
-rw-r--r--core/util.lisp6
-rw-r--r--data/enemies/raccoon-bandits.lisp4
-rw-r--r--data/epilog/items.lisp7
-rw-r--r--data/moves/regular.lisp6
-rw-r--r--data/status-conditions/abdl.lisp8
-rw-r--r--data/status-conditions/pokemon.lisp2
-rw-r--r--packages.lisp6
13 files changed, 113 insertions, 58 deletions
diff --git a/core/libexec/classes.lisp b/core/libexec/classes.lisp
index cde836e..29a9e53 100644
--- a/core/libexec/classes.lisp
+++ b/core/libexec/classes.lisp
@@ -147,7 +147,7 @@
(status-conditions
:initarg :status-conditions
:initform ()
- :accessor status-conditions-of
+ :accessor %status-conditions-of
:type list
:documentation "Status conditions of the character"))
(:documentation "Base class for the characters in the game"))
@@ -280,14 +280,11 @@
:initform nil
:type boolean
:accessor curablep
- :documentation "Whether items or moves that cure statuses cure this")
- (persistent
- :initarg :persistent
- :initform nil
- :type boolean
- :accessor persistentp
- :documentation "Whether this lasts outside battle or not"))
+ :documentation "Whether items or moves that cure statuses cure this"))
(:documentation "Base class for all the status conditions"))
+(defclass persistent-status-condition (status-condition)
+ ()
+ (:documentation "Status condition that lasts outside of battle"))
(defclass move (yadfa-class element-type-mixin)
((name
:initarg :name
@@ -1091,7 +1088,13 @@
:initform ()
:type list
:accessor fainted-of
- :documentation "Characters that have fainted in battle, used so the \"X has fainted\" messages don't appear repeatedly"))
+ :documentation "Characters that have fainted in battle, used so the \"X has fainted\" messages don't appear repeatedly")
+ (status-conditions
+ :initarg :status-conditions
+ :initform (make-hash-table :test 'eq)
+ :type hash-table
+ :accessor %status-conditions-of
+ :documentation #.(f:fmt nil "Hash table of " (ref status-condition :class) " indexed by " (ref base-character :class) ". These only last until the battle ends")))
(:documentation "Class that contains the information about the battle"))
(defmethod initialize-instance :after
((c battle) &key &allow-other-keys)
diff --git a/core/libexec/declares.lisp b/core/libexec/declares.lisp
index bfbf49c..c7246dc 100644
--- a/core/libexec/declares.lisp
+++ b/core/libexec/declares.lisp
@@ -5,7 +5,7 @@
(ftype (function (integer list) (values boolean &optional)) list-length-<= list-length-< list-length-> list-length->=)
(ftype (function ((or list symbol)) (values boolean &optional)) finished-events unfinished-events)
(ftype (function (closed-bottoms) (values real &optional)) get-diaper-expansion)
- (ftype (function (symbol base-character &key (:duration (or null unsigned-byte)) (:test (or symbol function)) (:key (or symbol function)))
+ (ftype (function (t base-character &key (:duration (or null unsigned-byte)) (:test (or symbol function)) (:key (or symbol function)))
(values (eql t) &optional))
set-status-condition)
(ftype (function ((or symbol list)) (values list &optional)) trigger-event)
diff --git a/core/libexec/functions.lisp b/core/libexec/functions.lisp
index fa218dc..6f8fa32 100644
--- a/core/libexec/functions.lisp
+++ b/core/libexec/functions.lisp
@@ -211,22 +211,63 @@
(remf (getf (direction-attributes-of (get-zone position)) direction) attribute)
(unless (getf (direction-attributes-of (get-zone position)) direction)
(remf (direction-attributes-of (get-zone position)) direction)))
-(defun set-status-condition (status-condition user &key duration test key
- &aux (status-conditions (iter (for i in (status-conditions-of user))
- (when (eq (type-of i) status-condition)
- (collect i))))
- (i (if (or (eq (accumulative-of (make-instance status-condition)) t)
- (list-length-> (accumulative-of (make-instance status-condition)) status-conditions))
- (make-instance status-condition)
- (car (s:dsu-sort status-conditions (lambda (a b)
- (cond ((eq b t)
- nil)
- ((eq a t)
- t)
- (t (< a b))))
- :key #'duration-of))))
- (duration (or duration (duration-of (make-instance status-condition)))))
- (pushnew i (status-conditions-of user) :test (or test #'eql) :key (or key #'identity))
+(defunassert status-conditions (user)
+ (user base-character)
+ (append (when *battle* (gethash user (%status-conditions-of *battle*)))
+ (%status-conditions-of user)))
+(defunassert deletef-status-conditions (item user &key (test nil testp) (key nil keyp))
+ (user base-character)
+ (let ((key (if keyp key 'identity))
+ (test (if testp test 'eql)))
+ (when *battle*
+ (a:deletef (gethash user (%status-conditions-of *battle*)) item
+ :key key
+ :test test))
+ (a:deletef (%status-conditions-of user) item
+ :key key
+ :test test)))
+(define-compiler-macro deletef-status-conditions (item user &key (test nil testp) (key nil keyp))
+ (let ((args `(,@(when keyp
+ `(:key ,key))
+ ,@(when testp
+ `(:test ,test)))))
+ `(progn
+ (when *battle*
+ (a:deletef (gethash ,user (%status-conditions-of *battle*)) ,item ,@args))
+ (a:deletef (%status-conditions-of ,user) ,item ,@args))))
+(defunassert deletef-status-conditions-if (test user &key (key nil keyp))
+ (user base-character)
+ (let ((key (if keyp key 'identity)))
+ (when *battle*
+ (deletef-if (gethash user (%status-conditions-of *battle*)) test
+ :key key))
+ (deletef-if (%status-conditions-of user) test
+ :key key)))
+(define-compiler-macro deletef-status-conditions-if (user test &key (key nil keyp))
+ (let ((args `(,@(when keyp
+ `(:key ,key)))))
+ `(progn
+ (when *battle*
+ (deletef-if (gethash ,user (%status-conditions-of *battle*)) ,test ,@args))
+ (deletef-if (%status-conditions-of ,user) ,test ,@args))))
+(defunassert set-status-condition (status-condition user
+ &key duration (test nil testp) (key nil keyp)
+ &aux (status-conditions (status-conditions user))
+ (i (if (or (eq (accumulative-of (make-instance status-condition)) t)
+ (list-length-> (accumulative-of (make-instance status-condition)) status-conditions))
+ (make-instance status-condition)
+ (car (s:dsu-sort status-conditions (lambda (a b)
+ (cond ((eq b t)
+ nil)
+ ((eq a t)
+ t)
+ (t (< a b))))
+ :key #'duration-of))))
+ (duration (or duration (duration-of (make-instance status-condition)))))
+ (user base-character i status-condition status-conditions list)
+ (pushnew i (effective-status-conditions i user)
+ :key (if keyp key 'identity)
+ :test (if testp test 'eql))
(when (and (not (eq (duration-of i) t)) (< (duration-of i) duration))
(setf (duration-of i) duration))
t)
@@ -628,14 +669,14 @@
"Returns true if @var{CHARACTER} fainted and false if not, but only if in @var{BATTLE}, otherwise unspecified"
(declare (type base-character character)
(type boolean battle))
- (iter (for i in (status-conditions-of character))
+ (iter (for i in (status-conditions character))
(when (or (eq (duration-of i) t) (> (duration-of i) 0))
(condition-script character i battle)
(when (typep (duration-of i) 'real)
(decf (duration-of i))))
- (removef-if (status-conditions-of character)
- (lambda (a) (and (not (eq a t)) (<= a 0)))
- :key #'duration-of))
+ (deletef-status-conditions-if character
+ (lambda (a) (and (not (eq a t)) (<= a 0)))
+ :key #'duration-of))
(run-equip-effects character)
(if battle
(let ((faintedp (handle-faint character)))
@@ -1389,7 +1430,7 @@
(user base-character)
(iter
(with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
- (for i in (status-conditions-of user))
+ (for i in (status-conditions user))
(iter
(for (a b) on (stat-delta-of i) by #'cddr)
(incf (getf j a) b))
@@ -1398,7 +1439,7 @@
(user base-character)
(iter
(with j = (list :health 1 :attack 1 :defense 1 :energy 1 :speed 1))
- (for i in (status-conditions-of user))
+ (for i in (status-conditions user))
(iter
(for (a b) on (stat-multiplier-of i) by #'cddr)
(declare (ignorable b))
@@ -1567,10 +1608,7 @@
;; and changing the game's logic and dialog to make it make sense is too complicated,
;; so fuck it, characters don't faint outside of battle
(when (<= (health-of character) 0)
- (setf (health-of character) (calculate-stat character :health)))
- (setf (status-conditions-of character) (iter (for status-condition in (status-conditions-of character))
- (when (persistentp status-condition)
- (collect status-condition)))))
+ (setf (health-of character) (calculate-stat character :health))))
(switch-user-packages))
(defun wash (clothing)
(declare (type list clothing))
diff --git a/core/libexec/generic-functions.lisp b/core/libexec/generic-functions.lisp
index a2a758f..44c9680 100644
--- a/core/libexec/generic-functions.lisp
+++ b/core/libexec/generic-functions.lisp
@@ -158,7 +158,7 @@
(:method :before ((target base-character) (user base-character) (attack move))
(format t "~a used ~a~%" (name-of user) (name-of attack)))
(:method :before ((target base-character) (user base-character) (attack clear-status-mixin))
- (a:deletef (status-conditions-of target) (statuses-cleared-of attack)
+ (deletef-status-conditions (statuses-cleared-of attack) target
:test (lambda (o e) (typep e o))))
(:method :after ((target base-character) (user base-character) (attack damage-move))
(f:fmt t (name-of target) " received " (calculate-damage target user attack) " damage" #\Newline
@@ -232,6 +232,17 @@
"such as talking, walking around, and doing a potty dance and acting embarrassed when having an accident." #\Newline #\Newline
"Fixing this made the code way too complicated."))
(:method ((user base-character) (condition status-condition) battle)))
+(defgeneric effective-status-conditions (status-condition user)
+ (:method ((status-condition status-condition) (user base-character))
+ (gethash user (%status-conditions-of *battle*)))
+ (:method ((status-condition persistent-status-condition) (user base-character))
+ (%status-conditions-of user)))
+(defgeneric (setf effective-status-conditions) (new-value status-condition user)
+ (:method (new-value (status-condition status-condition) (user base-character))
+ (setf (gethash user (%status-conditions-of *battle*)) new-value))
+ (:method (new-value (status-condition persistent-status-condition) (user base-character))
+ (setf new-value (%status-conditions-of user))))
+
(defgeneric toggle-onesie% (onesie))
(defgeneric toggle-onesie (onesie clothes user))
;;; Wish the API I made for this wasn't so complex, but I wasn't sure how to make it simple and still retain the functionality
diff --git a/core/libexec/mcclim.lisp b/core/libexec/mcclim.lisp
index 93ad12f..5f8d741 100644
--- a/core/libexec/mcclim.lisp
+++ b/core/libexec/mcclim.lisp
@@ -117,7 +117,7 @@
(calculate-stat object :energy))
""))
(write-string "Conditions: " stream)
- (iter (for i in (status-conditions-of object))
+ (iter (for i in (status-conditions object))
(format stream "“~a” " (name-of i)))
(write-char #\Newline stream)
(format stream "Stats: ~a~%Base-Stats: ~a~%"
diff --git a/core/libexec/methods.lisp b/core/libexec/methods.lisp
index 3bdfa98..2dd5389 100644
--- a/core/libexec/methods.lisp
+++ b/core/libexec/methods.lisp
@@ -1678,7 +1678,7 @@ randomrange is @code{(random-from-range 85 100)}"
(return-from process-battle-turn))
(cond ((process-battle-accident character attack item reload selected-target)
nil)
- ((iter (for j in (status-conditions-of character))
+ ((iter (for j in (status-conditions character))
(when (blocks-turn-of j)
(leave t))))
((process-potty-dance character attack item reload selected-target) t)
@@ -1714,7 +1714,7 @@ randomrange is @code{(random-from-range 85 100)}"
(return-from process-battle-turn))
(cond ((process-battle-accident character attack item reload selected-target)
nil)
- ((iter (for j in (status-conditions-of character))
+ ((iter (for j in (status-conditions character))
(when (blocks-turn-of j)
(leave t))))
((process-potty-dance character attack item reload selected-target) t)
diff --git a/core/util.lisp b/core/util.lisp
index 1e7cb1a..f1d2c5f 100644
--- a/core/util.lisp
+++ b/core/util.lisp
@@ -46,6 +46,12 @@ the result of calling @code{SUSTITUTE} with @var{OLD}, @var{NEW}, place, and the
remove-if/swapped-arguments
"Modify-macro for @code{REMOVE-IF}. Sets place designated by the first argument to
the result of calling @code{REMOVE-IF} with @var{TEST}, place, and the @var{KEYWORD-ARGUMENTS}.")
+(defun delete-if/swapped-arguments (sequence test &rest keyword-arguments)
+ (apply #'delete-if test sequence keyword-arguments))
+(define-modify-macro deletef-if (test &rest keyword-arguments)
+ delete-if/swapped-arguments
+ "Modify-macro for @code{DELETE-IF}. Sets place designated by the first argument to
+the result of calling @code{DELETE-IF} with @var{TEST}, place, and the @var{KEYWORD-ARGUMENTS}.")
(defun type-specifier-p (type-specifier)
"Returns true if @var{TYPE-SPECIFIER} is a valid type specifier."
#+sbcl (sb-ext:valid-type-specifier-p type-specifier)
diff --git a/data/enemies/raccoon-bandits.lisp b/data/enemies/raccoon-bandits.lisp
index 19a47e6..5892dd0 100644
--- a/data/enemies/raccoon-bandits.lisp
+++ b/data/enemies/raccoon-bandits.lisp
@@ -67,9 +67,9 @@
(f:fmt t (name-of character) " starts to make a mess on the floor" #\Newline)))
(set-status-condition 'yadfa-status-conditions:messing character))
(let ((wetting (find-if (lambda (o) (typep o 'yadfa-status-conditions:wetting))
- (status-conditions-of character)))
+ (status-conditions character)))
(messing (find-if (lambda (o) (typep o 'yadfa-status-conditions:messing))
- (status-conditions-of character)))
+ (status-conditions character)))
(teammember (find-if (lambda (o)
(and (typep o 'diapered-raccoon-bandit) (not (eq o character))))
(enemies-of *battle*))))
diff --git a/data/epilog/items.lisp b/data/epilog/items.lisp
index f76ad1d..cc84ac6 100644
--- a/data/epilog/items.lisp
+++ b/data/epilog/items.lisp
@@ -16,9 +16,7 @@
;; prevent the enemy from going again during the battle
(alexandria:deletef (enemies-of *battle*) target)
(alexandria:deletef (turn-queue-of *battle*) target)
- (setf (status-conditions-of target) (iter (for status-condition in (status-conditions-of target))
- (when (persistentp status-condition)
- (collect status-condition))))
+
(push target (contained-enemies-of item))
(unless (getf (special-actions-of item) :take-items)
@@ -93,9 +91,6 @@
;; prevent the enemy from going again during the battle
(alexandria:deletef (enemies-of *battle*) target)
(alexandria:deletef (turn-queue-of *battle*) target)
- (setf (status-conditions-of target) (iter (for status-condition in (status-conditions-of target))
- (when (persistentp status-condition)
- (collect status-condition))))
(push target (contained-enemies-of item)))))
(defunassert yadfa-battle-commands:catch-enemy (&optional (target 'yadfa-enemies:catchable-enemy) (item 'enemy-catcher))
diff --git a/data/moves/regular.lisp b/data/moves/regular.lisp
index 262dd27..4dc2b08 100644
--- a/data/moves/regular.lisp
+++ b/data/moves/regular.lisp
@@ -39,7 +39,7 @@
'soggy)))
(padding i))
(leave `(padding ,padding severity ,severity)))))))
- (old-condition (find 'yadfa-status-conditions:pantsed (status-conditions-of target)
+ (old-condition (find 'yadfa-status-conditions:pantsed (status-conditions target)
:test (lambda (o e)
(typep e o)))))
(if stat
@@ -54,7 +54,7 @@
(name-of target)
(name-of (car (filter-items pants 'dress))))))
(unless old-condition
- (push (make-instance 'yadfa-status-conditions:pantsed) (status-conditions-of target)))
+ (set-status-condition 'yadfa-status-conditions:pantsed target))
(format t "~a gets a horrified look on ~a face as ~a ~a is exposed to the world~%"
(name-of target)
(if (malep target) "his" "her")
@@ -214,7 +214,7 @@
(f:fmt* t (name-of i) " is laughing at " name #\Newline))))
(cond
((and (>= (bowels/contents-of user) (bowels/need-to-potty-limit-of user))
- (find 'yadfa-status-conditions:poisoned (status-conditions-of user)
+ (find 'yadfa-status-conditions:poisoned (status-conditions user)
:test (lambda (o e)
(typep e o))))
(mess :messer user)
diff --git a/data/status-conditions/abdl.lisp b/data/status-conditions/abdl.lisp
index 35e5d83..2cda131 100644
--- a/data/status-conditions/abdl.lisp
+++ b/data/status-conditions/abdl.lisp
@@ -30,13 +30,13 @@
:duration t
:stat-multiplier (list :speed 1/2)
:blocks-turn t))
-(defmethod condition-script ((user base-character) (self mushed) (battle (eql t)))
+(defmethod condition-script ((user base-character) (status-condition mushed) (battle (eql t)))
(cond ((<= (getf (calculate-diaper-usage user) :messiness) 0)
- (setf (status-conditions-of user) (remove self (status-conditions-of user))))
+ (deletef-status-conditions status-condition user))
((< (random 4) 1)
(format t "~a is too busy grabbing the back of ~a diaper trying to unmush it to fight~%" (name-of user) (if (malep user) "his" "her"))
- (setf (blocks-turn-of self) t))
- (t (setf (blocks-turn-of self) nil))))
+ (setf (blocks-turn-of status-condition) t))
+ (t (setf (blocks-turn-of status-condition) nil))))
(defclass pantsed (status-condition)
()
(:default-initargs
diff --git a/data/status-conditions/pokemon.lisp b/data/status-conditions/pokemon.lisp
index 8878ee1..9037c4c 100644
--- a/data/status-conditions/pokemon.lisp
+++ b/data/status-conditions/pokemon.lisp
@@ -10,4 +10,4 @@
(if (= 0 (random 5))
(progn (format t "~a is hurt by the poison~%" (name-of user))
(decf (health-of user) (/ (calculate-stat user :health))))
- (a:deletef (status-conditions-of user) condition)))
+ (deletef-status-conditions condition user)))
diff --git a/packages.lisp b/packages.lisp
index c0fb767..d5810a5 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -14,6 +14,7 @@
#:type-specifier
#:coerced-function
#:removef-if
+ #:deletef-if
#:append*
#:appendf*
#:collecting*
@@ -321,7 +322,6 @@
#:enter-battle-text-of
#:enemies-of
#:win-events-of
- #:status-conditions-of
#:player-of
#:allies-of
#:team-of
@@ -333,7 +333,9 @@
#:action-p
#:fainted-of
#:curablep
- #:persistentp)
+ #:deletef-status-conditions
+ #:deletef-status-conditions-if
+ #:status-conditions)
(:documentation "Yet Another Diaperfur Adventure")
(:local-nicknames (:s :serapeum) (:a :alexandria) (:u :ugly-tiny-infix-macro) (:g :global-vars) (:sc :serapeum/contrib/hooks)
(:c :clim) (:ce :clim-extensions) (:cc :conditional-commands) (:ms :marshal) (:f :fmt)))