aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Pouar <pouar@pouar.net>2020-10-12 10:36:16 -0500
committerGravatar Pouar <pouar@pouar.net>2020-10-12 10:36:16 -0500
commit1c9fa1c2e2dab897d71e7be72422204c9eb6b1aa (patch)
treee4507aa7a1be01660aa174381caf92f10617cd45
parentdocstring typos (diff)
another giant commit with a useless log message
-rw-r--r--core/bin/world.lisp5
-rw-r--r--core/libexec/classes.lisp36
-rw-r--r--core/libexec/declares.lisp15
-rw-r--r--core/libexec/functions.lisp1610
-rw-r--r--core/libexec/generic-functions.lisp68
-rw-r--r--core/libexec/init.lisp4
-rw-r--r--core/libexec/mcclim.lisp165
-rw-r--r--core/libexec/methods.lisp75
-rw-r--r--data/enemies/raccoon-bandits.lisp10
-rw-r--r--data/epilog/items.lisp86
-rw-r--r--data/moves/regular.lisp6
-rw-r--r--data/prolog/enemies.lisp15
-rw-r--r--data/status-conditions/abdl.lisp12
-rw-r--r--data/status-conditions/pokemon.lisp4
-rw-r--r--packages.lisp3
-rw-r--r--yadfa.asd2
16 files changed, 1061 insertions, 1055 deletions
diff --git a/core/bin/world.lisp b/core/bin/world.lisp
index 56e046d..b7081b3 100644
--- a/core/bin/world.lisp
+++ b/core/bin/world.lisp
@@ -291,9 +291,8 @@ You can also specify multiple directions, for example @code{(move :south :south)
:target this-user
keys)))
(incf (time-of *game*))
- (process-potty)
- (iter (for i in (allies-of *game*))
- (process-potty i))
+ (iter (for i in (cons (player-of *game*) (allies-of *game*)))
+ (process-potty i nil))
ret))
(unusable-item (c)
(princ c))))))
diff --git a/core/libexec/classes.lisp b/core/libexec/classes.lisp
index f573f09..cde836e 100644
--- a/core/libexec/classes.lisp
+++ b/core/libexec/classes.lisp
@@ -58,13 +58,13 @@
:documentation "Description of the character")
(health
:initarg :health
- :accessor health-of
- :type real
+ :reader health-of
+ :type (real 0)
:documentation "Health of the character.")
(energy
:initarg :energy
- :accessor energy-of
- :type real
+ :reader energy-of
+ :type (real 0)
:documentation "Energy of the character.")
(default-attack-power
:initarg :default-attack-power
@@ -143,7 +143,13 @@
:initform nil
:accessor wield-of
:type (or null item)
- :documentation "Item the character is wielding as a weapon"))
+ :documentation "Item the character is wielding as a weapon")
+ (status-conditions
+ :initarg :status-conditions
+ :initform ()
+ :accessor status-conditions-of
+ :type list
+ :documentation "Status conditions of the character"))
(:documentation "Base class for the characters in the game"))
(defclass item (yadfa-class)
((description
@@ -269,12 +275,18 @@
:type unsigned-byte
:accessor priority-of
:documentation "Unsigned integer that specifies How important this condition is to cure. Used for the AI. Lower value means more important")
+ (curable
+ :initarg :curable
+ :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 items or moves that cure statuses cure this"))
+ :documentation "Whether this lasts outside battle or not"))
(:documentation "Base class for all the status conditions"))
(defclass move (yadfa-class element-type-mixin)
((name
@@ -472,8 +484,8 @@
(defclass playable-ally (ally) ())
(defmethod initialize-instance :after
((c base-character) &key (health nil healthp) (energy nil energyp)
- (base-health nil base-health-p) (base-attack nil base-attack-p)
- (base-defense nil base-defense-p) (base-speed nil base-speed-p) (base-energy nil base-energy-p) &allow-other-keys)
+ (base-health nil base-health-p) (base-attack nil base-attack-p)
+ (base-defense nil base-defense-p) (base-speed nil base-speed-p) (base-energy nil base-energy-p) &allow-other-keys)
(declare (ignore health energy))
(when base-health-p
(setf (getf (base-stats-of c) :health) base-health))
@@ -1074,12 +1086,6 @@
:accessor win-events-of
:type list
:documentation "List of events that trigger when you've won the battle")
- (status-conditions
- :initarg :status-conditions
- :initform ()
- :accessor status-conditions-of
- :type list
- :documentation "plist of characters who's values are a plist of conditions that go away after battle")
(fainted
:initarg :fainted
:initform ()
@@ -1094,7 +1100,7 @@
(enter-battle-text-of c)
(with-output-to-string (s)
(iter (for i in (enemies-of c))
- (format s "A Wild ~a Appeared!!!~%" (name-of i))))))
+ (format s "A Wild ~a Appeared!!!~%" (name-of i))))))
(setf (turn-queue-of c) (sort (append* (enemies-of c) (team-npcs-of c) (team-of *game*)) '>
:key (lambda (a)
(calculate-stat a :speed))))
diff --git a/core/libexec/declares.lisp b/core/libexec/declares.lisp
index 577bfc6..77024c6 100644
--- a/core/libexec/declares.lisp
+++ b/core/libexec/declares.lisp
@@ -17,7 +17,8 @@
(ftype (function (list &optional list symbol) (values null &optional)) print-enter-text)
(ftype (function () (values list &optional)) get-inventory-list)
(ftype (function (list type-specifier) (values list &optional)) filter-items)
- (ftype (function (base-character) (values list &optional)) swell-up%)
+ (ftype (function (base-character) (values list &optional)) swell-up% calculate-diaper-usage calculate-wear-stats
+ calculate-wield-stats calculate-stat-delta calculate-stat-multiplier)
(ftype (function (base-character) (values list symbol &optional)) swell-up)
(ftype (function (list clothing) (values real &optional)) fast-thickness)
(ftype (function (base-character &optional cons) (values list symbol &optional)) pop-from-expansion)
@@ -30,16 +31,14 @@
(ftype (function (symbol list) (values list &optional)) get-items-from-prop)
(ftype (function (symbol list) (values real &optional)) get-bitcoins-from-prop)
(ftype (function (symbol base-character) (values (or move null) &optional)) get-move)
- (ftype (function (base-character) (values list &optional)) calculate-diaper-usage)
(ftype (function (real) (values real real &optional)) calculate-level-to-exp)
(ftype (function (enemy) (values real &optional)) calculate-exp-yield)
- (ftype (function (base-character) (values list &optional))
- calculate-wear-stats calculate-wield-stats calculate-stat-delta calculate-stat-multiplier)
(ftype (function (base-character keyword) (values real real &optional)) calculate-stat)
(ftype (function (item &optional boolean) (values (eql t) &optional)) describe-item)
(ftype (function (&optional boolean) (values (eql t) &optional)) finish-battle)
(ftype (function (list) (values null &optional)) wash)
(ftype (function (base-character) (values cons &optional)) go-to-sleep%)
+ (ftype (function (base-character) (values boolean &optional)) handle-faint)
(ftype (function (list symbol symbol) (values action &optional)) getf-action-from-prop)
(ftype (function (&key (:attack (or symbol boolean)) (:item item) (:reload type-specifier) (:no-team-attack t)
(:selected-target (or null enemy team-member))))
@@ -48,4 +47,10 @@
(ftype (function (simple-string boolean simple-string) (values (eql t) &optional)) set-player)
(ftype (function (list list) (values (member :super-effective :not-very-effective :no-effect nil) real &optional)) effective-type-effectiveness)
(ftype (function (t) (values list &optional)) coerce-element-types)
- (ftype (function (list &key (:ignore-lock t) (:direction symbol) (:old-position list))) move-to-zone))
+ (ftype (function (list &key (:ignore-lock t) (:direction symbol) (:old-position list))) move-to-zone)
+ (type (or null battle) *battle*)
+ (type list yadfa-clim::*records* *mods* *cheat-hooks* *world-packages* *battle-packages* *command-packages*)
+ (type (or null game) *game*)
+ (type hash-table *mod-registry* *pattern-cache* *events* *element-types*)
+ (type boolean *immutable*)
+ (type unsigned-byte *last-rng-update*))
diff --git a/core/libexec/functions.lisp b/core/libexec/functions.lisp
index 5393b5c..37dcbbe 100644
--- a/core/libexec/functions.lisp
+++ b/core/libexec/functions.lisp
@@ -33,10 +33,10 @@
t)
(defunassert get-event (event-id)
- (event-id symbol)
+ (event-id symbol)
(gethash event-id *events*))
(defunassert (setf get-event) (new-value event-id)
- (event-id symbol)
+ (event-id symbol)
(setf (gethash event-id *events*) new-value))
(defun get-zone (position)
(declare (type list position))
@@ -47,52 +47,52 @@
(setf (position-of new-value) position
(gethash position (slot-value *game* 'zones)) new-value))
(s:eval-always
- (defun set-logical-pathnames ()
- (setf (logical-pathname-translations "YADFA")
- `(("yadfa:data;**;*.*.*" ,(uiop:merge-pathnames*
- (make-pathname
- :directory '(:relative "YADFA" :wild-inferiors)
- :name :wild
- :type :wild
- :version :wild
- :case :common)
- (uiop:xdg-data-home)))
- ("yadfa:config;**;*.*.*" ,(uiop:merge-pathnames*
- (make-pathname
- :directory '(:relative "YADFA" :wild-inferiors)
- :name :wild
- :type :wild
- :version :wild
- :case :common)
- (uiop:xdg-config-home)))
- ("yadfa:home;**;*.*.*" ,(uiop:merge-pathnames*
- (make-pathname
- :directory '(:relative :wild-inferiors)
- :type :wild
- :name :wild
- :version :wild
- :case :common)
- (if uiop:*image-dumped-p*
- (make-pathname
- :device (pathname-device (truename (uiop:argv0)))
- :directory (pathname-directory (truename (uiop:argv0))))
- (asdf:component-pathname (asdf:find-system "yadfa")))))))
- (illogical-pathnames:define-illogical-host :yadfa.data (uiop:merge-pathnames*
- (make-pathname
- :directory '(:relative "YADFA")
- :case :common)
- (uiop:xdg-data-home)))
- (illogical-pathnames:define-illogical-host :yadfa.config (uiop:merge-pathnames*
- (make-pathname
- :directory '(:relative "YADFA")
- :case :common)
- (uiop:xdg-config-home)))
- (illogical-pathnames:define-illogical-host :yadfa.home (if uiop:*image-dumped-p*
+ (defun set-logical-pathnames ()
+ (setf (logical-pathname-translations "YADFA")
+ `(("yadfa:data;**;*.*.*" ,(uiop:merge-pathnames*
+ (make-pathname
+ :directory '(:relative "YADFA" :wild-inferiors)
+ :name :wild
+ :type :wild
+ :version :wild
+ :case :common)
+ (uiop:xdg-data-home)))
+ ("yadfa:config;**;*.*.*" ,(uiop:merge-pathnames*
+ (make-pathname
+ :directory '(:relative "YADFA" :wild-inferiors)
+ :name :wild
+ :type :wild
+ :version :wild
+ :case :common)
+ (uiop:xdg-config-home)))
+ ("yadfa:home;**;*.*.*" ,(uiop:merge-pathnames*
+ (make-pathname
+ :directory '(:relative :wild-inferiors)
+ :type :wild
+ :name :wild
+ :version :wild
+ :case :common)
+ (if uiop:*image-dumped-p*
+ (make-pathname
+ :device (pathname-device (truename (uiop:argv0)))
+ :directory (pathname-directory (truename (uiop:argv0))))
+ (asdf:component-pathname (asdf:find-system "yadfa")))))))
+ (illogical-pathnames:define-illogical-host :yadfa.data (uiop:merge-pathnames*
+ (make-pathname
+ :directory '(:relative "YADFA")
+ :case :common)
+ (uiop:xdg-data-home)))
+ (illogical-pathnames:define-illogical-host :yadfa.config (uiop:merge-pathnames*
(make-pathname
- :device (pathname-device (truename (uiop:argv0)))
- :directory (pathname-directory (truename (uiop:argv0))))
- (asdf:system-source-directory "yadfa"))))
- (set-logical-pathnames))
+ :directory '(:relative "YADFA")
+ :case :common)
+ (uiop:xdg-config-home)))
+ (illogical-pathnames:define-illogical-host :yadfa.home (if uiop:*image-dumped-p*
+ (make-pathname
+ :device (pathname-device (truename (uiop:argv0)))
+ :directory (pathname-directory (truename (uiop:argv0))))
+ (asdf:system-source-directory "yadfa"))))
+ (set-logical-pathnames))
(defun process-potty-dance-check (character attack)
(and (or
(>= (bladder/contents-of character) (bladder/potty-dance-limit-of character))
@@ -111,37 +111,37 @@
1)
(or (eq attack t) (not (typep (get-move attack character) '(or mess-move-mixin wet-move-mixin))))))
(defunassert get-positions-of-type (type list)
- (type type-specifier
- list list)
+ (type type-specifier
+ list list)
(iter (for i in list)
- (for (the fixnum j) upfrom 0)
- (when (typep i type)
- (collect j))))
+ (for (the fixnum j) upfrom 0)
+ (when (typep i type)
+ (collect j))))
(defunassert finished-events (events)
- (events (or list symbol))
+ (events (or list symbol))
(iter (for (the (or list symbol) event) in (a:ensure-list events))
- #-(or sbcl ccl)
- (check-type event (or list symbol))
- (unless (gethash (a:ensure-list event) (finished-events-of *game*))
- (leave))
- (finally (return t))))
+ #-(or sbcl ccl)
+ (check-type event (or list symbol))
+ (unless (gethash (a:ensure-list event) (finished-events-of *game*))
+ (leave))
+ (finally (return t))))
(defunassert unfinished-events (events)
- (events (or list symbol))
+ (events (or list symbol))
(iter (for (the (or list symbol) event) in (a:ensure-list events))
- #-(or sbcl ccl)
- (check-type event (or list symbol))
- (when (gethash (a:ensure-list event) (finished-events-of *game*))
- (leave))
- (finally (return t))))
+ #-(or sbcl ccl)
+ (check-type event (or list symbol))
+ (when (gethash (a:ensure-list event) (finished-events-of *game*))
+ (leave))
+ (finally (return t))))
(defunassert finish-events (events)
- (events (or list symbol))
+ (events (or list symbol))
(iter (for (the symbol event) in (a:ensure-list events))
- #-(or sbcl ccl)
- (check-type event symbol)
- (remhash event (current-events-of *game*))
- (setf (gethash `(,event) (finished-events-of *game*)) t)))
+ #-(or sbcl ccl)
+ (check-type event symbol)
+ (remhash event (current-events-of *game*))
+ (setf (gethash `(,event) (finished-events-of *game*)) t)))
(defunassert get-diaper-expansion (item)
- (item closed-bottoms)
+ (item closed-bottoms)
(+ (* 10 (/ (+ (sogginess-of item) (messiness-of item))
(- (* 72 36) (* (/ (* 72 5/7) 2) 18/2 pi))))
(thickness-of item)))
@@ -162,13 +162,13 @@
(t new))))
(iter (for i in (uiop:directory*
#P((:common :yadfa.data) ("MODS" :**) (:* "ASD") :newest)))
- (setf (gethash (pathname-name i) *mod-registry*)
- (preferred-mod (gethash (pathname-name i) *mod-registry*)
- i)))))
+ (setf (gethash (pathname-name i) *mod-registry*)
+ (preferred-mod (gethash (pathname-name i) *mod-registry*)
+ i)))))
(defun clear-pattern-cache ()
(clrhash *pattern-cache*))
(defunassert find-mod (system)
- (system (or symbol simple-string))
+ (system (or symbol simple-string))
(gethash (asdf:primary-system-name system) *mod-registry*))
(defun clear-configuration-hook ()
(set-logical-pathnames)
@@ -193,16 +193,16 @@
(if (and
(typep mods 'list)
(iter (for i in mods)
- (unless (typep i '(or string symbol asdf/component:component))
- (leave nil))
- (finally (return t))))
+ (unless (typep i '(or string symbol asdf/component:component))
+ (leave nil))
+ (finally (return t))))
(setf *mods* mods)
(write-line "The configuration file containing the list of enabled mods isn't valid, ignoring")))
(let ((*compile-verbose* compiler-verbose)
(*compile-print* compiler-verbose))
(iter (for i in *mods*)
- (when (asdf:find-system i nil)
- (apply #'asdf:load-system i :allow-other-keys t keys))))))
+ (when (asdf:find-system i nil)
+ (apply #'asdf:load-system i :allow-other-keys t keys))))))
(defun (setf getf-direction) (new-value position direction attribute)
(setf (getf (getf (direction-attributes-of (get-zone position)) direction) attribute) new-value))
(defun getf-direction (position direction attribute)
@@ -212,53 +212,53 @@
(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 (getf (status-conditions-of *battle*) 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 (getf (status-conditions-of *battle*) user) :test (or test #'eql) :key (or key #'identity))
+ &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))
(when (and (not (eq (duration-of i) t)) (< (duration-of i) duration))
(setf (duration-of i) duration))
t)
(defunassert trigger-event (event-ids)
- (event-ids (or symbol list))
+ (event-ids (or symbol list))
(iter (for (the symbol event-id) in (a:ensure-list event-ids))
- #-(or sbcl ccl)
- (check-type event-id symbol)
- (when (and
- (funcall (coerce (slot-value (get-event event-id) 'predicate) 'function)
- (get-event event-id))
- (or (and (slot-value (get-event event-id) 'repeatable) (not (gethash event-id (current-events-of *game*))))
- (not (gethash event-id (finished-events-of *game*))))
- (finished-events (slot-value (get-event event-id) 'finished-depends)))
- (let* ((mission (slot-value (get-event event-id) 'mission))
- (accept (when mission
- (funcall (coerce (slot-value (get-event event-id) 'mission) 'function)))))
- (when mission
- (setf (gethash event-id (current-events-of *game*)) t))
- (setf (gethash `(,event-id
- ,@(when (and mission (s:memq accept '(:accepted :declined)))
- `(,accept)))
- (finished-events-of *game*))
- t)
- (apply (coerce (slot-value (get-event event-id) 'lambda) 'function)
- `(,event-id ,@(when mission `(,accept)))))
- (collect event-id))))
+ #-(or sbcl ccl)
+ (check-type event-id symbol)
+ (when (and
+ (funcall (coerce (slot-value (get-event event-id) 'predicate) 'function)
+ (get-event event-id))
+ (or (and (slot-value (get-event event-id) 'repeatable) (not (gethash event-id (current-events-of *game*))))
+ (not (gethash event-id (finished-events-of *game*))))
+ (finished-events (slot-value (get-event event-id) 'finished-depends)))
+ (let* ((mission (slot-value (get-event event-id) 'mission))
+ (accept (when mission
+ (funcall (coerce (slot-value (get-event event-id) 'mission) 'function)))))
+ (when mission
+ (setf (gethash event-id (current-events-of *game*)) t))
+ (setf (gethash `(,event-id
+ ,@(when (and mission (s:memq accept '(:accepted :declined)))
+ `(,accept)))
+ (finished-events-of *game*))
+ t)
+ (apply (coerce (slot-value (get-event event-id) 'lambda) 'function)
+ `(,event-id ,@(when mission `(,accept)))))
+ (collect event-id))))
(defunassert event-attributes (event-id)
- (event-id symbol)
+ (event-id symbol)
(gethash event-id (slot-value *game* 'event-attributes%)))
(defunassert (setf event-attributes) (instance event-id)
- (event-id symbol)
+ (event-id symbol)
(setf (gethash event-id (slot-value *game* 'event-attributes%)) instance))
(defun set-new-battle (enemies &rest keys &key team-npcs win-events enter-battle-text continuable)
(when continuable
@@ -271,38 +271,38 @@
(setf *battle*
(apply #'make-instance 'battle
:enemies (iter (for (the list j) in enemies)
- (collect (apply #'make-instance (car j) (eval (cdr j)))))
+ (collect (apply #'make-instance (car j) (eval (cdr j)))))
:team-npcs (iter (for (the list j) in team-npcs)
- (collect (apply #'make-instance (car j) (eval (cdr j)))))
+ (collect (apply #'make-instance (car j) (eval (cdr j)))))
keys))
(format t "~a~%" (enter-battle-text-of *battle*))
(iter (for (the symbol j) in (iter (for i in (enemies-of *battle*))
- (unless (s:memq (s:class-name-of i) (seen-enemies-of *game*))
- (format t "~a was added to your pokedex~%" (name-of i))
- (push (s:class-name-of i) (seen-enemies-of *game*))
- (collect (s:class-name-of i)))))
- (yadfa-bin:pokedex j))
+ (unless (s:memq (s:class-name-of i) (seen-enemies-of *game*))
+ (format t "~a was added to your pokedex~%" (name-of i))
+ (push (s:class-name-of i) (seen-enemies-of *game*))
+ (collect (s:class-name-of i)))))
+ (yadfa-bin:pokedex j))
(switch-user-packages)
(process-battle :attack t :no-team-attack t))
(defunassert run-equip-effects (user)
- (user base-character)
+ (user base-character)
(iter (for i in (wear-of user))
- (wear-script i user))
+ (wear-script i user))
(when (wield-of user)
(wield-script (wield-of user) user)))
(defunassert get-warp-point (direction position)
- (direction symbol position list)
+ (direction symbol position list)
(getf (warp-points-of (get-zone position))
(typecase direction
((member :north :south :east :west :up :down)
direction)
(keyword
(iter (for (k v) on (warp-points-of (get-zone position)) by 'cddr)
- (when (and (string= k direction) v)
- (leave k))))
+ (when (and (string= k direction) v)
+ (leave k))))
(symbol direction))))
(defunassert get-destination (direction position)
- (direction symbol position list)
+ (direction symbol position list)
(macrolet ((a (pos x y z)
(a:with-gensyms ((posx "POSX") (posy "POSY") (posz "POSZ") (posm "POSM") (b "B"))
`(let ((,b (destructuring-bind (,posx ,posy ,posz ,posm) ,pos
@@ -322,7 +322,7 @@
(defunassert get-path-end (destination &optional position direction
&aux (player (player-of *game*)) (allies (allies-of *game*)) (wield (wield-of player))
(wear (wear-of player)) (inventory (inventory-of player)))
- (direction symbol position list destination list)
+ (direction symbol position list destination list)
(unless (get-zone destination)
(return-from get-path-end (values nil (format nil "Pick a direction the game knows about~%"))))
(when (or (hiddenp (get-zone destination)) (and position direction (getf-direction position direction :hidden)))
@@ -336,9 +336,9 @@
(cons wield wear)
(let ((a ()))
(iter (for i in allies)
- (push (wield-of i) a)
- (iter (for j in (wear-of i))
- (push j a)))
+ (push (wield-of i) a)
+ (iter (for j in (wear-of i))
+ (push j a)))
a)))))
(and position direction
(getf-direction position direction :locked)
@@ -348,14 +348,14 @@
(cons wield wear)
(let ((a ()))
(iter (for i in allies)
- (push (wield-of i) a)
- (iter (for j in (wear-of i))
- (push j a)))
+ (push (wield-of i) a)
+ (iter (for j in (wear-of i))
+ (push j a)))
a))))))
(return-from get-path-end (values nil (format nil "zone ~a is locked~%" destination))))
destination)
(defunassert print-map-pattern-cache (path designs)
- (path pathname designs list)
+ (path pathname designs list)
(or (gethash `(:map-pattern ,path ,designs) *pattern-cache*)
(setf (gethash `(:map-pattern ,path ,designs) *pattern-cache*)
(clim:make-pattern-from-bitmap-file
@@ -375,7 +375,7 @@
(and (not (s:memq direction '(:up :down)))))
t))
(defunassert print-map (position &aux (player (player-of *game*)) (player-position (position-of player)) (player-zone (get-zone player-position)))
- (player player player-position list player-zone (or null zone))
+ (player player player-position list player-zone (or null zone))
(labels ((a (position)
(let ((b 0)
(array
@@ -396,65 +396,65 @@
#P"e.xpm"
#P"dot.xpm")))
(iter (for direction in '(:east :west :south :north))
- (for (the fixnum byte-position) upfrom 0)
- (unless (travelablep position direction)
- (setf (ldb (byte 1 byte-position) b) 1)))
+ (for (the fixnum byte-position) upfrom 0)
+ (unless (travelablep position direction)
+ (setf (ldb (byte 1 byte-position) b) 1)))
(aref array b))))
(updating-present-with-effective-frame (*query-io* :unique-id `(map% ,position)
:id-test #'equal
:cache-value (sxhash (list player-position
(iter (for i in '(:north :south :east :west :up :down))
- (collect (travelablep player-position i)))
+ (collect (travelablep player-position i)))
(and player-zone
(warp-points-of player-zone)))))
- (let ((pattern (print-map-pattern-cache #P"blank.xpm"
- (list clim:+background-ink+ clim:+foreground-ink+))))
- (multiple-value-bind (start-x start-y) (if c:*application-frame*
- (clim:stream-cursor-position *standard-output*)
- (values 0 0))
- (declare (type real start-x start-y))
- (clim:updating-output (t)
- ;; position needs to be bound inside of clim:updating-output and not outside
- ;; for the presentation to notice when the floor the player is on changes
- (let* ((player-position (position-of (player-of *game*)))
- (position (if (eq position t)
- player-position
- position)))
- (declare (type list position player-position))
- (destructuring-bind (posx posy posz posm) position
- (declare (type integer posx posy posz)
- (type symbol posm))
- (iter (for (the integer y)
- from (- posy 15)
- to (+ posy 15))
- (for y-pos
- from start-y
- to (+ start-y (* 30 (the (unsigned-byte 32) (clim:pattern-height pattern))))
- by (the (unsigned-byte 32) (clim:pattern-height pattern)))
- (iter (for (the integer x)
- from (- posx 15)
- to (+ posx 15))
- (for x-pos
- from start-x
- to (+ start-x (* 30 (the (unsigned-byte 32) (clim:pattern-width pattern))))
- by (the (unsigned-byte 32) (clim:pattern-width pattern)))
- (let* ((current-position `(,x ,y ,posz ,posm))
- (current-zone (get-zone current-position))
- (char (cons (if (or (and current-zone (hiddenp current-zone)) (not current-zone))
- #P"blank.xpm"
- (a current-position))
- (clim:make-rgb-color (if (and current-zone (warp-points-of current-zone)) 1 0)
- (if (equal current-position player-position) 0.7l0 0)
- (if (or (travelablep current-position :up) (travelablep current-position :down)) 1 0)))))
- (setf pattern (print-map-pattern-cache (car char) (list clim:+background-ink+ (cdr char))))
- (when (get-zone current-position)
- (clim:with-output-as-presentation
- (*standard-output* (get-zone current-position) 'zone)
- (clim:draw-pattern* *standard-output* pattern x-pos y-pos)))))))))
- (when c:*application-frame*
- (clim:stream-set-cursor-position *standard-output* start-x (+ start-y (* 31 (the (unsigned-byte 32) (clim:pattern-height pattern)))))))))))
+ (let ((pattern (print-map-pattern-cache #P"blank.xpm"
+ (list clim:+background-ink+ clim:+foreground-ink+))))
+ (multiple-value-bind (start-x start-y) (if c:*application-frame*
+ (clim:stream-cursor-position *standard-output*)
+ (values 0 0))
+ (declare (type real start-x start-y))
+ (clim:updating-output (t)
+ ;; position needs to be bound inside of clim:updating-output and not outside
+ ;; for the presentation to notice when the floor the player is on changes
+ (let* ((player-position (position-of (player-of *game*)))
+ (position (if (eq position t)
+ player-position
+ position)))
+ (declare (type list position player-position))
+ (destructuring-bind (posx posy posz posm) position
+ (declare (type integer posx posy posz)
+ (type symbol posm))
+ (iter (for (the integer y)
+ from (- posy 15)
+ to (+ posy 15))
+ (for y-pos
+ from start-y
+ to (+ start-y (* 30 (the (unsigned-byte 32) (clim:pattern-height pattern))))
+ by (the (unsigned-byte 32) (clim:pattern-height pattern)))
+ (iter (for (the integer x)
+ from (- posx 15)
+ to (+ posx 15))
+ (for x-pos
+ from start-x
+ to (+ start-x (* 30 (the (unsigned-byte 32) (clim:pattern-width pattern))))
+ by (the (unsigned-byte 32) (clim:pattern-width pattern)))
+ (let* ((current-position `(,x ,y ,posz ,posm))
+ (current-zone (get-zone current-position))
+ (char (cons (if (or (and current-zone (hiddenp current-zone)) (not current-zone))
+ #P"blank.xpm"
+ (a current-position))
+ (clim:make-rgb-color (if (and current-zone (warp-points-of current-zone)) 1 0)
+ (if (equal current-position player-position) 0.7l0 0)
+ (if (or (travelablep current-position :up) (travelablep current-position :down)) 1 0)))))
+ (setf pattern (print-map-pattern-cache (car char) (list clim:+background-ink+ (cdr char))))
+ (when (get-zone current-position)
+ (clim:with-output-as-presentation
+ (*standard-output* (get-zone current-position) 'zone)
+ (clim:draw-pattern* *standard-output* pattern x-pos y-pos)))))))))
+ (when c:*application-frame*
+ (clim:stream-set-cursor-position *standard-output* start-x (+ start-y (* 31 (the (unsigned-byte 32) (clim:pattern-height pattern)))))))))))
(defunassert get-zone-text (text)
- (text (or string coerced-function))
+ (text (or string coerced-function))
(typecase text
(string
text)
@@ -467,8 +467,8 @@
old-direction)
(keyword
(iter (for (k v) on (warp-points-of (get-zone old-position)) by 'cddr)
- (when (and (string= k old-direction) v)
- (leave k))))
+ (when (and (string= k old-direction) v)
+ (leave k))))
(symbol old-direction)))))
(format t "~a~%" (get-zone-text (if (and old-position old-direction (getf-direction old-position old-direction :exit-text))
(getf-direction old-position old-direction :exit-text)
@@ -493,27 +493,27 @@
(z '(0 0 1) :up stairs)
(z '(0 0 -1) :down stairs)))
(iter (for (a b) on (warp-points-of (get-zone position)) by #'cddr)
- (when (and (get-zone b) (not (hiddenp (get-zone b))))
- (format t "To ~s is ~a. " a (name-of (get-zone b)))))
+ (when (and (get-zone b) (not (hiddenp (get-zone b))))
+ (format t "To ~s is ~a. " a (name-of (get-zone b)))))
(format t "~%"))
(defun get-inventory-list ()
(iter (for i in (inventory-of (player-of *game*))) (collect (symbol-name (type-of i)))))
(defunassert filter-items (items type)
- (items list type type-specifier)
+ (items list type type-specifier)
"This function will return all items in the list @var{ITEMS} that is of type @var{TYPE}"
(iter (for item in items)
- (when (typep item type)
- (collect item))))
+ (when (typep item type)
+ (collect item))))
(defunassert swell-up% (user)
- (user base-character)
+ (user base-character)
(iter (for i in (filter-items (wear-of user) 'closed-bottoms))
- (if (waterproofp i)
- (finish)
- (progn
- (setf (sogginess-of i) (sogginess-capacity-of i))
- (collect i)))))
+ (if (waterproofp i)
+ (finish)
+ (progn
+ (setf (sogginess-of i) (sogginess-capacity-of i))
+ (collect i)))))
(defunassert swell-up (user &aux (swollen-clothes (swell-up% user)) (name (name-of user)))
- (user base-character)
+ (user base-character)
(cond
((filter-items swollen-clothes 'diaper)
(format t "~a's diapers swells up humorously~%~%" name))
@@ -522,26 +522,23 @@
((filter-items swollen-clothes 'stuffer)
(format t "~a's incontinence pad swells up~%~%" name)))
(pop-from-expansion user))
-(defun swell-up-all ()
- (swell-up (player-of *game*))
- (iter (for i in (allies-of *game*)) (swell-up i)))
(defunassert total-thickness (clothing)
- (clothing list)
+ (clothing list)
(iter (for i in (filter-items clothing 'closed-bottoms))
- (with j = 0)
- (incf j (get-diaper-expansion i))
- (finally (return j))))
+ (with j = 0)
+ (incf j (get-diaper-expansion i))
+ (finally (return j))))
(defun fast-thickness (list item)
#+sbcl (declare (type list list)
(type clothing item))
(s:nlet execute (list item (count 0))
- (if (or (eq (car list) item) (endp list))
- count
- (execute (cdr list) item (if (typep (car list) 'closed-bottoms)
- (+ count (get-diaper-expansion (car list)))
- count)))))
+ (if (or (eq (car list) item) (endp list))
+ count
+ (execute (cdr list) item (if (typep (car list) 'closed-bottoms)
+ (+ count (get-diaper-expansion (car list)))
+ count)))))
(defunassert pop-from-expansion (user &optional wet/mess &aux (reverse-wear (nreverse (wear-of user))) (last (car reverse-wear)) (return ()))
- (user base-character)
+ (user base-character)
(macrolet ((pushclothing (i wet/mess return)
`(progn
(when (and (getf (car ,wet/mess) :wet-amount)
@@ -552,83 +549,109 @@
(pushnew ,i (getf (cdr ,wet/mess) :popped)))
(pushnew ,i ,return))))
(iter
- (for item in reverse-wear)
- (let* ((thickness-capacity (if (typep item 'bottoms) (thickness-capacity-of item)))
- (thickness-capacity-threshold (if (typep item 'bottoms) (thickness-capacity-threshold-of item)))
- (total-thickness (if (and (typep item 'bottoms)
- thickness-capacity
- thickness-capacity-threshold)
- (fast-thickness reverse-wear item))))
- (declare (type (or null (real 0)) thickness-capacity thickness-capacity-threshold total-thickness))
- (when
- (and (not (eq item last))
- total-thickness
- thickness-capacity
- thickness-capacity-threshold
- (> total-thickness (+ thickness-capacity thickness-capacity-threshold)))
- (typecase item
- (onesie/closed
- (toggle-onesie% item)
- (if (lockedp item)
- (progn (format t "~a's ~a pops open from the expansion destroying the lock in the process~%~%"
- (name-of user)
- (name-of item))
- (setf (lockedp item) nil))
- (format t "~a's ~a pops open from the expansion~%~%"
- (name-of user)
- (name-of item)))
- (pushclothing (the item item) wet/mess return))
- ((or incontinence-product snap-bottoms)
- (push item (inventory-of (if (typep user 'team-member)
- (player-of *game*)
- user)))
- (a:deletef (the list reverse-wear) item :count 1)
- (format t "~a's ~a comes off from the expansion~%~%"
- (name-of user)
- (name-of item))
- (pushclothing (the item item) wet/mess return))
- ((and bottoms (not incontinence-product))
- (a:deletef (the list reverse-wear) item :count 1)
- (format t "~a's ~a tears from the expansion and is destroyed~%~%"
- (name-of user)
- (name-of item))
- (pushclothing (the item item) wet/mess return))))))
+ (for item in reverse-wear)
+ (let* ((thickness-capacity (if (typep item 'bottoms) (thickness-capacity-of item)))
+ (thickness-capacity-threshold (if (typep item 'bottoms) (thickness-capacity-threshold-of item)))
+ (total-thickness (if (and (typep item 'bottoms)
+ thickness-capacity
+ thickness-capacity-threshold)
+ (fast-thickness reverse-wear item))))
+ (declare (type (or null (real 0)) thickness-capacity thickness-capacity-threshold total-thickness))
+ (when
+ (and (not (eq item last))
+ total-thickness
+ thickness-capacity
+ thickness-capacity-threshold
+ (> total-thickness (+ thickness-capacity thickness-capacity-threshold)))
+ (typecase item
+ (onesie/closed
+ (toggle-onesie% item)
+ (if (lockedp item)
+ (progn (format t "~a's ~a pops open from the expansion destroying the lock in the process~%~%"
+ (name-of user)
+ (name-of item))
+ (setf (lockedp item) nil))
+ (format t "~a's ~a pops open from the expansion~%~%"
+ (name-of user)
+ (name-of item)))
+ (pushclothing (the item item) wet/mess return))
+ ((or incontinence-product snap-bottoms)
+ (push item (inventory-of (if (typep user 'team-member)
+ (player-of *game*)
+ user)))
+ (a:deletef (the list reverse-wear) item :count 1)
+ (format t "~a's ~a comes off from the expansion~%~%"
+ (name-of user)
+ (name-of item))
+ (pushclothing (the item item) wet/mess return))
+ ((and bottoms (not incontinence-product))
+ (a:deletef (the list reverse-wear) item :count 1)
+ (format t "~a's ~a tears from the expansion and is destroyed~%~%"
+ (name-of user)
+ (name-of item))
+ (pushclothing (the item item) wet/mess return))))))
(setf (wear-of user) (nreverse reverse-wear))
(cond ((or (getf (car wet/mess) :popped) (getf (cdr wet/mess) :popped))
(values wet/mess :wet/mess))
(return (values return :return))
(t (values nil nil)))))
(defunassert thickest-sort (clothing)
- (clothing list)
+ (clothing list)
(s:dsu-sort (iter (for i in clothing)
- (when (typep i 'closed-bottoms)
- (collect i)))
+ (when (typep i 'closed-bottoms)
+ (collect i)))
'>
:key 'get-diaper-expansion))
(defunassert thickest (clothing &optional n &aux (a (iter (for i in clothing)
- (when (typep i 'closed-bottoms)
- (collect i)))))
- (clothing list n (or null unsigned-byte))
+ (when (typep i 'closed-bottoms)
+ (collect i)))))
+ (clothing list n (or null unsigned-byte))
(if n
(the (values list &optional)
(s:bestn n a '> :key 'get-diaper-expansion :memo t))
(iter (for i in a)
- (finding i maximizing (get-diaper-expansion i)))))
+ (finding i maximizing (get-diaper-expansion i)))))
+(defun handle-faint (character)
+ (let ((faintedp (member character (fainted-of *battle*))))
+ (cond ((and (<= (health-of character) 0) (not faintedp))
+ (f:fmt t (name-of character) " has fainted" #\Newline)
+ (pushnew character (fainted-of *battle*))
+ (a:deletef (turn-queue-of *battle*) character)
+ t)
+ ((and (> (health-of character) 0) faintedp)
+ (setf (fainted-of *battle*) (s:delq character (fainted-of *battle*)))
+ nil)
+ (t (and faintedp t)))))
+(defun handle-status-effects (character &optional battle)
+ (iter (for i in (status-conditions-of 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))
+ (run-equip-effects character)
+ (if battle
+ (let ((faintedp (handle-faint character)))
+ (process-potty character battle)
+ faintedp)
+ (process-potty character battle)))
(defun move-to-zone (new-position &key ignore-lock direction old-position)
(declare (type list new-position old-position)
(type symbol direction))
(when (iter (for i in (cons (player-of *game*) (allies-of *game*)))
- (let ((wear (typecase (must-wear-of (get-zone new-position))
- (cons (must-wear-of (get-zone new-position)))
- (symbol (gethash (must-wear-of *game*) (must-wear-of (get-zone new-position))))))
- (not-wear (typecase (must-not-wear-of (get-zone new-position))
- (cons (must-not-wear-of (get-zone new-position)))
- (symbol (gethash (must-not-wear-of *game*) (must-not-wear-of (get-zone new-position)))))))
- (when (or (and (list-length-> 1 (filter-items (wear-of i) (car wear)))
- (not (funcall (coerce (cdr wear) 'function) i)))
- (and (list-length-< 0 (filter-items (wear-of i) (car not-wear)))
- (not (funcall (coerce (cdr not-wear) 'function) i))))
- (leave t))))
+ (let ((wear (typecase (must-wear-of (get-zone new-position))
+ (cons (must-wear-of (get-zone new-position)))
+ (symbol (gethash (must-wear-of *game*) (must-wear-of (get-zone new-position))))))
+ (not-wear (typecase (must-not-wear-of (get-zone new-position))
+ (cons (must-not-wear-of (get-zone new-position)))
+ (symbol (gethash (must-not-wear-of *game*) (must-not-wear-of (get-zone new-position)))))))
+ (when (or (and (list-length-> 1 (filter-items (wear-of i) (car wear)))
+ (not (funcall (coerce (cdr wear) 'function) i)))
+ (and (list-length-< 0 (filter-items (wear-of i) (car not-wear)))
+ (not (funcall (coerce (cdr not-wear) 'function) i))))
+ (leave t))))
(return-from move-to-zone))
(when (and (not ignore-lock)
(or (and (lockedp (get-zone new-position))
@@ -657,12 +680,11 @@
(setf (lockedp (get-zone new-position)) nil)
(remf (getf (direction-attributes-of (get-zone (position-of (player-of *game*)))) direction) :locked))
(setf (position-of (player-of *game*)) new-position)
- (when (underwaterp (get-zone (position-of (player-of *game*)))) (swell-up-all))
- (process-potty)
- (run-equip-effects (player-of *game*))
- (iter (for i in (allies-of *game*))
- (process-potty i)
- (run-equip-effects i))
+ (iter (for character in (cons (player-of *game*) (allies-of *game*)))
+ (with underwater = (underwaterp (get-zone (position-of (player-of *game*)))))
+ (when underwater
+ (swell-up character))
+ (handle-status-effects character nil))
(print-enter-text (position-of (player-of *game*)) old-position direction)
(s:run-hook (sc:find-hook 'yadfa-world:move) direction old-position)
(cond ((continue-battle-of (get-zone (position-of (player-of *game*))))
@@ -676,19 +698,19 @@
(return-from move-to-zone))
((resolve-enemy-spawn-list (get-zone (position-of (player-of *game*))))
(let ((enemy-spawn-list (iter (for i in (resolve-enemy-spawn-list (get-zone (position-of (player-of *game*)))))
- (when (< (random 1.0l0) (getf i :chance))
- (leave (cond ((getf i :eval)
- (eval (getf i :eval)))
- ((getf i :lambda)
- (funcall (coerce (getf i :lambda) 'function)))
- (t (getf i :enemies)))))))
+ (when (< (random 1.0l0) (getf i :chance))
+ (leave (cond ((getf i :eval)
+ (eval (getf i :eval)))
+ ((getf i :lambda)
+ (funcall (coerce (getf i :lambda) 'function)))
+ (t (getf i :enemies)))))))
(team-npc-spawn-list (iter (for i in (resolve-team-npc-spawn-list (get-zone (position-of (player-of *game*)))))
- (when (< (random 1.0l0) (getf i :chance))
- (leave (cond ((getf i :eval)
- (eval (getf i :eval)))
- ((getf i :lambda)
- (funcall (coerce (getf i :lambda) 'function)))
- (t (getf i :enemies))))))))
+ (when (< (random 1.0l0) (getf i :chance))
+ (leave (cond ((getf i :eval)
+ (eval (getf i :eval)))
+ ((getf i :lambda)
+ (funcall (coerce (getf i :lambda) 'function)))
+ (t (getf i :enemies))))))))
(when enemy-spawn-list
(set-new-battle enemy-spawn-list :team-npcs team-npc-spawn-list))))))
(defun move-to-secret-underground ()
@@ -706,9 +728,9 @@
(return-from move-to-pocket-map))
(unless (get-zone '(0 0 0 pocket-map))
(make-pocket-zone (0 0 0)
- :name "Pocket Map Entrance"
- :description "Welcome to the Pocket Map. It's like the secret bases in Pokémon, except you customize it by scripting, and you can take it with you."
- :enter-text "You're at the start of the Pocket Map. Use the Pocket Map machine again at anytime to exit."))
+ :name "Pocket Map Entrance"
+ :description "Welcome to the Pocket Map. It's like the secret bases in Pokémon, except you customize it by scripting, and you can take it with you."
+ :enter-text "You're at the start of the Pocket Map. Use the Pocket Map machine again at anytime to exit."))
(let ((old-position (position-of (player-of *game*))))
(move-to-zone (if (eq (fourth (position-of (player-of *game*))) :pocket-map)
(getf (attributes-of item) :pocket-map-position)
@@ -719,10 +741,10 @@
(defunassert wet (&key (wet-amount t) force-fill-amount pants-down accident force-wet-amount (wetter (player-of *game*)) (clothes nil clothes-supplied-p)
&aux (return-value ()) (affected-clothes ()) (random (random 4)) (amount nil)
(clothes (if clothes-supplied-p clothes (wear-of wetter))))
- (force-fill-amount (or null real)
- force-wet-amount (or boolean real)
- wet-amount (or boolean real)
- wetter base-character)
+ (force-fill-amount (or null real)
+ force-wet-amount (or boolean real)
+ wet-amount (or boolean real)
+ wetter base-character)
#.(format nil "this function is mostly for mods, doesn't print text or diaper expansion, that's handled by other functions. @var{WETTER} is the instance of @code{BASE-CHARACTER} doing the flooding. @var{WET-AMOUNT} is the amount @var{WETTER} floods but won't flood if he/she can't go, passing @code{T} to @var{WET-AMOUNT} means to use @code{(BLADDER/CONTENTS-OF WETTER)}, @var{FORCE-WET-AMOUNT} causes @var{WETTER} to wet regardless. @var{FORCE-FILL-AMOUNT} will set @code{(BLADDER/CONTENTS-OF WETTER)} to that amount first. @var{PANTS-DOWN} is @code{T} if @var{WETTER} pulls his/her pants down first. @var{ACCIDENT} is @code{T} if the wetting isn't intentional and @var{WETTER} may or may not be able to stop the flow. if @var{CLOTHES} is passed, it will be the one @var{WETTER} floods, otherwise it will be @code{(wear-of @var{WETTER})}
~a."
@@ -745,9 +767,9 @@
(accident
(setf amount
(a:switch (random :test '=)
- (3 (* 4 (bladder/fill-rate-of wetter)))
- (2 (bladder/need-to-potty-limit-of wetter))
- (t (bladder/contents-of wetter)))))
+ (3 (* 4 (bladder/fill-rate-of wetter)))
+ (2 (bladder/need-to-potty-limit-of wetter))
+ (t (bladder/contents-of wetter)))))
(t (setf amount (cond ((eq wet-amount t)
(bladder/contents-of wetter))
((> wet-amount (bladder/contents-of wetter))
@@ -757,9 +779,9 @@
(setf (getf return-value :accident)
(if accident
(a:switch (random :test '=)
- (3 :dribble)
- (2 :some)
- (t :all))))
+ (3 :dribble)
+ (2 :some)
+ (t :all))))
(setf (getf return-value :old-bladder-contents) (bladder/contents-of wetter))
(let* ((amount-left amount))
(cond ((or pants-down (not (filter-items clothes 'closed-bottoms)))
@@ -768,19 +790,19 @@
(t
(decf (bladder/contents-of wetter) amount)
(iter (while (> amount-left 0))
- (for i in (reverse clothes))
- (when (typep i 'closed-bottoms)
- (cond ((> amount-left (- (sogginess-capacity-of i) (sogginess-of i)))
- (if (leakproofp i)
- (setf amount-left 0)
- (decf amount-left (- (sogginess-capacity-of i) (sogginess-of i))))
- (setf (sogginess-of i) (sogginess-capacity-of i))
- (push i affected-clothes)
- )
- ((> amount-left 0)
- (incf (sogginess-of i) amount-left)
+ (for i in (reverse clothes))
+ (when (typep i 'closed-bottoms)
+ (cond ((> amount-left (- (sogginess-capacity-of i) (sogginess-of i)))
+ (if (leakproofp i)
(setf amount-left 0)
- (push i affected-clothes)))))))
+ (decf amount-left (- (sogginess-capacity-of i) (sogginess-of i))))
+ (setf (sogginess-of i) (sogginess-capacity-of i))
+ (push i affected-clothes)
+ )
+ ((> amount-left 0)
+ (incf (sogginess-of i) amount-left)
+ (setf amount-left 0)
+ (push i affected-clothes)))))))
(setf (getf return-value :new-bladder-contents) (bladder/contents-of wetter))
(setf (getf return-value :affected-clothes) affected-clothes)
(setf (getf return-value :leak-amount) amount-left)
@@ -788,10 +810,10 @@
return-value)
(defunassert mess (&key (mess-amount t) force-fill-amount pants-down accident force-mess-amount (messer (player-of *game*)) (clothes nil clothes-supplied-p)
&aux (return-value ()) (affected-clothes ()) (amount nil) (clothes (if clothes-supplied-p clothes (wear-of messer))))
- (force-fill-amount (or null real)
- force-mess-amount (or boolean real)
- mess-amount (or boolean real)
- messer base-character)
+ (force-fill-amount (or null real)
+ force-mess-amount (or boolean real)
+ mess-amount (or boolean real)
+ messer base-character)
#.(format nil "this function is mostly for mods, doesn't print text or diaper expansion, that's handled by other functions. @var{MESSER} is the instance of @code{BASE-CHARACTER} doing the messing. @var{MESS-AMOUNT} is the amount @var{MESSER} messes but won't mess if he/she can't go, passing @code{T} to @var{MESS-AMOUNT} means to use @code{(BOWELS/CONTENTS-OF MESSER)}, @var{FORCE-MESS-AMOUNT} causes @var{MESSER} to mess regardless. @var{FORCE-FILL-AMOUNT} will set @code{(BOWELS/CONTENTS-OF MESSER)} to that amount first. @var{PANTS-DOWN} is @code{T} if @var{MESSER} pulls his/her pants down first. @var{ACCIDENT} is @code{T} if the messing isn't intentional. If @var{CLOTHES} is passed, it will be the one @var{MESSER} messes, otherwise it will be @code{(wear-of @var{MESSER})}
@@ -828,18 +850,18 @@
(t
(decf (bowels/contents-of messer) amount)
(iter (while (> amount-left 0))
- (for i in (reverse clothes))
- (when (typep i 'closed-bottoms)
- (cond ((> amount-left (- (messiness-capacity-of i) (messiness-of i)))
- (if (leakproofp i)
- (setf amount-left 0)
- (decf amount-left (- (messiness-capacity-of i) (messiness-of i))))
- (setf (messiness-of i) (messiness-capacity-of i))
- (push i affected-clothes))
- ((> amount-left 0)
- (incf (messiness-of i) amount-left)
+ (for i in (reverse clothes))
+ (when (typep i 'closed-bottoms)
+ (cond ((> amount-left (- (messiness-capacity-of i) (messiness-of i)))
+ (if (leakproofp i)
(setf amount-left 0)
- (push i affected-clothes)))))))
+ (decf amount-left (- (messiness-capacity-of i) (messiness-of i))))
+ (setf (messiness-of i) (messiness-capacity-of i))
+ (push i affected-clothes))
+ ((> amount-left 0)
+ (incf (messiness-of i) amount-left)
+ (setf amount-left 0)
+ (push i affected-clothes)))))))
(setf (getf return-value :new-bowels-contents) (bowels/contents-of messer))
(setf (getf return-value :affected-clothes) affected-clothes)
(setf (getf return-value :leak-amount) amount-left)
@@ -847,9 +869,9 @@
(setf (fart-count-of messer) 0)
return-value)
(defunassert potty-on-toilet (prop &key wet mess pants-down (user (player-of *game*)))
- (prop yadfa-props:toilet
- wet (or boolean real)
- mess (or boolean real))
+ (prop yadfa-props:toilet
+ wet (or boolean real)
+ mess (or boolean real))
(when (notany #'identity (list wet mess))
(setf wet t
mess t))
@@ -865,13 +887,13 @@
:user user))
(return-from potty-on-toilet))
((and pants-down (iter (for i in (filter-items (wear-of user) 'closed-bottoms))
- (when (lockedp i)
- (format t "~a struggles to remove ~a ~a, realizes ~a can't, then starts panicking while doing a potty dance.~%"
- (name-of user)
- (if (malep user) "his" "her")
- (name-of i)
- (if (malep user) "he" "she"))
- (leave t))))
+ (when (lockedp i)
+ (format t "~a struggles to remove ~a ~a, realizes ~a can't, then starts panicking while doing a potty dance.~%"
+ (name-of user)
+ (if (malep user) "his" "her")
+ (name-of i)
+ (if (malep user) "he" "she"))
+ (leave t))))
(return-from potty-on-toilet)))
(let* ((mess-return-value (when mess
(mess :mess-amount mess :pants-down pants-down :messer user)))
@@ -909,8 +931,8 @@
out)
(format t "~a~%" (a:random-elt out))))))
(defunassert potty-on-self-or-prop (prop &key wet mess pants-down (user (player-of *game*)))
- (wet (or boolean real)
- mess (or boolean real))
+ (wet (or boolean real)
+ mess (or boolean real))
(when (notany #'identity (list wet mess))
(setf wet t
mess t))
@@ -928,13 +950,13 @@
:user user))
(return-from potty-on-self-or-prop))
((and pants-down (iter (for i in (filter-items (wear-of user) 'closed-bottoms))
- (when (lockedp i)
- (format t "~a struggles to remove ~a ~a, realizes ~a can't, then starts panicking while doing a potty dance.~%"
- (name-of user)
- (if (malep user) "his" "her")
- (name-of i)
- (if (malep user) "he" "she"))
- (leave t))))
+ (when (lockedp i)
+ (format t "~a struggles to remove ~a ~a, realizes ~a can't, then starts panicking while doing a potty dance.~%"
+ (name-of user)
+ (if (malep user) "his" "her")
+ (name-of i)
+ (if (malep user) "he" "she"))
+ (leave t))))
(return-from potty-on-self-or-prop)))
(let*
((mess-return-value (when mess
@@ -1280,38 +1302,6 @@
mess-return-value (cdr value))))
(funcall (coerce (potty-trigger-of (get-zone (position-of (player-of *game*)))) 'function)
(cons wet-return-value mess-return-value) user))))))))
-(defunassert process-potty (&optional (user (player-of *game*)))
- (user (or player ally))
- (let ((time-difference (- (time-of *game*) (last-process-potty-time-of user))))
- (fill-bladder user :times time-difference)
- (fill-bowels user :times time-difference))
- (setf (last-process-potty-time-of user) (time-of *game*))
- (let ((had-accident (if (typep user 'potty-trained-team-member)
- (cons (when (>= (bladder/contents-of user) (bladder/maximum-limit-of user))
- (wet :accident t :wetter user))
- (when (>= (bowels/contents-of user) (bowels/maximum-limit-of user))
- (mess :accident t :messer user)))
- (cons (when (>= (bladder/contents-of user) (bladder/need-to-potty-limit-of user))
- (wet :wetter user))
- (when (>= (bowels/contents-of user) (bowels/need-to-potty-limit-of user))
- (mess :messer user))))))
- (iter (for i in '(:wet :mess))
- (output-process-potty-text user
- (get-babyish-padding user)
- i
- (get-process-potty-action-type user
- i
- had-accident)
- had-accident))
- (multiple-value-bind
- (value key)
- (pop-from-expansion user had-accident)
- (when (eq key :wet/mess)
- (setf had-accident value)))
- (funcall (coerce (potty-trigger-of (get-zone (position-of (player-of *game*))))
- 'function)
- had-accident user)
- had-accident))
(defun coerce-element-types (element-types)
(iter (for element-type in (a:ensure-list element-types))
(collect (coerce-element-type element-type))))
@@ -1338,78 +1328,78 @@
(string= a (s:class-name-of b))
(eq a (s:class-name-of b))))))
(defunassert calculate-diaper-usage (user)
- (user base-character)
+ (user base-character)
(iter
- (with sogginess = 0)
- (with sogginess-capacity = 0)
- (with messiness = 0)
- (with messiness-capacity = 0)
- (for i in (wear-of user))
- (when (typep i 'closed-bottoms)
- (incf sogginess (sogginess-of i))
- (incf sogginess-capacity (sogginess-capacity-of i))
- (incf messiness (messiness-of i))
- (incf messiness-capacity (messiness-capacity-of i)))
- (finally (return `(:sogginess ,sogginess :sogginess-capacity ,sogginess-capacity
- :messiness ,messiness :messiness-capacity ,messiness-capacity)))))
+ (with sogginess = 0)
+ (with sogginess-capacity = 0)
+ (with messiness = 0)
+ (with messiness-capacity = 0)
+ (for i in (wear-of user))
+ (when (typep i 'closed-bottoms)
+ (incf sogginess (sogginess-of i))
+ (incf sogginess-capacity (sogginess-capacity-of i))
+ (incf messiness (messiness-of i))
+ (incf messiness-capacity (messiness-capacity-of i)))
+ (finally (return `(:sogginess ,sogginess :sogginess-capacity ,sogginess-capacity
+ :messiness ,messiness :messiness-capacity ,messiness-capacity)))))
(defunassert calculate-diaper-usage* (clothes)
- (clothes list)
+ (clothes list)
(iter
- (with sogginess = 0)
- (with sogginess-capacity = 0)
- (with messiness = 0)
- (with messiness-capacity = 0)
- (for i in clothes)
- (when (typep i 'closed-bottoms)
- (incf sogginess (sogginess-of i))
- (incf sogginess-capacity (sogginess-capacity-of i))
- (incf messiness (messiness-of i))
- (incf messiness-capacity (messiness-capacity-of i)))
- (finally (return `(:sogginess ,sogginess :sogginess-capacity ,sogginess-capacity
- :messiness ,messiness :messiness-capacity ,messiness-capacity)))))
+ (with sogginess = 0)
+ (with sogginess-capacity = 0)
+ (with messiness = 0)
+ (with messiness-capacity = 0)
+ (for i in clothes)
+ (when (typep i 'closed-bottoms)
+ (incf sogginess (sogginess-of i))
+ (incf sogginess-capacity (sogginess-capacity-of i))
+ (incf messiness (messiness-of i))
+ (incf messiness-capacity (messiness-capacity-of i)))
+ (finally (return `(:sogginess ,sogginess :sogginess-capacity ,sogginess-capacity
+ :messiness ,messiness :messiness-capacity ,messiness-capacity)))))
(defunassert calculate-level-to-exp (level)
- (level real)
+ (level real)
(floor (/ (* 4 (expt level 3)) 5)))
(defunassert calculate-exp-yield (target)
- (target enemy)
+ (target enemy)
(u:$ (exp-yield-of target) * (level-of target) / 7))
(defunassert calculate-wear-stats (user)
- (user base-character)
+ (user base-character)
(iter
- (with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
- (for i in (wear-of user))
- (iter
- (for (a b) on (wear-stats-of i) by #'cddr)
- (incf (getf j a) b))
- (finally (return j))))
+ (with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
+ (for i in (wear-of user))
+ (iter
+ (for (a b) on (wear-stats-of i) by #'cddr)
+ (incf (getf j a) b))
+ (finally (return j))))
(defunassert calculate-wield-stats (user)
- (user base-character)
+ (user base-character)
(iter
- (with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
- (for (a b) on (if (wield-of user) (wield-stats-of (wield-of user)) ()) by #'cddr)
- (incf (getf j a) b)
- (finally (return j))))
+ (with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
+ (for (a b) on (if (wield-of user) (wield-stats-of (wield-of user)) ()) by #'cddr)
+ (incf (getf j a) b)
+ (finally (return j))))
(defunassert calculate-stat-delta (user)
- (user base-character)
+ (user base-character)
(iter
- (with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
- (for i in (when *battle* (getf (status-conditions-of *battle*) user)))
- (iter
- (for (a b) on (stat-delta-of i) by #'cddr)
- (incf (getf j a) b))
- (finally (return j))))
+ (with j = (list :health 0 :attack 0 :defense 0 :energy 0 :speed 0))
+ (for i in (status-conditions-of user))
+ (iter
+ (for (a b) on (stat-delta-of i) by #'cddr)
+ (incf (getf j a) b))
+ (finally (return j))))
(defunassert calculate-stat-multiplier (user)
- (user base-character)
+ (user base-character)
(iter
- (with j = (list :health 1 :attack 1 :defense 1 :energy 1 :speed 1))
- (for i in (when *battle* (getf (status-conditions-of *battle*) user)))
- (iter
- (for (a b) on (stat-multiplier-of i) by #'cddr)
- (declare (ignorable b))
- (setf (getf j a) (* (getf j a))))
- (finally (return j))))
+ (with j = (list :health 1 :attack 1 :defense 1 :energy 1 :speed 1))
+ (for i in (status-conditions-of user))
+ (iter
+ (for (a b) on (stat-multiplier-of i) by #'cddr)
+ (declare (ignorable b))
+ (setf (getf j a) (* (getf j a))))
+ (finally (return j))))
(defunassert calculate-stat (user stat-key)
- (user base-character)
+ (user base-character)
(round (if (or (eq stat-key :health) (eq stat-key :energy))
(u:$ (u:$ (u:$ (u:$ (u:$ (getf (base-stats-of user) stat-key) +
(getf (iv-stats-of user) stat-key) +
@@ -1451,8 +1441,8 @@
('= '(nil 0))))))))))
(defun present-stats (user)
(updating-present-with-effective-frame (*query-io* :unique-id `(stats% ,user) :id-test #'equal)
- (clim:updating-output (*query-io*)
- (clim:present user (type-of user) :view yadfa-clim:+stat-view+))))
+ (clim:updating-output (*query-io*)
+ (clim:present user (type-of user) :view yadfa-clim:+stat-view+))))
(defun describe-item (item &optional wear)
(format t
"Name: ~a~%Resale Value: ~f~%Description:~%~a~%"
@@ -1467,16 +1457,16 @@
(format t "Ammo Type: ~s" (ammo-type-of item)))
(when (special-actions-of item)
(iter (for (a b) on (special-actions-of item) by #'cddr)
- (format t "Keyword: ~a~%Other Parameters: ~w~%Documentation: ~a~%~%Describe: ~a~%~%"
- a
- (cddr (lambda-list (action-lambda b)))
- (documentation b t)
- (with-output-to-string (s)
- (let ((*standard-output* s))
- (describe (action-lambda b)))))))
+ (format t "Keyword: ~a~%Other Parameters: ~w~%Documentation: ~a~%~%Describe: ~a~%~%"
+ a
+ (cddr (lambda-list (action-lambda b)))
+ (documentation b t)
+ (with-output-to-string (s)
+ (let ((*standard-output* s))
+ (describe (action-lambda b)))))))
t)
(defun finish-battle (&optional lose &aux (player (player-of *game*)) (male (malep player)) (name (name-of player))
- (position (position-of player)) (enemies (enemies-of *battle*)) (team (team-of *game*)))
+ (position (position-of player)) (enemies (enemies-of *battle*)) (team (team-of *game*)))
(if lose
(progn (format t "~a was defeated~%" name)
(setf (position-of player) (warp-on-death-point-of player))
@@ -1490,59 +1480,60 @@
(name-of (get-zone position))
position)
(iter (for user in (cons player (allies-of *game*)))
- (setf (health-of user) (calculate-stat user :health))
- (setf (energy-of user) (calculate-stat user :energy)))
+ (setf (health-of user) (calculate-stat user :health))
+ (setf (energy-of user) (calculate-stat user :energy)))
(let ((exp-gained (/ (iter (for enemy in enemies)
- (with j = 0)
- (incf j (calculate-exp-yield enemy))
- (finally (return j)))
+ (with j = 0)
+ (incf j (calculate-exp-yield enemy))
+ (finally (return j)))
2)))
(iter (for team-member in team)
- (incf (exp-of team-member) exp-gained)
- (let ((old-level (level-of team-member)))
- (iter (while (>= (exp-of team-member) (calculate-level-to-exp (+ (level-of team-member) 1))))
- (incf (level-of team-member)))
- (when (> (level-of team-member) old-level)
- (format t "~a level-uped to ~d~%" (name-of team-member) (level-of team-member))
- (iter (for level from (1+ old-level) to (level-of team-member))
- (iter (for learned-move in (learned-moves-of team-member))
- (when (= (car learned-move) level)
- (unless (get-move (cdr learned-move) team-member)
- (pushnewmove (cdr learned-move) team-member)
- (format t "~a learned ~a~%" (name-of team-member) (name-of (get-move (cdr learned-move) team-member))))))))))
- (setf *battle* nil))
+ (incf (exp-of team-member) exp-gained)
+ (let ((old-level (level-of team-member)))
+ (iter (while (>= (exp-of team-member) (calculate-level-to-exp (+ (level-of team-member) 1))))
+ (incf (level-of team-member)))
+ (when (> (level-of team-member) old-level)
+ (format t "~a level-uped to ~d~%" (name-of team-member) (level-of team-member))
+ (iter (for level from (1+ old-level) to (level-of team-member))
+ (iter (for learned-move in (learned-moves-of team-member))
+ (when (= (car learned-move) level)
+ (unless (get-move (cdr learned-move) team-member)
+ (pushnewmove (cdr learned-move) team-member)
+ (format t "~a learned ~a~%" (name-of team-member) (name-of (get-move (cdr learned-move) team-member)))))))))))
(iter (for team-member in team)
- (wet :force-fill-amount (bladder/maximum-limit-of team-member))
- (mess :force-fill-amount (bowels/maximum-limit-of team-member))))
+ (wet :force-fill-amount (bladder/maximum-limit-of team-member))
+ (mess :force-fill-amount (bowels/maximum-limit-of team-member))))
(progn (format t "~a won the battle~%~%" name)
(let ((items-looted (iter (for enemy in enemies)
- (with j = ())
- (setf j (append* j (inventory-of enemy) (wear-of enemy)))
- (setf (inventory-of enemy) nil
- (wear-of enemy) nil)
- (finally (return j))))
+ (with j = ())
+ (setf j (append* j (inventory-of enemy) (wear-of enemy)))
+ (setf (inventory-of enemy) nil
+ (wear-of enemy) nil)
+ (finally (return j))))
(bitcoins-looted (iter (for enemy in enemies)
- (with j = 0)
- (incf j (if (bitcoins-per-level-of enemy) (* (bitcoins-per-level-of enemy) (level-of enemy)) (bitcoins-of enemy)))
- (finally (return j))))
+ (with j = 0)
+ (incf j (if (bitcoins-per-level-of enemy)
+ (* (bitcoins-per-level-of enemy) (level-of enemy))
+ (bitcoins-of enemy)))
+ (finally (return j))))
(exp-gained (iter (for enemy in enemies)
- (with j = 0)
- (incf j (calculate-exp-yield enemy))
- (finally (return j))))
+ (with j = 0)
+ (incf j (calculate-exp-yield enemy))
+ (finally (return j))))
(win-events (win-events-of *battle*)))
(iter (for team-member in team)
- (incf (exp-of team-member) exp-gained)
- (let ((old-level (level-of team-member)))
- (iter (while (>= (exp-of team-member) (calculate-level-to-exp (+ (level-of team-member) 1))))
- (incf (level-of team-member)))
- (when (> (level-of team-member) old-level)
- (format t "~a level-uped to ~d~%" (name-of team-member) (level-of team-member))
- (iter (for level from (1+ old-level) to (level-of team-member))
- (iter (for learned-move in (learned-moves-of team-member))
- (when (= (car learned-move) level)
- (unless (get-move (cdr learned-move) team-member)
- (pushnewmove (cdr learned-move) team-member)
- (format t "~a learned ~a~%" (name-of team-member) (name-of (get-move (cdr learned-move) team-member))))))))))
+ (incf (exp-of team-member) exp-gained)
+ (let ((old-level (level-of team-member)))
+ (iter (while (>= (exp-of team-member) (calculate-level-to-exp (+ (level-of team-member) 1))))
+ (incf (level-of team-member)))
+ (when (> (level-of team-member) old-level)
+ (format t "~a level-uped to ~d~%" (name-of team-member) (level-of team-member))
+ (iter (for level from (1+ old-level) to (level-of team-member))
+ (iter (for learned-move in (learned-moves-of team-member))
+ (when (= (car learned-move) level)
+ (unless (get-move (cdr learned-move) team-member)
+ (pushnewmove (cdr learned-move) team-member)
+ (format t "~a learned ~a~%" (name-of team-member) (name-of (get-move (cdr learned-move) team-member))))))))))
(cond ((and items-looted (> bitcoins-looted 0))
(format t "~a loots ~d bitcoins and ~d ~a from the enemies~%"
name
@@ -1562,15 +1553,24 @@
(format t "~a loots ~d bitcoins from the enemy~%" name bitcoins-looted)))
(incf (bitcoins-of player) bitcoins-looted)
(a:nconcf (inventory-of player) items-looted)
- (setf *battle* nil)
(setf (continue-battle-of (get-zone position)) nil)
(trigger-event win-events))))
+ (setf *battle* nil)
+ (iter (for character in (team-of *game*))
+ ;; Most of the dialog outside of battle makes no sense when the character is fainted
+ ;; 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)))))
(switch-user-packages))
(defun wash (clothing)
(declare (type list clothing))
(iter (for i in (filter-items clothing 'closed-bottoms))
- (when (not (disposablep i))
- (setf (sogginess-of i) 0 (messiness-of i) 0))))
+ (when (not (disposablep i))
+ (setf (sogginess-of i) 0 (messiness-of i) 0))))
(defun go-to-sleep% (user)
(incf (time-of *game*) 60)
(let ((time-difference (- (time-of *game*) (last-process-potty-time-of user))))
@@ -1582,169 +1582,81 @@
(cons (wet :wetter user) (mess :messer user)))
(defun go-to-sleep ()
(iter (for i in (cons (player-of *game*) (allies-of *game*)))
- (let* ((return-value (go-to-sleep% i))
- (out ())
- (male (malep i))
- (hisher (if male "his" "her"))
- (name (name-of i))
- (cheshe (if male "He" "She")))
- (multiple-value-bind (value key)
- (pop-from-expansion i return-value)
- (when (eq key :wet/mess)
- (setf return-value value)))
- (format t "~a wakes up " (name-of i))
- (when (> (getf (car return-value) :wet-amount) 0)
- (cond ((filter-items (wear-of i) 'diaper)
- (if (> (getf (car return-value) :leak-amount) 0)
- (progn (push (format nil "feeling all cold and soggy. ~a checks ~a diaper and to ~a embarrassment finds out it's leaking profusely. Seems ~a wet the bed.~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (progn (push (format nil "and hears a squish . ~a looks down at ~a diaper, notices that it's soggy and then folds ~a ears back and blushes. Looks like ~a wet the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (push (format nil "and looks down and pokes ~a diaper, then gets all blushy when it squishes. Seems ~a wet the bed~%"
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
- ((filter-items (wear-of i) 'pullup)
- (if (> (getf (car return-value) :leak-amount) 0)
- (progn (push (format nil "feeling all cold and soggy. ~a checks ~a pullups and to ~a embarrassment finds out it's leaking profusely. Seems ~a wet the bed.~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (progn (push (format nil "and hears a squish. ~a looks down at ~a pullups, notices that ~a and then folds ~a ears back and blushes. Looks like ~a wet the bed~%"
- cheshe
- (if (filter-items (wear-of i) '(ab-clothing pullup))
- "the little pictures have faded"
- "it's soggy")
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
- ((filter-items (wear-of i) 'stuffer)
- (if (> (getf (car return-value) :leak-amount) 0)
- (progn (push (format nil "feeling all cold and soggy. ~a notices ~a PJs, the padding under ~a PJs, and bed are soaked. Seems ~a wet the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (progn (push (format nil "and hears a squish from under ~a PJs. ~a checks the incontinence pad under them and notices that they're soaked and then folds ~a ears back and blushes. Looks like ~a wet the bed~%"
- hisher
- cheshe
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
- ((filter-items (wear-of i) 'closed-bottoms)
- (push (format nil "feeling all cold and soggy. ~a notices ~a PJs and bed are soaked then folds ~a ears back and blushes. Seems ~a wet the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (t
- (push (format nil "feeling all cold and soggy. ~a notices the bed is soaked then folds ~a ears back and blushes. Seems ~a wet the bed~%"
- cheshe
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
- (when (and (> (getf (cdr return-value) :mess-amount) 0) (> (getf (car return-value) :wet-amount) 0))
- (format t "~a is also " (name-of i)))
- (when (> (getf (cdr return-value) :mess-amount) 0)
- (cond
- ((filter-items (wear-of i) 'diaper)
- (if (> (getf (cdr return-value) :leak-amount) 0)
- (progn
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a diaper is leaking poo all over the bed. Seems ~a messed the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (progn
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a diaper is filled with poo. Seems ~a messed the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
+ (let* ((return-value (go-to-sleep% i))
+ (out ())
+ (male (malep i))
+ (hisher (if male "his" "her"))
+ (name (name-of i))
+ (cheshe (if male "He" "She")))
+ (multiple-value-bind (value key)
+ (pop-from-expansion i return-value)
+ (when (eq key :wet/mess)
+ (setf return-value value)))
+ (format t "~a wakes up " (name-of i))
+ (when (> (getf (car return-value) :wet-amount) 0)
+ (cond ((filter-items (wear-of i) 'diaper)
+ (if (> (getf (car return-value) :leak-amount) 0)
+ (progn (push (format nil "feeling all cold and soggy. ~a checks ~a diaper and to ~a embarrassment finds out it's leaking profusely. Seems ~a wet the bed.~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (progn (push (format nil "and hears a squish . ~a looks down at ~a diaper, notices that it's soggy and then folds ~a ears back and blushes. Looks like ~a wet the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (push (format nil "and looks down and pokes ~a diaper, then gets all blushy when it squishes. Seems ~a wet the bed~%"
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))
((filter-items (wear-of i) 'pullup)
- (if (> (getf (cdr return-value) :leak-amount) 0)
- (progn
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a pullups is leaking poo all over the bed. Seems ~a messed the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (progn
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a pullup is filled with poo. Seems ~a messed the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
+ (if (> (getf (car return-value) :leak-amount) 0)
+ (progn (push (format nil "feeling all cold and soggy. ~a checks ~a pullups and to ~a embarrassment finds out it's leaking profusely. Seems ~a wet the bed.~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (progn (push (format nil "and hears a squish. ~a looks down at ~a pullups, notices that ~a and then folds ~a ears back and blushes. Looks like ~a wet the bed~%"
+ cheshe
+ (if (filter-items (wear-of i) '(ab-clothing pullup))
+ "the little pictures have faded"
+ "it's soggy")
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))
((filter-items (wear-of i) 'stuffer)
- (if (> (getf (cdr return-value) :leak-amount) 0)
- (progn
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a incontinence pad is leaking poo all over the bed and PJs. Seems ~a messed the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))
- (progn
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a incontinence pad is filled with poo. Seems ~a messed the bed~%"
- cheshe
- hisher
- hisher
- name)
- out)
- (format t "~a" (a:random-elt out))
- (setf out ()))))
+ (if (> (getf (car return-value) :leak-amount) 0)
+ (progn (push (format nil "feeling all cold and soggy. ~a notices ~a PJs, the padding under ~a PJs, and bed are soaked. Seems ~a wet the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (progn (push (format nil "and hears a squish from under ~a PJs. ~a checks the incontinence pad under them and notices that they're soaked and then folds ~a ears back and blushes. Looks like ~a wet the bed~%"
+ hisher
+ cheshe
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))
((filter-items (wear-of i) 'closed-bottoms)
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a PJs have poo in them and is getting on the bed. Seems ~a messed the bed~%"
+ (push (format nil "feeling all cold and soggy. ~a notices ~a PJs and bed are soaked then folds ~a ears back and blushes. Seems ~a wet the bed~%"
cheshe
hisher
hisher
@@ -1753,35 +1665,123 @@
(format t "~a" (a:random-elt out))
(setf out ()))
(t
- (push (format nil
- "feeling all mushy. ~a notices to ~a embarrassment that ~a bed has poo on it. Seems ~a messed the bed~%"
+ (push (format nil "feeling all cold and soggy. ~a notices the bed is soaked then folds ~a ears back and blushes. Seems ~a wet the bed~%"
cheshe
hisher
- hisher
name)
out)
(format t "~a" (a:random-elt out))
- (setf out ()))))))
+ (setf out ()))))
+ (when (and (> (getf (cdr return-value) :mess-amount) 0) (> (getf (car return-value) :wet-amount) 0))
+ (format t "~a is also " (name-of i)))
+ (when (> (getf (cdr return-value) :mess-amount) 0)
+ (cond
+ ((filter-items (wear-of i) 'diaper)
+ (if (> (getf (cdr return-value) :leak-amount) 0)
+ (progn
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a diaper is leaking poo all over the bed. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (progn
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a diaper is filled with poo. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))
+ ((filter-items (wear-of i) 'pullup)
+ (if (> (getf (cdr return-value) :leak-amount) 0)
+ (progn
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a pullups is leaking poo all over the bed. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (progn
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a pullup is filled with poo. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))
+ ((filter-items (wear-of i) 'stuffer)
+ (if (> (getf (cdr return-value) :leak-amount) 0)
+ (progn
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a incontinence pad is leaking poo all over the bed and PJs. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (progn
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a incontinence pad is filled with poo. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))
+ ((filter-items (wear-of i) 'closed-bottoms)
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a PJs have poo in them and is getting on the bed. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))
+ (t
+ (push (format nil
+ "feeling all mushy. ~a notices to ~a embarrassment that ~a bed has poo on it. Seems ~a messed the bed~%"
+ cheshe
+ hisher
+ hisher
+ name)
+ out)
+ (format t "~a" (a:random-elt out))
+ (setf out ()))))))
t)
(defunassert shopfun (items-for-sale &key items-to-buy items-to-sell user format-items)
- (user (or base-character null)
- items-to-buy (or list boolean)
- items-to-sell (or list boolean)
- items-for-sale list)
+ (user (or base-character null)
+ items-to-buy (or list boolean)
+ items-to-sell (or list boolean)
+ items-for-sale list)
(when items-to-buy
(if (eq items-to-buy t)
(let (item quantity)
(accept-with-effective-frame (clim:accepting-values (*query-io* :resynchronize-every-pass t)
- (fresh-line *query-io*)
- (setf item (clim:accept `(clim:member-alist ,(iter (for i in items-for-sale)
- (collect (list (name-of (apply 'make-instance (car i) (eval (cdr i))))
- i)))) :prompt "Item"
- :view (make-instance 'clim:radio-box-view
- :orientation :vertical)
- :stream *query-io*))
- (fresh-line *query-io*)
- (setf quantity (clim:accept 'string :prompt "Quantity"
- :view clim:+text-field-view+ :stream *query-io*))))
+ (fresh-line *query-io*)
+ (setf item (clim:accept `(clim:member-alist ,(iter (for i in items-for-sale)
+ (collect (list (name-of (apply 'make-instance (car i) (eval (cdr i))))
+ i)))) :prompt "Item"
+ :view (make-instance 'clim:radio-box-view
+ :orientation :vertical)
+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf quantity (clim:accept 'string :prompt "Quantity"
+ :view clim:+text-field-view+ :stream *query-io*))))
(when (and quantity item (handler-case (if (typep (parse-integer quantity) '(integer 1 *))
t
(progn (format t "Quantity must be an '(integer 1 *)~%")
@@ -1810,83 +1810,83 @@
(or (plural-name-of temp) (format nil "~as" (name-of temp)))
(* (value-of temp) quantity)))))))
(iter (for i in items-to-buy)
- (let ((item (when (list-length-<= (car i) items-for-sale)
- (apply #'make-instance
- (car (nth (car i) items-for-sale))
- (eval (cdr (nth (car i) items-for-sale)))))))
- (cond ((not item)
- (format t "item ~d doesn't exist~%" (car i)))
- ((> (* (value-of item) (cdr i)) (bitcoins-of user))
- (format t "You don't have enough bitcoins to buy ~a~%"
- (if (= (cdr i) 1)
- (format nil "that ~a" (name-of item))
- (format nil "~d ~a"
- (cdr i)
- (if (plural-name-of item)
- (plural-name-of item)
- (format nil "~as" (name-of item)))))))
- (t (dotimes (j (cdr i))
- (push (apply #'make-instance
- (car (nth (car i) items-for-sale))
- (eval (cdr (nth (car i) items-for-sale))))
- (inventory-of user)))
- (decf (bitcoins-of user) (* (value-of item) (cdr i)))
- (format t "You buy ~d ~a for ~f bitcoins~%"
- (cdr i)
- (or (plural-name-of item) (format nil "~as" (name-of item)))
- (* (value-of item) (cdr i)))))))))
+ (let ((item (when (list-length-<= (car i) items-for-sale)
+ (apply #'make-instance
+ (car (nth (car i) items-for-sale))
+ (eval (cdr (nth (car i) items-for-sale)))))))
+ (cond ((not item)
+ (format t "item ~d doesn't exist~%" (car i)))
+ ((> (* (value-of item) (cdr i)) (bitcoins-of user))
+ (format t "You don't have enough bitcoins to buy ~a~%"
+ (if (= (cdr i) 1)
+ (format nil "that ~a" (name-of item))
+ (format nil "~d ~a"
+ (cdr i)
+ (if (plural-name-of item)
+ (plural-name-of item)
+ (format nil "~as" (name-of item)))))))
+ (t (dotimes (j (cdr i))
+ (push (apply #'make-instance
+ (car (nth (car i) items-for-sale))
+ (eval (cdr (nth (car i) items-for-sale))))
+ (inventory-of user)))
+ (decf (bitcoins-of user) (* (value-of item) (cdr i)))
+ (format t "You buy ~d ~a for ~f bitcoins~%"
+ (cdr i)
+ (or (plural-name-of item) (format nil "~as" (name-of item)))
+ (* (value-of item) (cdr i)))))))))
(when items-to-sell
(if (eq items-to-sell t)
(let (items)
(accept-with-effective-frame (clim:accepting-values (*query-io* :resynchronize-every-pass t)
- (setf items (clim:accept `(clim:subset-alist ,(iter (for item in (remove-duplicates (inventory-of user)))
- (collect (cons (name-of item)
- item)))) :prompt "Items"
- :view clim:+check-box-view+ :stream *query-io*))))
+ (setf items (clim:accept `(clim:subset-alist ,(iter (for item in (remove-duplicates (inventory-of user)))
+ (collect (cons (name-of item)
+ item)))) :prompt "Items"
+ :view clim:+check-box-view+ :stream *query-io*))))
(iter (for i in items)
- (format t "You sell your ~a for ~f bitcoins~%"
- (name-of i)
- (/ (value-of i) 2))
- (incf (bitcoins-of user) (/ (value-of i) 2)))
+ (format t "You sell your ~a for ~f bitcoins~%"
+ (name-of i)
+ (/ (value-of i) 2))
+ (incf (bitcoins-of user) (/ (value-of i) 2)))
(a:deletef (the list (inventory-of user)) items :test (lambda (o e)
(s:memq e o))))
(let ((items (sort (remove-duplicates items-to-sell) #'<)))
(setf items (iter (generate i in items)
- (for j in (inventory-of user))
- (for (the fixnum k) upfrom 0)
- (when (first-iteration-p)
- (next i))
- (when (= k i)
- (collect j)
- (next i))))
+ (for j in (inventory-of user))
+ (for (the fixnum k) upfrom 0)
+ (when (first-iteration-p)
+ (next i))
+ (when (= k i)
+ (collect j)
+ (next i))))
(unless items
(format t "Those items aren't valid")
(return-from shopfun))
(iter (for i in items)
- (when (not (sellablep i))
- (format t "That item isn't sellable~%~%")
- (return-from shopfun)))
+ (when (not (sellablep i))
+ (format t "That item isn't sellable~%~%")
+ (return-from shopfun)))
(iter (for i in items)
- (format t "You sell your ~a for ~f bitcoins~%"
- (name-of (nth i (inventory-of user)))
- (/ (value-of (nth i (inventory-of user))) 2))
- (incf (bitcoins-of user) (/ (value-of i) 2)))
+ (format t "You sell your ~a for ~f bitcoins~%"
+ (name-of (nth i (inventory-of user)))
+ (/ (value-of (nth i (inventory-of user))) 2))
+ (incf (bitcoins-of user) (/ (value-of i) 2)))
(a:deletef (the list (inventory-of user)) items
:test (lambda (o e)
(s:memq e o))))))
(when format-items
(format t "~10a~40a~10@a~%" "Index" "Item" "Price")
(iter (for i in items-for-sale)
- (for (the fixnum j) upfrom 0)
- (let ((item (apply #'make-instance (car i) (eval (cdr i)))))
- (format t "~10a~40a~10@a~%" j (name-of item) (value-of item))))))
+ (for (the fixnum j) upfrom 0)
+ (let ((item (apply #'make-instance (car i) (eval (cdr i)))))
+ (format t "~10a~40a~10@a~%" j (name-of item) (value-of item))))))
(defun getf-action-from-prop (position prop action)
(getf (actions-of (getf (get-props-from-zone position) prop)) action))
(defun (setf getf-action-from-prop) (new-value position prop action)
(setf (getf (actions-of (getf (get-props-from-zone position) prop)) action) new-value))
(defunassert wash-in-washer (washer)
- (washer (or yadfa-props:washer null))
+ (washer (or yadfa-props:washer null))
"washes your dirty diapers and all the clothes you've ruined. WASHER is an instance of a washer you want to put your clothes in."
(declare (ignorable washer))
(wash (inventory-of (player-of *game*)))
@@ -1905,24 +1905,12 @@
(team-attacked no-team-attack))
(flet ((check-if-done ()
(s:run-hooks '*cheat-hooks*)
- (iter (for i in (append (enemies-of *battle*) (team-of *game*)))
- (if (<= (health-of i) 0)
- (progn (setf (health-of i) 0)
- (unless (s:memq i (fainted-of *battle*))
- (format t "~a has fainted~%~%" (name-of i))
- (pushnew i (fainted-of *battle*)))
- (a:deletef (turn-queue-of *battle*) i))
- (a:deletef (fainted-of *battle*) i :count 1))
- (when (> (health-of i) (calculate-stat i :health))
- (setf (health-of i) (calculate-stat i :health)))
- (when (> (energy-of i) (calculate-stat i :energy))
- (setf (energy-of i) (calculate-stat i :energy))))
- (unless (iter (for i in (team-of *game*)) (when (> (health-of i) 0) (leave t)))
+ (iter (for character in (append (team-of *game*) (enemies-of *battle*)))
+ (handle-faint character))
+ (unless (set-difference (team-of *game*) (fainted-of *battle*))
(finish-battle t)
(return-from process-battle t))
- (unless (iter (for i in (enemies-of *battle*))
- (when (> (health-of i) 0)
- (leave t)))
+ (unless (set-difference (enemies-of *battle*) (fainted-of *battle*))
(finish-battle)
(return-from process-battle t))))
(check-if-done)
@@ -1942,27 +1930,27 @@
(name-of (first (turn-queue-of *battle*))) (name-of (get-move attack (first (turn-queue-of *battle*)))))
(return-from process-battle))
(iter (until (and team-attacked (typep (first (turn-queue-of *battle*)) 'team-member)))
- (check-if-done)
- (let* ((current-character (pop (turn-queue-of *battle*)))
- (new-ret (process-battle-turn current-character attack item reload selected-target)))
- (iter (for i in (append (team-of *game*) (team-npcs-of *battle*) (enemies-of *battle*)))
- (pop-from-expansion i))
- (when (typep current-character '(not npc))
- (setf team-attacked t
- ret new-ret)))
- (check-if-done)
- (unless (turn-queue-of *battle*)
- (incf (time-of *game*))
- (setf (turn-queue-of *battle*)
- (s:dsu-sort (iter (for i in (append (enemies-of *battle*) (team-npcs-of *battle*) (team-of *game*)))
- (when (> (health-of i) 0)
- (collect i)))
- '>
- :key (lambda (a) (calculate-stat a :speed))))))
+ (check-if-done)
+ (let* ((current-character (pop (turn-queue-of *battle*)))
+ (new-ret (process-battle-turn current-character attack item reload selected-target)))
+ (iter (for i in (append (team-of *game*) (team-npcs-of *battle*) (enemies-of *battle*)))
+ (pop-from-expansion i))
+ (when (typep current-character '(not npc))
+ (setf team-attacked t
+ ret new-ret)))
+ (check-if-done)
+ (unless (turn-queue-of *battle*)
+ (incf (time-of *game*))
+ (setf (turn-queue-of *battle*)
+ (s:dsu-sort (iter (for i in (append (enemies-of *battle*) (team-npcs-of *battle*) (team-of *game*)))
+ (when (> (health-of i) 0)
+ (collect i)))
+ '>
+ :key (lambda (a) (calculate-stat a :speed))))))
(format t "~a is next in battle~%" (name-of (first (turn-queue-of *battle*))))
ret)))
(defunassert ally-join (ally)
- (ally ally)
+ (ally ally)
(format t "~a Joins the team~%" (name-of ally))
(when (> (bitcoins-of ally) 0)
(format t "~a gets ~f bitcoins from ~a~%" (name-of (player-of *game*)) (bitcoins-of ally) (name-of ally)))
@@ -1975,8 +1963,8 @@
(bitcoins-of ally) 0)
t)
(defun use-item% (item user &rest keys &key target action &allow-other-keys
- &aux (effective-action (getf (special-actions-of item) action)) (script (when effective-action
- (action-lambda effective-action))))
+ &aux (effective-action (getf (special-actions-of item) action)) (script (when effective-action
+ (action-lambda effective-action))))
(unless (apply 'cant-use-p item user target action keys)
(cond ((and action effective-action)
(error 'item-action-missing :action action :item item))
@@ -1994,57 +1982,57 @@
(setf (energy-of target) (calculate-stat target :energy)))
ret)))
(defunassert set-player (name malep species)
- (malep boolean
- name simple-string
- species simple-string)
+ (malep boolean
+ name simple-string
+ species simple-string)
"Sets the name, gender, and species of the player"
(setf (name-of (player-of *game*)) name)
(setf (species-of (player-of *game*)) species)
(setf (malep (player-of *game*)) malep)
t)
(defun intro-function (&aux (default (make-instance 'player))
- (wear '(yadfa-items:short-dress yadfa-items:tshirt yadfa-items:bra yadfa-items:jeans
- yadfa-items:boxers yadfa-items:panties yadfa-items:pullups yadfa-items:diaper))
- name male species clothes bladder bowels fill-rate wings skin tail tail-type bio)
+ (wear '(yadfa-items:short-dress yadfa-items:tshirt yadfa-items:bra yadfa-items:jeans
+ yadfa-items:boxers yadfa-items:panties yadfa-items:pullups yadfa-items:diaper))
+ name male species clothes bladder bowels fill-rate wings skin tail tail-type bio)
"This function sets up the player and prints the back story. If you're trying to create your own game with a different storyline using a mod, you can replace this function. Be careful when enabling mods that change the story line this significantly as they can overwrite each other"
(write-line "Enter your character's name, gender, and species" *query-io*)
(clim:accepting-values (*query-io* :resynchronize-every-pass t :exit-boxes '((:exit "Accept")))
- (fresh-line *query-io*)
- (setf name (clim:accept 'string :prompt "Name" :default (name-of default) :view clim:+text-field-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf male (clim:accept 'boolean :prompt "Is Male"
- :default (malep default) :view clim:+toggle-button-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf species (clim:accept 'string :prompt "Species"
- :default (species-of default) :view clim:+text-field-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf clothes (clim:accept `((clim:subset-completion ,wear) :name-key ,(lambda (o) (name-of (make-instance o))))
- :prompt "Clothes" :view clim:+check-box-view+ :default '(yadfa-items:tshirt yadfa-items:diaper)
- :stream *query-io*))
- (fresh-line *query-io*)
- (setf bladder (clim:accept '(clim:completion (:normal :low :overactive))
- :prompt "Bladder capacity" :default :normal :view clim:+option-pane-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf bowels (clim:accept '(clim:completion (:normal :low :kid))
- :prompt "Bowels capacity" :default :normal :view clim:+option-pane-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf fill-rate (clim:accept '(clim:completion (:normal :fast :faster))
- :prompt "Bladder/Bowels fill rate" :default :normal :view clim:+option-pane-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf bio (clim:accept 'string :prompt "Description" :default (description-of default) :view '(clim:text-editor-view :ncolumns 80 :nlines 7)
- :stream *query-io*)))
+ (fresh-line *query-io*)
+ (setf name (clim:accept 'string :prompt "Name" :default (name-of default) :view clim:+text-field-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf male (clim:accept 'boolean :prompt "Is Male"
+ :default (malep default) :view clim:+toggle-button-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf species (clim:accept 'string :prompt "Species"
+ :default (species-of default) :view clim:+text-field-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf clothes (clim:accept `((clim:subset-completion ,wear) :name-key ,(lambda (o) (name-of (make-instance o))))
+ :prompt "Clothes" :view clim:+check-box-view+ :default '(yadfa-items:tshirt yadfa-items:diaper)
+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf bladder (clim:accept '(clim:completion (:normal :low :overactive))
+ :prompt "Bladder capacity" :default :normal :view clim:+option-pane-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf bowels (clim:accept '(clim:completion (:normal :low :kid))
+ :prompt "Bowels capacity" :default :normal :view clim:+option-pane-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf fill-rate (clim:accept '(clim:completion (:normal :fast :faster))
+ :prompt "Bladder/Bowels fill rate" :default :normal :view clim:+option-pane-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf bio (clim:accept 'string :prompt "Description" :default (description-of default) :view '(clim:text-editor-view :ncolumns 80 :nlines 7)
+ :stream *query-io*)))
(clim:accepting-values (*query-io* :resynchronize-every-pass t :exit-boxes '((:exit "Accept")))
- (setf tail-type (clim:accept '(clim:completion (:small :medium :large :lizard :bird-small :bird-large nil))
- :prompt "Tail type" :default (car (tail-of default)) :view clim:+option-pane-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf tail (clim:accept '((clim:subset-completion (:multi :scales :fur :feathers)))
- :prompt "Tail attributes" :default (cdr (tail-of default)) :view clim:+check-box-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf wings (clim:accept '((clim:subset-completion (:scales :fur :feathers)))
- :prompt "Wings attributes" :default (wings-of default) :view clim:+check-box-view+ :stream *query-io*))
- (fresh-line *query-io*)
- (setf skin (clim:accept '((clim:subset-completion (:scales :fur :feathers)))
- :prompt "Skin attributes" :default (skin-of default) :view clim:+check-box-view+ :stream *query-io*)))
+ (setf tail-type (clim:accept '(clim:completion (:small :medium :large :lizard :bird-small :bird-large nil))
+ :prompt "Tail type" :default (car (tail-of default)) :view clim:+option-pane-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf tail (clim:accept '((clim:subset-completion (:multi :scales :fur :feathers)))
+ :prompt "Tail attributes" :default (cdr (tail-of default)) :view clim:+check-box-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf wings (clim:accept '((clim:subset-completion (:scales :fur :feathers)))
+ :prompt "Wings attributes" :default (wings-of default) :view clim:+check-box-view+ :stream *query-io*))
+ (fresh-line *query-io*)
+ (setf skin (clim:accept '((clim:subset-completion (:scales :fur :feathers)))
+ :prompt "Skin attributes" :default (skin-of default) :view clim:+check-box-view+ :stream *query-io*)))
(setf (player-of *game*) (make-instance 'player
:position '(0 0 0 yadfa-zones:home)
:name name
@@ -2072,13 +2060,13 @@
:faster 20/9)
fill-rate)
:wear (iter (for i in wear)
- (when (s:memq i clothes)
- (collect (make-instance i))))))
+ (when (s:memq i clothes)
+ (collect (make-instance i))))))
(setf (team-of *game*) (list (player-of *game*)))
(iter (for i in (iter (for i in '(yadfa-items:diaper yadfa-items:pullups yadfa-items:boxers yadfa-items:panties))
- (when (s:memq i clothes)
- (collect i))))
- (dotimes (j (random 20))
- (push (make-instance i)
- (get-items-from-prop :dresser (position-of (player-of *game*))))))
+ (when (s:memq i clothes)
+ (collect i))))
+ (dotimes (j (random 20))
+ (push (make-instance i)
+ (get-items-from-prop :dresser (position-of (player-of *game*))))))
(write-line "You wake up from sleeping, the good news is that you managed to stay dry throughout the night. Bad news is your bladder filled up during the night. You would get up and head to the toilet, but the bed is too comfy, so you just lay there holding it until the discomfort of your bladder exceeds the comfort of your bed. Then eventually get up while holding yourself and hopping from foot to foot hoping you can make it to a bathroom in time" *query-io*))
diff --git a/core/libexec/generic-functions.lisp b/core/libexec/generic-functions.lisp
index b0827df..b1fdcb4 100644
--- a/core/libexec/generic-functions.lisp
+++ b/core/libexec/generic-functions.lisp
@@ -158,9 +158,8 @@
(: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))
- (when *battle*
- (a:deletef (getf (status-conditions-of *battle*) target) (statuses-cleared-of attack)
- :test (lambda (o e) (typep e o)))))
+ (a:deletef (status-conditions-of target) (statuses-cleared-of attack)
+ :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
(:esc (case (effective-type-effectiveness (element-types-of attack) (element-types-of target))
@@ -169,10 +168,10 @@
(:no-effect (:fmt "It had no effect" #\Newline))))))
(:method :after ((target base-character) (user base-character) (item weapon))
(f:fmt t (name-of target) " received " (calculate-damage target user
- (if (first (ammo-of item))
- (ammo-power-of (first (ammo-of item)))
- (power-of item)))
- " damage" #\Newline))
+ (if (first (ammo-of item))
+ (ammo-power-of (first (ammo-of item)))
+ (power-of item)))
+ " damage" #\Newline))
(:method :after ((target base-character) (user base-character) (item damage-wield))
(format t "~a received ~a damage~%" (name-of target) (calculate-damage target user (power-of item))))
(:method ((target base-character) (user base-character) (attack null))
@@ -202,11 +201,11 @@
(:method ((self npc) (target base-character))
(let ((moves-with-health
(iter (for i in (moves-of self))
- (when (and (>= (energy-of self) (energy-cost-of i)) (typep i 'health-inc-move))
- (collect i))))
+ (when (and (>= (energy-of self) (energy-cost-of i)) (typep i 'health-inc-move))
+ (collect i))))
(moves-can-use (iter (for i in (moves-of self))
- (when (>= (energy-of self) (energy-cost-of i))
- (collect i))))
+ (when (>= (energy-of self) (energy-cost-of i))
+ (collect i))))
(move-to-use nil))
(cond
((and (<= (health-of self) (/ (calculate-stat self :health) 4)) moves-with-health)
@@ -222,9 +221,9 @@
(attack target self (wield-of self)))
(t
(attack target self nil))))))))
-(defgeneric condition-script (user condition)
- (:documentation #.(f:fmt nil "Function that runs at the beginning of each turn @var{USER} is the character who has the @var{CONDITION}. @var{CONDITION} is a " (ref status-condition :class)))
- (:method ((user base-character) (condition status-condition))))
+(defgeneric condition-script (user condition battle)
+ (:documentation #.(f:fmt nil "Function that runs at the beginning of each turn @var{USER} is the character who has the @var{CONDITION}. @var{CONDITION} is a " (ref status-condition :class) " @var{BATTLE} is whether the condition happens in battle or not"))
+ (:method ((user base-character) (condition status-condition) battle)))
(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
@@ -331,7 +330,7 @@
0))
(defgeneric fart (user)
(:method ((user bowels-character) &aux (fart-count (fart-count-of user)) (bowels (bowels/contents-of user))
- (maximum-limit (bowels/maximum-limit-of user)) (rate (bowels/fill-rate-of user)))
+ (maximum-limit (bowels/maximum-limit-of user)) (rate (bowels/fill-rate-of user)))
(cond ((< (bowels/contents-of user) (bowels/need-to-potty-limit-of user))
:cant-go)
((= 0 (random (expt 2 fart-count)))
@@ -351,3 +350,42 @@
(:method ((user bowels-character) (result (eql :failure)) mess &key (stream *standard-output*))
(f:fmt stream (name-of user) "tries to fart to relive the pressure then gets a look of horror on " (if (malep user) "his" "her") " face as "
(if (malep user) "he" "she") " ends up messing " (if (malep user) "himself" "herself") " instead" #\Newline)))
+(defgeneric process-potty (character battle)
+ (:method ((user base-character) battle))
+ (:method ((user potty-character) (battle null))
+ (let ((time-difference (- (time-of *game*) (last-process-potty-time-of user))))
+ (fill-bladder user :times time-difference)
+ (fill-bowels user :times time-difference))
+ (setf (last-process-potty-time-of user) (time-of *game*))
+ (let ((had-accident (if (typep user 'potty-trained-team-member)
+ (cons (when (>= (bladder/contents-of user) (bladder/maximum-limit-of user))
+ (wet :accident t :wetter user))
+ (when (>= (bowels/contents-of user) (bowels/maximum-limit-of user))
+ (mess :accident t :messer user)))
+ (cons (when (>= (bladder/contents-of user) (bladder/need-to-potty-limit-of user))
+ (wet :wetter user))
+ (when (>= (bowels/contents-of user) (bowels/need-to-potty-limit-of user))
+ (mess :messer user))))))
+ (iter (for i in '(:wet :mess))
+ (output-process-potty-text user
+ (get-babyish-padding user)
+ i
+ (get-process-potty-action-type user
+ i
+ had-accident)
+ had-accident))
+ (multiple-value-bind
+ (value key)
+ (pop-from-expansion user had-accident)
+ (when (eq key :wet/mess)
+ (setf had-accident value)))
+ (funcall (coerce (potty-trigger-of (get-zone (position-of (player-of *game*))))
+ 'function)
+ had-accident user)
+ had-accident))
+ (:method ((character potty-character) (battle (eql t)))
+ (let ((time-passed (- (time-of *game*) (last-process-potty-time-of character))))
+ (when (> (health-of character) 0)
+ (fill-bladder character :times time-passed)
+ (fill-bowels character :times time-passed)))
+ (setf (last-process-potty-time-of character) (time-of *game*))))
diff --git a/core/libexec/init.lisp b/core/libexec/init.lisp
index 5206831..94f9074 100644
--- a/core/libexec/init.lisp
+++ b/core/libexec/init.lisp
@@ -32,10 +32,6 @@
(uiop:symbol-call '#:net.didierverna.declt '#:escape ',symbol))
(let ((*package* (find-package :cl)))
(format nil "See ~s" ',symbol)))))
-(declaim (type (or null battle) *battle*)
- (type list yadfa-clim::*records* *mods* *cheat-hooks*)
- (type (or null game) *game*)
- (type hash-table *mod-registry* *pattern-cache*))
(g:define-global-var *events* (make-hash-table :test #'equal :size 100))
(g:define-global-var yadfa-clim::*records* ())
(g:define-global-var *battle* nil)
diff --git a/core/libexec/mcclim.lisp b/core/libexec/mcclim.lisp
index 7d2010d..942cada 100644
--- a/core/libexec/mcclim.lisp
+++ b/core/libexec/mcclim.lisp
@@ -50,9 +50,9 @@
(:menu-bar t)
(:layouts (default
(c:vertically ()
- clim-listener::interactor-container
- clim-listener::doc
- clim-listener::wholine))))
+ clim-listener::interactor-container
+ clim-listener::doc
+ clim-listener::wholine))))
(c:define-command (yadfa-set-eol-action :command-table yadfa-menu-commands :menu "Set EOL Action")
((keyword '(member :scroll :allow :wrap :wrap*)
:prompt "Keyword"))
@@ -63,11 +63,11 @@
(cc:define-conditional-command (com-enable-world)
(yadfa-listener :enable-commands (yadfa-world-commands yadfa-bin-commands)
:disable-commands (yadfa-battle-commands))
- ())
+ ())
(cc:define-conditional-command (com-enable-battle)
(yadfa-listener :enable-commands (yadfa-battle-commands yadfa-bin-commands)
:disable-commands (yadfa-world-commands))
- ())
+ ())
(c:define-command
(com-inspect :command-table c:global-command-table :name "Inspect")
((obj 'c:expression
@@ -78,11 +78,11 @@
`(multiple-value-bind (x y) (c:stream-cursor-position ,medium)
(c:draw-rectangle* ,medium x y (+ x (* ,stat 400)) (+ y 15)
:ink (cond ,@(iter (for i in colors)
- (collect `(,(car i) ,(intern (format nil "+~a+"
- (if (typep (car (last i)) 'cons)
- (caar (last i))
- (car (last i))))
- "CLIM"))))))
+ (collect `(,(car i) ,(intern (format nil "+~a+"
+ (if (typep (car (last i)) 'cons)
+ (caar (last i))
+ (car (last i))))
+ "CLIM"))))))
(c:draw-rectangle* ,medium x y (+ x 400) (+ y 15)
:filled nil)
(c:stream-set-cursor-position ,medium (+ x 400) y)))
@@ -116,17 +116,16 @@
(energy-of object)
(calculate-stat object :energy))
""))
- (when *battle*
- (write-string "Conditions: " stream)
- (iter (for i in (getf (status-conditions-of *battle*) object))
- (format stream "“~a” " (name-of i)))
- (write-char #\Newline stream))
+ (write-string "Conditions: " stream)
+ (iter (for i in (status-conditions-of object))
+ (format stream "“~a” " (name-of i)))
+ (write-char #\Newline stream)
(format stream "Stats: ~a~%Base-Stats: ~a~%"
(let ((wield-stats (calculate-wield-stats object))
(wear-stats (calculate-wear-stats object)))
(iter (for (a b) on (base-stats-of object) by #'cddr)
- (collect a)
- (collect (+ b (getf wield-stats a) (getf wear-stats a)))))
+ (collect a)
+ (collect (+ b (getf wield-stats a) (getf wear-stats a)))))
(base-stats-of object))
(let ((c (filter-items (wear-of object) 'closed-bottoms)))
(destructuring-bind (&key (sogginess 0) (sogginess-capacity 0) (messiness 0) (messiness-capacity 0))
@@ -197,16 +196,16 @@
(return))
((and (< old-x new-x) (= old-y new-y) (= old-z new-z) (equal old-zone new-zone))
(iter (for i from (1+ old-x) to new-x)
- (collect :east)))
+ (collect :east)))
((and (> old-x new-x) (= old-y new-y) (= old-z new-z) (equal old-zone new-zone))
(iter (for i from (1- old-x) downto new-x)
- (collect :west)))
+ (collect :west)))
((and (= old-x new-x) (< old-y new-y) (= old-z new-z) (equal old-zone new-zone))
(iter (for i from (1+ old-y) to new-y)
- (collect :south)))
+ (collect :south)))
((and (= old-x new-x) (> old-y new-y) (= old-z new-z) (equal old-zone new-zone))
(iter (for i from (1- old-y) downto new-y)
- (collect :north)))
+ (collect :north)))
(t
(format t "You're either already on that zone or you tried specifying a path that involves turning (which this interface can't do because Pouar sucks at writing code that generates paths)~%")
(return))))))))
@@ -217,63 +216,63 @@
(yadfa-bin:lst :describe-zone zone))
(c:define-presentation-to-command-translator com-yadfa-move-translator
(zone com-yadfa-move yadfa-world-commands
- :documentation "Move"
- :pointer-documentation "Move Here"
- :gesture nil
- :menu t
- :tester ((object) (destructuring-bind (new-x new-y new-z new-zone) (position-of object)
- (destructuring-bind (old-x old-y old-z old-zone) (position-of (player-of *game*))
- (and (= old-z new-z) (equal old-zone new-zone) (or (and (= old-y new-y) (/= old-x new-x))
- (and (= old-x new-x) (/= old-y new-y))))))))
- (object)
+ :documentation "Move"
+ :pointer-documentation "Move Here"
+ :gesture nil
+ :menu t
+ :tester ((object) (destructuring-bind (new-x new-y new-z new-zone) (position-of object)
+ (destructuring-bind (old-x old-y old-z old-zone) (position-of (player-of *game*))
+ (and (= old-z new-z) (equal old-zone new-zone) (or (and (= old-y new-y) (/= old-x new-x))
+ (and (= old-x new-x) (/= old-y new-y))))))))
+ (object)
(list object))
(c:define-presentation-to-command-translator com-yadfa-move-translator-up
(zone com-yadfa-move yadfa-world-commands
- :documentation "Move Up"
- :pointer-documentation "Move Up"
- :gesture nil
- :menu t
- :tester ((object) (and (equal (position-of (player-of *game*)) (position-of object))
- (get-zone (destructuring-bind (x y z zone) (position-of object)
- `(,x ,y ,(1+ z) ,zone)))
- (yadfa::travelablep (position-of (player-of *game*)) :up))))
- (object)
+ :documentation "Move Up"
+ :pointer-documentation "Move Up"
+ :gesture nil
+ :menu t
+ :tester ((object) (and (equal (position-of (player-of *game*)) (position-of object))
+ (get-zone (destructuring-bind (x y z zone) (position-of object)
+ `(,x ,y ,(1+ z) ,zone)))
+ (yadfa::travelablep (position-of (player-of *game*)) :up))))
+ (object)
'((:up)))
(c:define-presentation-to-command-translator com-yadfa-move-translator-down
(zone com-yadfa-move yadfa-world-commands
- :documentation "Move Down"
- :pointer-documentation "Move Down"
- :gesture nil
- :menu t
- :tester ((object) (and (equal (position-of (player-of *game*)) (position-of object))
- (get-zone (destructuring-bind (x y z zone) (position-of object)
- `(,x ,y ,(1- z) ,zone)))
- (yadfa::travelablep (position-of (player-of *game*)) :down))))
- (object)
+ :documentation "Move Down"
+ :pointer-documentation "Move Down"
+ :gesture nil
+ :menu t
+ :tester ((object) (and (equal (position-of (player-of *game*)) (position-of object))
+ (get-zone (destructuring-bind (x y z zone) (position-of object)
+ `(,x ,y ,(1- z) ,zone)))
+ (yadfa::travelablep (position-of (player-of *game*)) :down))))
+ (object)
'((:down)))
(c:define-presentation-to-command-translator com-yadfa-move-translator-warp
(zone com-yadfa-move yadfa-world-commands
- :documentation "Move To Waypoint"
- :pointer-documentation "Move To Waypoint"
- :gesture nil
- :menu t
- :tester ((object) (and (equal (position-of (player-of *game*)) (position-of object))
- (iter (for (point position) on (warp-points-of (get-zone (position-of object))) by 'cddr)
- (unless (yadfa::travelablep (position-of (player-of *game*)) point)
- (collect point))))))
- (object)
+ :documentation "Move To Waypoint"
+ :pointer-documentation "Move To Waypoint"
+ :gesture nil
+ :menu t
+ :tester ((object) (and (equal (position-of (player-of *game*)) (position-of object))
+ (iter (for (point position) on (warp-points-of (get-zone (position-of object))) by 'cddr)
+ (unless (yadfa::travelablep (position-of (player-of *game*)) point)
+ (collect point))))))
+ (object)
`((,(let ((*query-io* (c:frame-query-io (c:find-application-frame 'yadfa-listener))))
(c:accepting-values (*query-io* :resynchronize-every-pass t)
- (c:accept `(member-alist ,(iter (for (key position) on (warp-points-of (get-zone (position-of object))) by 'cddr)
- (unless (yadfa::travelablep (position-of (player-of *game*)) key)
- (collect (cons (write-to-string key) key))))) :view clim:+radio-box-view+ :stream *query-io*))))))
+ (c:accept `(member-alist ,(iter (for (key position) on (warp-points-of (get-zone (position-of object))) by 'cddr)
+ (unless (yadfa::travelablep (position-of (player-of *game*)) key)
+ (collect (cons (write-to-string key) key))))) :view clim:+radio-box-view+ :stream *query-io*))))))
(c:define-presentation-to-command-translator com-yadfa-describe-zone-translator
(zone com-yadfa-describe-zone yadfa-bin-commands
- :documentation "Describe Zone"
- :pointer-documentation "Print Zone Description"
- :gesture nil
- :menu t)
- (object)
+ :documentation "Describe Zone"
+ :pointer-documentation "Print Zone Description"
+ :gesture nil
+ :menu t)
+ (object)
(list object))
(c:define-application-frame emacs-frame (c:standard-application-frame)
((lambda :accessor emacs-frame-lambda
@@ -286,10 +285,10 @@
(default int)))
(defmethod c:default-frame-top-level :around ((frame emacs-frame)
&key (command-parser 'c:command-line-command-parser)
- (command-unparser 'c:command-line-command-unparser)
- (partial-command-parser
- 'c:command-line-read-remaining-arguments-for-partial-command)
- (prompt "Command: "))
+ (command-unparser 'c:command-line-command-unparser)
+ (partial-command-parser
+ 'c:command-line-read-remaining-arguments-for-partial-command)
+ (prompt "Command: "))
(declare (ignore prompt))
(let* ((frame-query-io (c:frame-query-io frame))
(interactorp (typep frame-query-io 'c:interactor-pane))
@@ -317,10 +316,10 @@
(defmethod c:default-frame-top-level
((frame yadfa-listener)
&key (command-parser 'c:command-line-command-parser)
- (command-unparser 'c:command-line-command-unparser)
- (partial-command-parser
- 'c:command-line-read-remaining-arguments-for-partial-command)
- (prompt "Command: "))
+ (command-unparser 'c:command-line-command-unparser)
+ (partial-command-parser
+ 'c:command-line-read-remaining-arguments-for-partial-command)
+ (prompt "Command: "))
;; Give each pane a fresh start first time through.
(let ((needs-redisplay t)
(first-time t))
@@ -345,9 +344,9 @@
(restart-case
(flet ((execute-command ()
(a:when-let ((command (c:read-frame-command frame :stream frame-query-io)))
- (setq needs-redisplay t)
- (s:run-hooks 'yadfa:*cheat-hooks*)
- (c:execute-frame-command frame command))))
+ (setq needs-redisplay t)
+ (s:run-hooks 'yadfa:*cheat-hooks*)
+ (c:execute-frame-command frame command))))
(when needs-redisplay
(dolist (i yadfa-clim::*records*) do (c:redisplay i *standard-output*))
(c:redisplay-frame-panes frame :force-p first-time)
@@ -383,13 +382,13 @@
(unwind-protect (error 'emm386-memory-manager-error)
(call-next-method)))
(defun run-listener (&key (new-process nil)
- (debugger t)
- (width 1024)
- (height 1024)
- port
- frame-manager
- (process-name "Yadfa")
- (package :yadfa-user))
+ (debugger t)
+ (width 1024)
+ (height 1024)
+ port
+ frame-manager
+ (process-name "Yadfa")
+ (package :yadfa-user))
(let* ((fm (or frame-manager (c:find-frame-manager :port (or port (c:find-port)))))
(frame (c:make-application-frame 'yadfa-listener
:frame-manager fm
diff --git a/core/libexec/methods.lisp b/core/libexec/methods.lisp
index 02338c3..3bdfa98 100644
--- a/core/libexec/methods.lisp
+++ b/core/libexec/methods.lisp
@@ -34,7 +34,28 @@
(t (write "Female" :stream stream)))
(write-string " " stream)
(print-slot obj 'species stream)))
-(defmethod process-potty-dance ((character base-character) attack (item item) reload (selected-target base-character))
+(defmethod (setf health-of) (new-value (character base-character))
+ (let* ((max-health (calculate-stat character :health)))
+ (setf (slot-value character 'health) (cond ((< new-value 0)
+ 0)
+ ((> new-value max-health)
+ max-health)
+ (t new-value)))))
+(defmethod (setf health-of) (new-value (character team-member))
+ (let* ((max-health (calculate-stat character :health)))
+ (setf (slot-value character 'health) (cond ((< new-value 0)
+ 0)
+ ((> new-value max-health)
+ max-health)
+ (t new-value)))))
+(defmethod (setf energy-of) (new-value (character base-character))
+ (let ((max-energy (calculate-stat character :energy)))
+ (setf (slot-value character 'energy) (cond ((< new-value 0)
+ 0)
+ ((> new-value max-energy)
+ max-energy)
+ (t new-value)))))
+(defmethod process-potty-dance ((character base-character) attack item reload (selected-target base-character))
(declare (ignore item reload selected-target))
(when (process-potty-dance-check character attack)
(format t "~a is too busy doing a potty dance to fight~%" (name-of character))
@@ -1653,33 +1674,11 @@ randomrange is @code{(random-from-range 85 100)}"
"Messiness: " (messiness-of item) #\Newline
"Messiness Capacity: " (messiness-capacity-of item) #\Newline))
(defmethod process-battle-turn ((character npc) attack item reload selected-target)
- (iter (for i in (getf (status-conditions-of *battle*) character))
- (when (or (eq (duration-of i) t) (> (duration-of i) 0))
- (condition-script character i)
- (when (typep (duration-of i) 'real)
- (decf (duration-of i))))
- (removef-if (getf (status-conditions-of *battle*) character)
- (lambda (a) (and (not (eq a t)) (<= a 0)))
- :key #'duration-of))
- (run-equip-effects character)
- (when (<= (health-of character) 0)
- (unless (s:memq character (fainted-of *battle*))
- (format t "~a has fainted~%~%" (name-of character))
- (pushnew (the npc character) (fainted-of *battle*)))
- (setf (health-of character) 0)
- (a:deletef (turn-queue-of *battle*) character)
+ (when (handle-status-effects character t)
(return-from process-battle-turn))
- (when (> (health-of character) (calculate-stat character :health))
- (setf (health-of character) (calculate-stat character :health)))
- (when (> (energy-of character) (calculate-stat character :energy))
- (setf (energy-of character) (calculate-stat character :energy)))
- (let ((time-passed (- (time-of *game*) (last-process-potty-time-of character))))
- (fill-bladder character :times time-passed)
- (fill-bowels character :times time-passed))
- (setf (last-process-potty-time-of character) (time-of *game*))
(cond ((process-battle-accident character attack item reload selected-target)
nil)
- ((iter (for j in (getf (status-conditions-of *battle*) character))
+ ((iter (for j in (status-conditions-of character))
(when (blocks-turn-of j)
(leave t))))
((process-potty-dance character attack item reload selected-target) t)
@@ -1711,33 +1710,11 @@ randomrange is @code{(random-from-range 85 100)}"
(team-of *game*)
(enemies-of *battle*)))))))
(defmethod process-battle-turn ((character base-character) attack item reload selected-target)
- (iter (for status-condition in (getf (status-conditions-of *battle*) character))
- (when (or (eq (duration-of status-condition) t) (> (duration-of status-condition) 0))
- (condition-script character status-condition)
- (when (typep (duration-of status-condition) 'real)
- (decf (duration-of status-condition))))
- (removef-if (getf (status-conditions-of *battle*) character)
- (lambda (a) (and (not (eq a t)) (<= a 0)))
- :key #'duration-of))
- (run-equip-effects character)
- (when (<= (health-of character) 0)
- (setf (health-of character) 0)
- (unless (s:memq character (fainted-of *battle*))
- (format t "~a has fainted~%~%" (name-of character))
- (pushnew (the base-character character) (fainted-of *battle*)))
- (a:deletef (turn-queue-of *battle*) character)
+ (when (handle-status-effects character t)
(return-from process-battle-turn))
- (when (> (health-of character) (calculate-stat character :health))
- (setf (health-of character) (calculate-stat character :health)))
- (when (> (energy-of character) (calculate-stat character :energy))
- (setf (energy-of character) (calculate-stat character :energy)))
- (let ((time-passed (- (time-of *game*) (last-process-potty-time-of character))))
- (fill-bladder character :times time-passed)
- (fill-bowels character :times time-passed))
- (setf (last-process-potty-time-of character) (time-of *game*))
(cond ((process-battle-accident character attack item reload selected-target)
nil)
- ((iter (for j in (getf (status-conditions-of *battle*) character))
+ ((iter (for j in (status-conditions-of character))
(when (blocks-turn-of j)
(leave t))))
((process-potty-dance character attack item reload selected-target) t)
diff --git a/data/enemies/raccoon-bandits.lisp b/data/enemies/raccoon-bandits.lisp
index c7e7e13..19a47e6 100644
--- a/data/enemies/raccoon-bandits.lisp
+++ b/data/enemies/raccoon-bandits.lisp
@@ -11,11 +11,11 @@
:wear (make-instances yadfa-items:bandit-uniform-tunic yadfa-items:bandit-adjustable-diaper)
:inventory (let ((a ()))
(iter (for i from 0 to (random 5))
- (push (make-instance 'yadfa-items:bandit-diaper) a))
+ (push (make-instance 'yadfa-items:bandit-diaper) a))
(iter (for i from 0 to (random 5))
- (push (make-instance 'yadfa-items:bandit-adjustable-diaper) a))
+ (push (make-instance 'yadfa-items:bandit-adjustable-diaper) a))
(iter (for i from 0 to (random 5))
- (push (make-instance 'yadfa-items:bandit-female-diaper) a)))
+ (push (make-instance 'yadfa-items:bandit-female-diaper) a)))
:bitcoins-per-level 40))
(s:defmethods diapered-raccoon-bandit (character)
(:method battle-script (character (target base-character))
@@ -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))
- (getf (status-conditions-of *battle*) character)))
+ (status-conditions-of character)))
(messing (find-if (lambda (o) (typep o 'yadfa-status-conditions:messing))
- (getf (status-conditions-of *battle*) character)))
+ (status-conditions-of 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 7b6e313..f76ad1d 100644
--- a/data/epilog/items.lisp
+++ b/data/epilog/items.lisp
@@ -4,7 +4,7 @@
(cond
((>= (list-length (contained-enemies-of item)) (contained-enemies-max-length-of item))
(f:fmt t (name-of item) " can't hold anymore enemies" #\Newline #\Newline))
- ((not (< (random 1.0l0) (* (catch-chance-multiplier-of item) (+ (catch-chance-delta-of item) (yadfa-enemies:catch-chance-of target)))))
+ ((not (< (random 1.0l0) (* (catch-chance-multiplier-of item) (+ (catch-chance-delta-of item) (yadfa-enemies:catch-chance target)))))
(f:fmt t "You failed to catch the " (name-of target) #\Newline #\Newline)
(cond ((eq (device-health-of item) t) nil)
((<= (device-health-of item) 1)
@@ -16,11 +16,9 @@
;; prevent the enemy from going again during the battle
(alexandria:deletef (enemies-of *battle*) target)
(alexandria:deletef (turn-queue-of *battle*) target)
- (remf (status-conditions-of *battle*) target)
-
- ;; these may break the save file since functions don't serialize very well
- ;; and they will never get called after the enemy is caught, so just delete these
- (setf (yadfa-enemies:catch-chance-of target) nil)
+ (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)
@@ -29,49 +27,49 @@
(declare (ignore user))
(setf (inventory-of (player-of *game*))
(append (iter (for enemy in (contained-enemies-of item))
- (dolist (item (inventory-of enemy))
- (collect item))
- (dolist (item (wear-of enemy))
- (collect item))
- (setf (inventory-of enemy) nil
- (wear-of enemy) nil))
+ (dolist (item (inventory-of enemy))
+ (collect item))
+ (dolist (item (wear-of enemy))
+ (collect item))
+ (setf (inventory-of enemy) nil
+ (wear-of enemy) nil))
(inventory-of (player-of *game*)))))))
(unless (getf (special-actions-of item) :adopt-enemies)
(setf (getf (special-actions-of item) :adopt-enemies)
'(lambda (item user &allow-other-keys :enemies enemies)
(if (iter (for i in (contained-enemies-of item))
- (when (typep (class-of i) 'yadfa-enemies:adoptable-enemy)
- (return t)))
+ (when (typep (class-of i) 'yadfa-enemies:adoptable-enemy)
+ (return t)))
(progn
(setf enemies
(typecase enemies
(null (accept-with-effective-frame
- (clim:accepting-values (*query-io* :resynchronize-every-pass t)
- (setf enemies (clim:accept `(clim:subset-alist ,(iter (for enemy in (contained-enemies-of item))
- (when (typep (class-of i) 'yadfa-enemies:adoptable-enemy)
- (collect (cons (name-of enemy) enemy)))))
- :prompt "Enemies to adopt"
- :stream *query-io*
- :view clim:+check-box-view+)))))
+ (clim:accepting-values (*query-io* :resynchronize-every-pass t)
+ (setf enemies (clim:accept `(clim:subset-alist ,(iter (for enemy in (contained-enemies-of item))
+ (when (typep (class-of i) 'yadfa-enemies:adoptable-enemy)
+ (collect (cons (name-of enemy) enemy)))))
+ :prompt "Enemies to adopt"
+ :stream *query-io*
+ :view clim:+check-box-view+)))))
(type-specifier (iter (for enemy in (contained-enemies-of item))
- (when (typep i enemies)
- (collect i))))
+ (when (typep i enemies)
+ (collect i))))
(list (iter
- (for enemy in (contained-enemies-of item))
- (generate current in enemies)
- (for index upfrom 0)
- (cond ((typep current '(not unsigned-byte))
- (error "ENEMIES must be a list of unsigned-bytes"))
- ((eql index current)
- (collect enemy)
- (next current)))))
+ (for enemy in (contained-enemies-of item))
+ (generate current in enemies)
+ (for index upfrom 0)
+ (cond ((typep current '(not unsigned-byte))
+ (error "ENEMIES must be a list of unsigned-bytes"))
+ ((eql index current)
+ (collect enemy)
+ (next current)))))
(t (error "ENEMIES must either be a list of unsigned-bytes or a type specifier"))))
(alexandria:removef (contained-enemies-of item) enemies
:test (lambda (o e)
(member e o)))
(alexandria:appendf (allies-of *game*) (iter (for i in enemies)
- (write-line (yadfa-enemies:change-class-text i))
- (collect (change-class i (get (class-name i) 'yadfa-enemies:change-class-target))))))
+ (write-line (yadfa-enemies:change-class-text i))
+ (collect (change-class i (get (class-name i) 'yadfa-enemies:change-class-target))))))
(format t "No enemies in there to adopt"))))))))
(defmethod use-script ((item enemy-catcher) (user base-character) (target yadfa-enemies:ghost))
(f:fmt t "You failed to catch " (name-of target) #\Newline #\Newline)
@@ -83,7 +81,7 @@
(cond
((>= (list-length (contained-enemies-of item)) (contained-enemies-max-length-of item))
(f:fmt t (name-of item) " can't hold anymore enemies" #\Newline #\Newline))
- ((not (< (random 1.0l0) (* (catch-chance-multiplier-of item) (+ (catch-chance-delta-of item) (yadfa-enemies:catch-chance-of target)))))
+ ((not (< (random 1.0l0) (* (catch-chance-multiplier-of item) (+ (catch-chance-delta-of item) (yadfa-enemies:catch-chance target)))))
(f:fmt t "You failed to catch the " (name-of target) #\Newline #\Newline)
(cond ((eq (device-health-of item) t) nil)
((<= (device-health-of item) 1)
@@ -95,16 +93,14 @@
;; prevent the enemy from going again during the battle
(alexandria:deletef (enemies-of *battle*) target)
(alexandria:deletef (turn-queue-of *battle*) target)
- (remf (status-conditions-of *battle*) target)
-
- ;; these may break the save file since functions don't serialize very well
- ;; and they will never get called after the enemy is caught, so just delete these
- (setf (yadfa-enemies:catch-chance-of target) nil)
+ (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))
- (item type-specifier
- target (or unsigned-byte type-specifier))
+ (item type-specifier
+ target (or unsigned-byte type-specifier))
"Catches an enemy using. @var{ITEM} which is a type specifier. @var{TARGET} is an index or type specifier of an enemy in battle or a type specifier"
(let ((selected-item (find item (inventory-of (player-of *game*))
:test (lambda (type-specifier obj)
@@ -130,13 +126,13 @@
:item selected-item
:selected-target selected-target)))
(defunassert yadfa-world-commands:loot-caught-enemies (&optional item)
- (item (or null unsigned-byte type-specifier))
+ (item (or null unsigned-byte type-specifier))
"Loots the enemies you caught. @var{ITEM} is either a type specifier or an unsiged-byte of the item. Don't specify if you want to loot the enemies of all items"
(cond ((null item)
(iter (for item in (inventory-of *game*))
- (when (typep item 'enemy-catcher)
- (funcall (coerce (action-lambda (getf (special-actions-of item) :take-items)) 'function)
- item (player-of *game*) :action :take-items))))
+ (when (typep item 'enemy-catcher)
+ (funcall (coerce (action-lambda (getf (special-actions-of item) :take-items)) 'function)
+ item (player-of *game*) :action :take-items))))
((typep item 'unsigned-byte)
(let* ((inventory-length (list-length (inventory-of (player-of *game*))))
(selected-item (and (< item inventory-length) (nth item (inventory-of (player-of *game*))))))
diff --git a/data/moves/regular.lisp b/data/moves/regular.lisp
index d2e25a6..262dd27 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 (getf (status-conditions-of *battle*) target)
+ (old-condition (find 'yadfa-status-conditions:pantsed (status-conditions-of 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) (getf (status-conditions-of *battle*) target)))
+ (push (make-instance 'yadfa-status-conditions:pantsed) (status-conditions-of 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 (getf (status-conditions-of *battle*) user)
+ (find 'yadfa-status-conditions:poisoned (status-conditions-of user)
:test (lambda (o e)
(typep e o))))
(mess :messer user)
diff --git a/data/prolog/enemies.lisp b/data/prolog/enemies.lisp
index 0151654..6bb9461 100644
--- a/data/prolog/enemies.lisp
+++ b/data/prolog/enemies.lisp
@@ -4,14 +4,15 @@
`(list ,@(iter (for symbol in symbols)
(collect `(make-instance ',symbol)))))
(defclass catchable-enemy (enemy)
- ((catch-chance%
- :initarg catch-chance
- :accessor catch-chance-of
- :initform (lambda (enemy)
- (let ((rate 1)) ; number between 0 and 1
- (/ (* (- (* 3 (calculate-stat enemy :health)) (* 2 (health-of enemy))) rate)
- (* 3 (calculate-stat enemy :health)))))
+ ((catch-chance-rate%
+ :initarg catch-chance-rate
+ :accessor catch-chance-rate-of
+ :initform 1
+ :type (real 0 1)
:documentation "Chance of @var{CATCH-CHANCE} in 1 that this enemy can be caught where @var{CATCH-CHANCE} is a number between 0 and 1. If it is an object that can be coerced into a function, it is a function that accepts this enemy as an argument that returns a number.")))
+(defmethod catch-chance ((enemy catchable-enemy))
+ (/ (* (- (* 3 (calculate-stat enemy :health)) (* 2 (health-of enemy))) (catch-chance-rate-of enemy))
+ (* 3 (calculate-stat enemy :health))))
(defclass adoptable-enemy (enemy) ())
(defclass skunk-boop-mixin (base-character) ())
(defmethod change-class-text ((class adoptable-enemy))
diff --git a/data/status-conditions/abdl.lisp b/data/status-conditions/abdl.lisp
index 0099529..35e5d83 100644
--- a/data/status-conditions/abdl.lisp
+++ b/data/status-conditions/abdl.lisp
@@ -7,7 +7,7 @@
:description "User is currently wetting himself/herself"
:duration 1
:blocks-turn t))
-(defmethod condition-script ((user base-character) (self wetting))
+(defmethod condition-script ((user base-character) (self wetting) (battle (eql t)))
(declare (ignore self))
(format t "~a is too busy wetting ~aself to fight~%" (name-of user) (if (malep user) "his" "her"))
(setf (bladder/contents-of user) 0))
@@ -18,7 +18,7 @@
:description "User is currently messing himself/herself"
:duration 1
:blocks-turn t))
-(defmethod condition-script ((user base-character) (self messing))
+(defmethod condition-script ((user base-character) (self messing) (battle (eql t)))
(declare (ignore self))
(format t "~a is too busy messing ~aself to fight~%" (name-of user) (if (malep user) "his" "her"))
(setf (bowels/contents-of user) 0))
@@ -30,9 +30,9 @@
:duration t
:stat-multiplier (list :speed 1/2)
:blocks-turn t))
-(defmethod condition-script ((user base-character) (self mushed))
+(defmethod condition-script ((user base-character) (self mushed) (battle (eql t)))
(cond ((<= (getf (calculate-diaper-usage user) :messiness) 0)
- (setf (getf (status-conditions-of *battle*) user) (remove self (getf (status-conditions-of *battle*) user))))
+ (setf (status-conditions-of user) (remove self (status-conditions-of 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))
@@ -42,7 +42,7 @@
(:default-initargs
:name "Pantsed"
:description "The user has been pantsed revealing his padding to the world"
- :persistent t))
+ :curable t))
(defclass laughing (status-condition)
()
(:default-initargs
@@ -50,7 +50,7 @@
:description "User is laughing"
:duration 1
:blocks-turn t))
-(defmethod condition-script ((user base-character) (self laughing))
+(defmethod condition-script ((user base-character) (self laughing) (battle (eql t)))
(declare (ignore self))
(format t "~a is too busy laughing to fight~%" (name-of user))
(when (or (>= (bladder/contents-of user) (bladder/potty-dance-limit-of user))
diff --git a/data/status-conditions/pokemon.lisp b/data/status-conditions/pokemon.lisp
index 0563d46..8878ee1 100644
--- a/data/status-conditions/pokemon.lisp
+++ b/data/status-conditions/pokemon.lisp
@@ -6,8 +6,8 @@
:name "Poisoned"
:description "User is currently poisoned"
:duration t))
-(defmethod condition-script ((user base-character) (condition poisoned))
+(defmethod condition-script ((user base-character) (condition poisoned) (battle (eql t)))
(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 (getf (status-conditions-of *battle*) user) condition)))
+ (a:deletef (status-conditions-of user) condition)))
diff --git a/packages.lisp b/packages.lisp
index aad0588..c0fb767 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -332,6 +332,7 @@
#:action-lambda
#:action-p
#:fainted-of
+ #:curablep
#:persistentp)
(:documentation "Yet Another Diaperfur Adventure")
(:local-nicknames (:s :serapeum) (:a :alexandria) (:u :ugly-tiny-infix-macro) (:g :global-vars) (:sc :serapeum/contrib/hooks)
@@ -630,8 +631,8 @@
#:werewolf
#:domesticated-werewolf
#:catchable-enemy
- #:catch-chance-of
#:catch-chance
+ #:catch-chance-rate-of
#:raptor
#:change-class-target
#:change-class-text
diff --git a/yadfa.asd b/yadfa.asd
index 346560b..3ef26e5 100644
--- a/yadfa.asd
+++ b/yadfa.asd
@@ -27,7 +27,7 @@
(:file "methods" :depends-on ("classes" "generic-functions" "macros" "declares" "functions" "conditions"))
(:file "generic-functions" :depends-on ("classes" "macros" "declares" "functions"))
(:file "classes" :depends-on ("init" "declares"))
- (:file "hooks")
+ (:file "hooks" :depends-on ("declares" "init"))
(:file "game" :depends-on ("classes" "init" "declares"))
(:file "mcclim" :depends-on ("init" "declares" "functions" "generic-functions" "macros"))
(:file "structs" :depends-on ("init" "declares"))