aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Pouar <pouar@pouar.net>2020-08-30 16:08:16 -0500
committerGravatar Pouar <pouar@pouar.net>2020-08-31 08:43:48 -0500
commitea5ff3d2d41a3172f4246317b716f924b2e244d7 (patch)
treea3fa13e3be9057d20fd4adea3ef72be3cb3f9ef8
parentformatting style (diff)
Start making use of &aux.
It's there, might was well use it.
-rw-r--r--core/libexec/functions.lisp983
1 files changed, 475 insertions, 508 deletions
diff --git a/core/libexec/functions.lisp b/core/libexec/functions.lisp
index 43fa022..9e37843 100644
--- a/core/libexec/functions.lisp
+++ b/core/libexec/functions.lisp
@@ -18,23 +18,18 @@
(declare (type list list)
(type integer length))
(not (list-length-< length list)))
-(defun switch-user-packages ()
+(defun switch-user-packages (&aux (clim:*application-frame* (clim:find-application-frame 'yadfa-clim::yadfa-listener)))
+ (declare (special clim:*application-frame*))
+ (if *battle*
+ (progn
+ (unuse-package *world-packages* :yadfa-user)
+ (use-package *battle-packages* :yadfa-user)
+ (conditional-commands:change-entity-enabledness 'yadfa-clim::com-enable-battle))
+ (progn
+ (unuse-package *battle-packages* :yadfa-user)
+ (use-package *world-packages* :yadfa-user)
+ (conditional-commands:change-entity-enabledness 'yadfa-clim::com-enable-world)))
(use-package *command-packages* :yadfa-user)
- (let ((clim:*application-frame* (clim:find-application-frame 'yadfa-clim::yadfa-listener :create nil)))
- (declare (special clim:*application-frame*))
- (if *battle*
- (progn
- (unuse-package *world-packages* :yadfa-user)
- (use-package *battle-packages* :yadfa-user)
- (let ((clim:*application-frame* (clim:find-application-frame 'yadfa-clim::yadfa-listener)))
- (declare (special clim:*application-frame*))
- (conditional-commands:change-entity-enabledness 'yadfa-clim::com-enable-battle)))
- (progn
- (unuse-package *battle-packages* :yadfa-user)
- (use-package *world-packages* :yadfa-user)
- (let ((clim:*application-frame* (clim:find-application-frame 'yadfa-clim::yadfa-listener)))
- (declare (special clim:*application-frame*))
- (conditional-commands:change-entity-enabledness 'yadfa-clim::com-enable-world)))))
t)
(defunassert get-event (event-id)
@@ -216,24 +211,24 @@
(remf (getf (direction-attributes-of (get-zone position)) direction) attribute)
(unless (getf (direction-attributes-of (get-zone position)) direction)
(remf (direction-attributes-of (get-zone position)) direction)))
-(defun set-status-condition (status-condition user &key duration test key)
- (let* ((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))
- (when (and (not (eq (duration-of i) t)) (< (duration-of i) duration))
- (setf (duration-of i) duration)))
+(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))
+ (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))
@@ -324,44 +319,41 @@
(:up (a position 0 0 1))
(:down (a position 0 0 -1))
(otherwise (get-warp-point direction position)))))
-(defunassert get-path-end (destination &optional position direction)
+(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)
- (let* ((player (player-of *game*))
- (allies (allies-of *game*))
- (wield (wield-of player))
- (wear (wear-of player))
- (inventory (inventory-of player)))
- (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)))
- (return-from get-path-end (values nil (format nil "Pick a direction the game knows about~%"))))
- (when (and direction (s:memq direction '(:up :down)) (not (s:memq direction (stairs-of (get-zone (or position (position-of player)))))))
- (return-from get-path-end (values nil (format nil "There are no stairs there~%"))))
- (when (or (and (lockedp (get-zone destination))
- (not (member-if (lambda (a)
- (typep a (key-of (get-zone destination))))
- (append inventory
- (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)))
- a)))))
- (and position direction
- (getf-direction position direction :locked)
- (not (member-if (lambda (a)
- (typep a (getf-direction position direction :key)))
- (append inventory
- (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)))
- a))))))
- (return-from get-path-end (values nil (format nil "zone ~a is locked~%" destination))))
- destination))
+ (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)))
+ (return-from get-path-end (values nil (format nil "Pick a direction the game knows about~%"))))
+ (when (and direction (s:memq direction '(:up :down)) (not (s:memq direction (stairs-of (get-zone (or position (position-of player)))))))
+ (return-from get-path-end (values nil (format nil "There are no stairs there~%"))))
+ (when (or (and (lockedp (get-zone destination))
+ (not (member-if (lambda (a)
+ (typep a (key-of (get-zone destination))))
+ (append inventory
+ (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)))
+ a)))))
+ (and position direction
+ (getf-direction position direction :locked)
+ (not (member-if (lambda (a)
+ (typep a (getf-direction position direction :key)))
+ (append inventory
+ (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)))
+ 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)
(or (gethash `(:map-pattern ,path ,designs) *pattern-cache*)
@@ -382,7 +374,8 @@
(or (and (s:memq direction '(:up :down)) (s:memq direction (stairs-of (get-zone position))))
(and (not (s:memq direction '(:up :down)))))
t))
-(defun print-map (position)
+(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))
(labels ((a (position)
(let ((b 0)
(array
@@ -407,65 +400,59 @@
(unless (travelablep position direction)
(setf (ldb (byte 1 byte-position) b) 1)))
(aref array b))))
- (let* ((player (player-of *game*))
- (player-position (position-of player))
- (player-zone (get-zone player-position)))
- (declare (type player player)
- (type list player-position)
- (type (or null zone) player-zone))
- (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)))
- (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))))))))))))
+ (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)))
+ (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)))))))))))
(defunassert get-zone-text (text)
(text (or string coerced-function))
(typecase text
@@ -525,18 +512,16 @@
(progn
(setf (sogginess-of i) (sogginess-capacity-of i))
(collect i)))))
-(defunassert swell-up (user)
+(defunassert swell-up (user &aux (swollen-clothes (swell-up% user)) (name (name-of user)))
(user base-character)
- (let ((swollen-clothes (swell-up% user))
- (name (name-of user)))
- (cond
- ((filter-items swollen-clothes 'diaper)
- (format t "~a's diapers swells up humorously~%~%" name))
- ((filter-items swollen-clothes 'pullup)
- (format t "~a's pullups swells up humorously~%~%" name))
- ((filter-items swollen-clothes 'stuffer)
- (format t "~a's incontinence pad swells up~%~%" name)))
- (pop-from-expansion user)))
+ (cond
+ ((filter-items swollen-clothes 'diaper)
+ (format t "~a's diapers swells up humorously~%~%" name))
+ ((filter-items swollen-clothes 'pullup)
+ (format t "~a's pullups swells up humorously~%~%" name))
+ ((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)))
@@ -555,7 +540,7 @@
(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)
+(defunassert pop-from-expansion (user &optional wet/mess &aux (reverse-wear (nreverse (wear-of user))) (last (car reverse-wear)) (return ()))
(user base-character)
(macrolet ((pushclothing (i wet/mess return)
`(progn
@@ -566,56 +551,53 @@
(> (getf (cdr ,wet/mess) :mess-amount) 0))
(pushnew ,i (getf (cdr ,wet/mess) :popped)))
(pushnew ,i ,return))))
- (let* ((reverse-wear (nreverse (wear-of user)))
- (last (car reverse-wear))
- (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))))))
- (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))))))
+ (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))))))
+ (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)
(s:dsu-sort (iter (for i in clothing)
@@ -623,16 +605,15 @@
(collect i)))
'>
:key 'get-diaper-expansion))
-(defunassert thickest (clothing &optional n)
+(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))
- (let ((a (iter (for i in clothing)
- (when (typep i 'closed-bottoms)
- (collect i)))))
- (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))))))
+ (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)))))
(defun move-to-zone (new-position &key ignore-lock direction old-position)
(when (iter (for i in (cons (player-of *game*) (allies-of *game*)))
(let ((wear (typecase (must-wear-of (get-zone new-position))
@@ -732,7 +713,9 @@
:ignore-lock t)
(unless (eq (fourth old-position) :pocket-map)
(setf (getf (attributes-of item) :pocket-map-position) old-position))))
-(defunassert wet (&key (wet-amount t) force-fill-amount pants-down accident force-wet-amount (wetter (player-of *game*)) (clothes nil clothes-supplied-p))
+(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)
@@ -741,71 +724,67 @@
~a."
(xref mess :function))
- (let* ((return-value ())
- (affected-clothes ())
- (random (random 4))
- (amount nil)
- (clothes (if clothes-supplied-p clothes (wear-of wetter))))
- (when force-fill-amount
- (setf (bladder/contents-of wetter) force-fill-amount))
- (cond (force-wet-amount
- (setf amount (cond ((eq force-wet-amount t)
+ (when force-fill-amount
+ (setf (bladder/contents-of wetter) force-fill-amount))
+ (cond (force-wet-amount
+ (setf amount (cond ((eq force-wet-amount t)
+ (bladder/contents-of wetter))
+ ((> force-wet-amount (bladder/contents-of wetter))
+ (bladder/contents-of wetter))
+ (t
+ force-wet-amount))))
+ ((< (bladder/contents-of wetter) (bladder/need-to-potty-limit-of wetter))
+ (return-from wet `(:old-bladder-contents ,(bladder/contents-of wetter)
+ :new-bladder-contents ,(bladder/contents-of wetter)
+ :affected-clothes ()
+ :leak-amount 0
+ :wet-amount 0)))
+ (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)))))
+ (t (setf amount (cond ((eq wet-amount t)
(bladder/contents-of wetter))
- ((> force-wet-amount (bladder/contents-of wetter))
+ ((> wet-amount (bladder/contents-of wetter))
(bladder/contents-of wetter))
(t
- force-wet-amount))))
- ((< (bladder/contents-of wetter) (bladder/need-to-potty-limit-of wetter))
- (return-from wet `(:old-bladder-contents ,(bladder/contents-of wetter)
- :new-bladder-contents ,(bladder/contents-of wetter)
- :affected-clothes ()
- :leak-amount 0
- :wet-amount 0)))
- (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)))))
- (t (setf amount (cond ((eq wet-amount t)
- (bladder/contents-of wetter))
- ((> wet-amount (bladder/contents-of wetter))
- (bladder/contents-of wetter))
- (t
- wet-amount)))))
- (setf (getf return-value :accident)
- (if accident
- (a:switch (random :test '=)
- (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)))
- (decf (bladder/contents-of wetter) amount)
- (setf amount-left 0))
- (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)
- (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)
- (setf (getf return-value :wet-amount) amount))
- 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))
+ wet-amount)))))
+ (setf (getf return-value :accident)
+ (if accident
+ (a:switch (random :test '=)
+ (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)))
+ (decf (bladder/contents-of wetter) amount)
+ (setf amount-left 0))
+ (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)
+ (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)
+ (setf (getf return-value :wet-amount) amount))
+ 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)
@@ -815,58 +794,54 @@
~a."
(xref wet :function))
- (let* ((return-value ())
- (affected-clothes ())
- (amount nil)
- (clothes (if clothes-supplied-p clothes (wear-of messer))))
- (when force-fill-amount
- (setf (bowels/contents-of messer) force-fill-amount))
- (cond (force-mess-amount
- (setf amount (cond ((eq force-mess-amount t)
+ (when force-fill-amount
+ (setf (bowels/contents-of messer) force-fill-amount))
+ (cond (force-mess-amount
+ (setf amount (cond ((eq force-mess-amount t)
+ (bowels/contents-of messer))
+ ((> force-mess-amount (bowels/contents-of messer))
+ (bowels/contents-of messer))
+ (t
+ force-mess-amount))))
+ ((< (bowels/contents-of messer) (bowels/need-to-potty-limit-of messer))
+ (return-from mess `(:old-bowels-contents ,(bowels/contents-of messer)
+ :new-bowels-contents ,(bowels/contents-of messer)
+ :affected-clothes ()
+ :leak-amount 0
+ :mess-amount 0)))
+ (accident
+ (setf amount (bowels/contents-of messer)))
+ (t (setf amount (cond ((eq mess-amount t)
(bowels/contents-of messer))
- ((> force-mess-amount (bowels/contents-of messer))
+ ((> mess-amount (bowels/contents-of messer))
(bowels/contents-of messer))
(t
- force-mess-amount))))
- ((< (bowels/contents-of messer) (bowels/need-to-potty-limit-of messer))
- (return-from mess `(:old-bowels-contents ,(bowels/contents-of messer)
- :new-bowels-contents ,(bowels/contents-of messer)
- :affected-clothes ()
- :leak-amount 0
- :mess-amount 0)))
- (accident
- (setf amount (bowels/contents-of messer)))
- (t (setf amount (cond ((eq mess-amount t)
- (bowels/contents-of messer))
- ((> mess-amount (bowels/contents-of messer))
- (bowels/contents-of messer))
- (t
- mess-amount)))))
- (setf (getf return-value :old-bowels-contents) (bowels/contents-of messer))
- (let* ((amount-left amount))
- (cond ((or pants-down (not (filter-items clothes 'closed-bottoms)))
- (decf (bowels/contents-of messer) amount)
- (setf amount-left 0))
- (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)
- (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)
- (setf (getf return-value :mess-amount) amount))
- return-value))
+ mess-amount)))))
+ (setf (getf return-value :old-bowels-contents) (bowels/contents-of messer))
+ (let* ((amount-left amount))
+ (cond ((or pants-down (not (filter-items clothes 'closed-bottoms)))
+ (decf (bowels/contents-of messer) amount)
+ (setf amount-left 0))
+ (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)
+ (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)
+ (setf (getf return-value :mess-amount) amount))
+ return-value)
(defunassert potty-on-toilet (prop &key wet mess pants-down (user (player-of *game*)))
(prop yadfa-props:toilet
wet (or boolean real)
@@ -1475,103 +1450,97 @@
(let ((*standard-output* s))
(describe (action-lambda b)))))))
t)
-(defun finish-battle (&optional lose)
- (let* ((player (player-of *game*))
- (male (malep player))
- (name (name-of player))
- (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))
- (format t
- "~a blacked out and flooded and messed ~aself~%~a wakes up and looks at ~a GPS to find out ~a's at ~a at ~a~%"
- name
- (if male "him" "her")
- name
- (if male "his" "her")
- (if male "he" "she")
- (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)))
- (let ((exp-gained (/ (iter (for enemy in enemies)
- (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))
+(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*)))
+ (if lose
+ (progn (format t "~a was defeated~%" name)
+ (setf (position-of player) (warp-on-death-point-of player))
+ (format t
+ "~a blacked out and flooded and messed ~aself~%~a wakes up and looks at ~a GPS to find out ~a's at ~a at ~a~%"
+ name
+ (if male "him" "her")
+ name
+ (if male "his" "her")
+ (if male "he" "she")
+ (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)))
+ (let ((exp-gained (/ (iter (for enemy in enemies)
+ (with j = 0)
+ (incf j (calculate-exp-yield enemy))
+ (finally (return j)))
+ 2)))
(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))))
- (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))))
- (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))))
- (exp-gained (iter (for enemy in enemies)
- (with j = 0)
- (incf j (calculate-exp-yield enemy))
+ (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))
+ (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))))
+ (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))))
- (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))))))))))
- (cond ((and items-looted (> bitcoins-looted 0))
- (format t "~a loots ~d bitcoins and ~d ~a from the enemies~%"
- name
- bitcoins-looted
- (list-length items-looted)
- (if (= (list-length items-looted) 1)
- "item"
- "items")))
- (items-looted
- (format t "~a loots ~d ~a from the enemy~%"
- name
- (list-length items-looted)
- (if (= (list-length items-looted) 1)
- "item"
- "items")))
- ((> bitcoins-looted 0)
- (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))))
- (switch-user-packages))
- t)
+ (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))))
+ (exp-gained (iter (for enemy in enemies)
+ (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))))))))))
+ (cond ((and items-looted (> bitcoins-looted 0))
+ (format t "~a loots ~d bitcoins and ~d ~a from the enemies~%"
+ name
+ bitcoins-looted
+ (list-length items-looted)
+ (if (= (list-length items-looted) 1)
+ "item"
+ "items")))
+ (items-looted
+ (format t "~a loots ~d ~a from the enemy~%"
+ name
+ (list-length items-looted)
+ (if (= (list-length items-looted) 1)
+ "item"
+ "items")))
+ ((> bitcoins-looted 0)
+ (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))))
+ (switch-user-packages))
(defun wash (clothing)
(declare (type list clothing))
(iter (for i in (filter-items clothing 'closed-bottoms))
@@ -1980,26 +1949,25 @@
(setf (inventory-of ally) ()
(bitcoins-of ally) 0)
t)
-(defun use-item% (item user &rest keys &key target action &allow-other-keys)
- (let* ((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))
- ((and (not action)
- (not (compute-applicable-methods #'use-script (list item user target))))
- (error 'item-use-script-missing-error :format-control "~s has no ~s method defined" :format-arguments `(,item use-script))))
- (let ((ret (if script
- (apply (coerce script 'function) item target keys)
- (use-script item user target))))
- (when (consumablep item)
- (a:deletef (the list (inventory-of user)) item))
- (when (> (health-of target) (calculate-stat target :health))
- (setf (health-of target) (calculate-stat target :health)))
- (when (> (energy-of target) (calculate-stat target :energy))
- (setf (energy-of target) (calculate-stat target :energy)))
- ret))))
+(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))))
+ (unless (apply 'cant-use-p item user target action keys)
+ (cond ((and action effective-action)
+ (error 'item-action-missing :action action :item item))
+ ((and (not action)
+ (not (compute-applicable-methods #'use-script (list item user target))))
+ (error 'item-use-script-missing-error :format-control "~s has no ~s method defined" :format-arguments `(,item use-script))))
+ (let ((ret (if script
+ (apply (coerce script 'function) item target keys)
+ (use-script item user target))))
+ (when (consumablep item)
+ (a:deletef (the list (inventory-of user)) item))
+ (when (> (health-of target) (calculate-stat target :health))
+ (setf (health-of target) (calculate-stat target :health)))
+ (when (> (energy-of target) (calculate-stat target :energy))
+ (setf (energy-of target) (calculate-stat target :energy)))
+ ret)))
(defunassert set-player (name malep species)
(malep boolean
name simple-string
@@ -2009,84 +1977,83 @@
(setf (species-of (player-of *game*)) species)
(setf (malep (player-of *game*)) malep)
t)
-(defun intro-function ()
+(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)
"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*)
- (let* ((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)
- (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*)))
- (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 (player-of *game*) (make-instance 'player
- :position '(0 0 0 yadfa-zones:home)
- :name name
- :male male
- :species species
- :description bio
- :skin skin
- :wings wings
- :tail (when tail-type (cons tail-type tail))
- :bladder/need-to-potty-limit (getf '(:normal 300 :low 200 :overactive 149) bladder)
- :bladder/potty-dance-limit (getf '(:normal 450 :low 300 :overactive 150) bladder)
- :bladder/potty-desperate-limit (getf '(:normal 525 :low 350 :overactive 160) bladder)
- :bladder/maximum-limit (getf '(:normal 600 :low 400 :overactive 200) bladder)
- :bladder/contents (getf '(:normal 450 :low 300 :overactive 150) bladder)
- :bowels/need-to-potty-limit (getf '(:normal 400 :low 800/3 :kid 140) bowels)
- :bowels/potty-dance-limit (getf '(:normal 600 :low 400 :kid 210) bowels)
- :bowels/potty-desperate-limit (getf '(:normal 700 :low 1400/3 :kid 245) bowels)
- :bowels/maximum-limit (getf '(:normal 800 :low 1600/3 :kid 280) bowels)
- :bladder/fill-rate (getf '(:normal 25/9
- :fast 50/9
- :faster 100/9)
- fill-rate)
- :bowels/fill-rate (getf '(:normal 5/9
- :fast 10/9
- :faster 20/9)
- fill-rate)
- :wear (iter (for i in wear)
- (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*))))))
- (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*)))
+ (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*)))
+ (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 (player-of *game*) (make-instance 'player
+ :position '(0 0 0 yadfa-zones:home)
+ :name name
+ :male male
+ :species species
+ :description bio
+ :skin skin
+ :wings wings
+ :tail (when tail-type (cons tail-type tail))
+ :bladder/need-to-potty-limit (getf '(:normal 300 :low 200 :overactive 149) bladder)
+ :bladder/potty-dance-limit (getf '(:normal 450 :low 300 :overactive 150) bladder)
+ :bladder/potty-desperate-limit (getf '(:normal 525 :low 350 :overactive 160) bladder)
+ :bladder/maximum-limit (getf '(:normal 600 :low 400 :overactive 200) bladder)
+ :bladder/contents (getf '(:normal 450 :low 300 :overactive 150) bladder)
+ :bowels/need-to-potty-limit (getf '(:normal 400 :low 800/3 :kid 140) bowels)
+ :bowels/potty-dance-limit (getf '(:normal 600 :low 400 :kid 210) bowels)
+ :bowels/potty-desperate-limit (getf '(:normal 700 :low 1400/3 :kid 245) bowels)
+ :bowels/maximum-limit (getf '(:normal 800 :low 1600/3 :kid 280) bowels)
+ :bladder/fill-rate (getf '(:normal 25/9
+ :fast 50/9
+ :faster 100/9)
+ fill-rate)
+ :bowels/fill-rate (getf '(:normal 5/9
+ :fast 10/9
+ :faster 20/9)
+ fill-rate)
+ :wear (iter (for i in wear)
+ (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*))))))
+ (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*))