aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Pouar <pouar@pouar.net>2020-07-04 19:26:45 -0500
committerGravatar Pouar <pouar@pouar.net>2020-07-04 19:26:45 -0500
commit41ac6f5005e84238cb0a54f1a927cefea236d897 (patch)
tree623dda3438b0da74898753162ce8f600ac672a27
parentmore helpful dialog (diff)
use CLIM:FORMATTING-TABLE as it works with variable width fonts
-rw-r--r--core/bin.lisp251
-rw-r--r--core/libexec.lisp33
-rw-r--r--packages.lisp1
3 files changed, 168 insertions, 117 deletions
diff --git a/core/bin.lisp b/core/bin.lisp
index e3cb66e..5ac1f73 100644
--- a/core/bin.lisp
+++ b/core/bin.lisp
@@ -163,83 +163,103 @@ You can also specify multiple directions, for example @code{(move :south :south)
inventory type-specifier)
"used to list various objects and properties, @var{INVENTORY} takes a type specifier for the items you want to list in your inventory. setting @var{INVENTORY} to @code{T} will list all the items. @var{INVENTORY-GROUP} is similar to @var{INVENTORY}, but will group the items by class name. @var{WEAR} is similar to @var{INVENTORY} but lists clothes you're wearing instead. setting @var{DIRECTIONS} to non-NIL will list the directions you can walk.setting @var{MOVES} to non-NIL will list the moves you know. setting @var{USER} to @code{T} will cause @var{MOVES} and @var{WEAR} to apply to the player, setting it to an integer will cause it to apply it to an ally. Leaving it at @code{NIL} will cause it to apply to everyone. setting @var{POSITION} to true will print your current position. Setting @var{MAP} to a number will print the map with the floor number set to @var{MAP}, setting @var{MAP} to @code{T} will print the map of the current floor you're on. When printing the map in McCLIM, red means there's a warp point, dark green is the zone with the player, blue means there are stairs. These 3 colors will blend with each other to make the final color"
(let ((allies-length (list-length (allies-of *game*))))
- (flet ((format-items (list item &optional user)
- (format t "Number of items listed: ~a~%~%" (iter (with j = 0)
- (for i in list)
- (when (typep i item)
- (incf j))
- (finally (return j))))
- (when user
- (format t "~a:~%~%" (name-of user)))
- (format t "~7a~30a~40a~12a~12a~12a~12a~%" "Index" "Name" "Class" "Wet" "Wetcap" "Mess" "Messcap")
- (let ((j 0)) (iter (for i in list)
- (when (typep i item)
- (format t "~7a~30a~40s~12a~12a~12a~12a~%" j
- (name-of i)
- (type-of i)
- (if (typep i 'closed-bottoms) (format nil "~12d" (coerce (sogginess-of i) 'long-float)) nil)
- (if (typep i 'closed-bottoms) (format nil "~12d" (coerce (sogginess-capacity-of i) 'long-float)) nil)
- (if (typep i 'closed-bottoms) (format nil "~12d" (coerce (messiness-of i) 'long-float)) nil)
- (if (typep i 'closed-bottoms) (format nil "~12d" (coerce (messiness-capacity-of i) 'long-float)) nil)))
- (incf j))
- (terpri)))
- (format-moves (user)
- (format t "~a:~%~%" (name-of user))
- (format t "~30a~20a~40a~%" "Symbol" "Name" "Description")
- (iter (for i in (moves-of user))
- (when i (format t "~30s~20a~40a~%" (class-name (class-of i)) (name-of i) (description-of i))))
- (terpri))
- (format-user (user)
- (format t "Name: ~a~%Species: ~a~%Description: ~a~%~%"
- (name-of user)
- (species-of user)
- (description-of user)))
- (check-allies ()
- (when (and (typep user 'unsigned-byte) (< allies-length user))
- (format t "You only have ~d allies~%" allies-length)
- (return-from yadfa-bin:lst))))
+ (labels ((format-table (header &rest body)
+ (c:formatting-table (t :x-spacing 20)
+ (c:with-text-style (*query-io* (c:make-text-style nil :bold nil))
+ (c:formatting-row ()
+ (iter (for cell in header)
+ (c:formatting-cell ()
+ (typecase cell
+ (string (write-string cell))
+ (t (write cell)))))))
+ (iter (for row in body)
+ (c:formatting-row ()
+ (iter (for cell in row)
+ (c:formatting-cell ()
+ (typecase cell
+ (string (write-string cell))
+ (t (write cell)))))))))
+ (format-items (list item &optional user)
+ (format t "Number of items listed: ~a~%~%" (iter (with j = 0)
+ (for i in list)
+ (when (typep i item)
+ (incf j))
+ (finally (return j))))
+ (when user
+ (format t "~a:~%~%" (name-of user)))
+ (apply #'format-table '("Index" "Name" "Class" "Wet" "Wetcap" "Mess" "Messcap")
+ (let ((j 0)) (iter (for i in list)
+ (when (typep i item)
+ (collect (list j
+ (name-of i)
+ (type-of i)
+ (if (typep i 'closed-bottoms) (coerce (sogginess-of i) 'long-float) nil)
+ (if (typep i 'closed-bottoms) (coerce (sogginess-capacity-of i) 'long-float) nil)
+ (if (typep i 'closed-bottoms) (coerce (messiness-of i) 'long-float) nil)
+ (if (typep i 'closed-bottoms) (coerce (messiness-capacity-of i) 'long-float) nil))))
+ (incf j)))))
+ (format-moves (user)
+ (format t "~a:~%~%" (name-of user))
+ (apply #'format-table '("Symbol" "Name" "Description")
+ (iter (for i in (moves-of user))
+ (when i (collect (list (class-name (class-of i)) (name-of i) (description-of i)))))))
+ (format-user (user)
+ (format t "Name: ~a~%Species: ~a~%Description: ~a~%~%"
+ (name-of user)
+ (species-of user)
+ (description-of user)))
+ (check-allies ()
+ (when (and (typep user 'unsigned-byte) (< allies-length user))
+ (format t "You only have ~d allies~%" allies-length)
+ (return-from yadfa-bin:lst))))
(check-allies)
(when inventory
- (format-items (inventory-of (player-of *game*)) inventory))
+ (with-effective-frame
+ (format-items (inventory-of (player-of *game*)) inventory)))
(when describe-zone
(format t "~a~%" (get-zone-text (description-of (typecase describe-zone
(zone describe-zone)
(list (get-zone describe-zone))
(t (get-zone (position-of (player-of *game*)))))))))
(when inventory-group
- (let ((a ()))
- (iter (for i in (inventory-of (player-of *game*)))
- (when (typep i inventory-group)
- (if (getf a (class-name (class-of i)))
- (incf (second (getf a (class-name (class-of i)))))
- (setf (getf a (class-name (class-of i))) (list (name-of (make-instance (class-name (class-of i)))) 1)))))
- (format t "~30a~40a~10a~%" "Class Name" "Name" "Quantity")
- (iter (for (key value) on a by #'cddr)
- (apply #'format t "~30a~40a~10a~%" key value))))
+ (with-effective-frame
+ (let ((a ()))
+ (iter (for i in (inventory-of (player-of *game*)))
+ (when (typep i inventory-group)
+ (if (getf a (class-name (class-of i)))
+ (incf (second (getf a (class-name (class-of i)))))
+ (setf (getf a (class-name (class-of i))) (list (name-of (make-instance (class-name (class-of i)))) 1)))))
+ (apply #'format-table '("Class Name" "Name" "Quantity")
+ (iter (for (key value) on a by #'cddr)
+ (collect (apply 'list key value)))))))
(when wear
- (cond ((not user)
- (format-items (wear-of (player-of *game*)) wear (player-of *game*))
- (iter (for k in (allies-of *game*))
- (format-items (wear-of k) wear k)))
- ((typep user 'integer)
- (let ((selected-ally (nth user (allies-of *game*))))
- (check-allies)
- (format-items (wear-of selected-ally) wear selected-ally)))
- (t
- (format-items (wear-of (player-of *game*)) wear (player-of *game*)))))
+ (with-effective-frame
+ (cond ((not user)
+ (format-items (wear-of (player-of *game*)) wear (player-of *game*))
+ (iter (for k in (allies-of *game*))
+ (format-items (wear-of k) wear k)))
+ ((typep user 'integer)
+ (let ((selected-ally (nth user (allies-of *game*))))
+ (check-allies)
+ (format-items (wear-of selected-ally) wear selected-ally)))
+ (t
+ (format-items (wear-of (player-of *game*)) wear (player-of *game*))))))
(when moves
- (cond ((typep user 'real)
- (let ((selected-ally (nth user (allies-of *game*))))
- (format-moves selected-ally)))
- ((not user)
- (format-moves (player-of *game*))
- (iter (for k in (allies-of *game*))
- (format-moves k)))
- (t (format-moves (player-of *game*)))))
- (when props (format t "~20a~30a~%" "Keyword" "Object")
- (iter (for (a b) on (get-props-from-zone (position-of (player-of *game*))) by #'cddr)
- (when b
- (format t ":~20a~30a~%" a (name-of b)))))
+ (with-effective-frame
+ (cond ((typep user 'real)
+ (let ((selected-ally (nth user (allies-of *game*))))
+ (format-moves selected-ally)))
+ ((not user)
+ (format-moves (player-of *game*))
+ (iter (for k in (allies-of *game*))
+ (format-moves k)))
+ (t (format-moves (player-of *game*))))))
+ (when props
+ (with-effective-frame
+ (apply #'format-table '("Keyword" "Object")
+ (iter (for (a b) on (get-props-from-zone (position-of (player-of *game*))) by #'cddr)
+ (when b
+ (collect (list a (name-of b))))))))
(let ((player-position (position-of (player-of *game*))))
(declare (type list player-position))
(destructuring-bind (x y z map) player-position
@@ -362,46 +382,63 @@ You can also specify multiple directions, for example @code{(move :south :south)
~a."
(xref yadfa-bin:lst :function))
(when (typep take 'list) (loop for i in take do (check-type i unsigned-byte)))
- (when list
- (format t "Bitcoins: ~a~%~%" (get-bitcoins-from-prop prop (position-of (player-of *game*))))
- (format t "~7a~30a~30a~%" "Index" "Name" "Class")
- (iter (for i in (get-items-from-prop prop (position-of (player-of *game*))))
- (declaring fixnum for j upfrom 0)
- (format t "~7a~30a~30s~%" j (name-of i) (type-of i)))
- (format t "~%~%Actions: ")
- (iter (for (key value) on (actions-of (getf (get-props-from-zone (position-of (player-of *game*))) prop)) by #'cddr)
- (when value
- (format t "~s " key)
- (finally (write-char #\Newline)))))
- (when take
- (cond ((eq take :all)
- (setf (inventory-of (player-of *game*)) (append* (get-items-from-prop prop (position-of (player-of *game*))) (inventory-of (player-of *game*))))
- (setf (get-items-from-prop prop (position-of (player-of *game*))) '())
- (incf (bitcoins-of (player-of *game*)) (get-bitcoins-from-prop prop (position-of (player-of *game*))))
- (setf (get-bitcoins-from-prop prop (position-of (player-of *game*))) 0))
- ((eq take :bitcoins)
- (incf (bitcoins-of (player-of *game*)) (get-bitcoins-from-prop prop (position-of (player-of *game*))))
- (setf (get-bitcoins-from-prop prop (position-of (player-of *game*))) 0))
- (t
- (iter (for i in take)
- (push (nth i (get-items-from-prop prop (position-of (player-of *game*)))) (inventory-of (player-of *game*))))
- (iter (for i in (sort (copy-tree take) #'>))
- (setf (get-items-from-prop prop (position-of (player-of *game*))) (remove-nth i (get-items-from-prop prop (position-of (player-of *game*)))))))))
- (when action
- (apply (coerce (action-lambda (getf-action-from-prop (position-of (player-of *game*)) prop action))
- 'function)
- (getf (get-props-from-zone (position-of (player-of *game*))) prop)
- :allow-other-keys t keys))
- (when describe-action
- (format t "Keyword: ~a~%~%Other Parameters: ~w~%~%Documentation: ~a~%~%Describe: ~a~%~%"
- describe-action
- (rest (lambda-list (action-lambda (getf-action-from-prop (position-of (player-of *game*)) prop describe-action))))
- (documentation (getf (actions-of (getf (get-props-from-zone (position-of (player-of *game*))) prop)) describe-action) t)
- (with-output-to-string (s)
- (let ((*standard-output* s))
- (describe (action-lambda (getf-action-from-prop (position-of (player-of *game*)) prop describe-action)))))))
- (when describe
- (format t "~a~%" (description-of (getf (get-props-from-zone (position-of (player-of *game*))) prop)))))
+ (flet ((format-table (header &rest body)
+ (c:formatting-table (t :x-spacing 20)
+ (c:with-text-style (*query-io* (c:make-text-style nil :bold nil))
+ (c:formatting-row ()
+ (iter (for cell in header)
+ (c:formatting-cell ()
+ (typecase cell
+ (string (write-string cell))
+ (t (write cell)))))))
+ (iter (for row in body)
+ (c:formatting-row ()
+ (iter (for cell in row)
+ (c:formatting-cell ()
+ (typecase cell
+ (string (write-string cell))
+ (t (write cell))))))))))
+ (when list
+ (with-effective-frame
+ (format t "Bitcoins: ~a~%~%" (get-bitcoins-from-prop prop (position-of (player-of *game*))))
+ (apply #'format-table '("Index" "Name" "Class")
+ (iter (for i in (get-items-from-prop prop (position-of (player-of *game*))))
+ (declaring fixnum for j upfrom 0)
+ (collect (list j (name-of i) (type-of i)))))
+ (format t "~%~%Actions: ")
+ (iter (for (key value) on (actions-of (getf (get-props-from-zone (position-of (player-of *game*))) prop)) by #'cddr)
+ (when value
+ (format t "~s " key)
+ (finally (write-char #\Newline))))))
+ (when take
+ (cond ((eq take :all)
+ (setf (inventory-of (player-of *game*)) (append* (get-items-from-prop prop (position-of (player-of *game*))) (inventory-of (player-of *game*))))
+ (setf (get-items-from-prop prop (position-of (player-of *game*))) '())
+ (incf (bitcoins-of (player-of *game*)) (get-bitcoins-from-prop prop (position-of (player-of *game*))))
+ (setf (get-bitcoins-from-prop prop (position-of (player-of *game*))) 0))
+ ((eq take :bitcoins)
+ (incf (bitcoins-of (player-of *game*)) (get-bitcoins-from-prop prop (position-of (player-of *game*))))
+ (setf (get-bitcoins-from-prop prop (position-of (player-of *game*))) 0))
+ (t
+ (iter (for i in take)
+ (push (nth i (get-items-from-prop prop (position-of (player-of *game*)))) (inventory-of (player-of *game*))))
+ (iter (for i in (sort (copy-tree take) #'>))
+ (setf (get-items-from-prop prop (position-of (player-of *game*))) (remove-nth i (get-items-from-prop prop (position-of (player-of *game*)))))))))
+ (when action
+ (apply (coerce (action-lambda (getf-action-from-prop (position-of (player-of *game*)) prop action))
+ 'function)
+ (getf (get-props-from-zone (position-of (player-of *game*))) prop)
+ :allow-other-keys t keys))
+ (when describe-action
+ (format t "Keyword: ~a~%~%Other Parameters: ~w~%~%Documentation: ~a~%~%Describe: ~a~%~%"
+ describe-action
+ (rest (lambda-list (action-lambda (getf-action-from-prop (position-of (player-of *game*)) prop describe-action))))
+ (documentation (getf (actions-of (getf (get-props-from-zone (position-of (player-of *game*))) prop)) describe-action) t)
+ (with-output-to-string (s)
+ (let ((*standard-output* s))
+ (describe (action-lambda (getf-action-from-prop (position-of (player-of *game*)) prop describe-action)))))))
+ (when describe
+ (format t "~a~%" (description-of (getf (get-props-from-zone (position-of (player-of *game*))) prop))))))
(defunassert yadfa-bin:wear (&key (inventory 0) (wear 0) user)
(user (or null unsigned-byte)
wear unsigned-byte
diff --git a/core/libexec.lisp b/core/libexec.lisp
index 4d5dbe6..949f924 100644
--- a/core/libexec.lisp
+++ b/core/libexec.lisp
@@ -294,20 +294,32 @@
(c:*application-frame*
,@body)
(t (clim:run-frame-top-level (clim:make-application-frame 'yadfa-clim::emacs-frame
+ :width 1024 :height 768
:emacs-frame-lambda (lambda (frame)
(let ((*query-io* (clim:frame-query-io frame)))
,@body)))))))
+(defmacro with-effective-frame (&body body)
+ `(cond
+ (c:*application-frame*
+ ,@body)
+ (t (clim:run-frame-top-level (clim:make-application-frame 'yadfa-clim::emacs-frame
+ :width 1024 :height 768
+ :emacs-frame-lambda (lambda (frame)
+ (let ((*query-io* (clim:frame-query-io frame)))
+ ,@body
+ (read-char *query-io*))))))))
(defmacro present-with-effective-frame (&body body)
`(cond
(c:*application-frame*
(push (clim:updating-output (*query-io*)
,@body)
yadfa-clim::*records*))
- (t (clim:run-frame-top-level (clim:make-application-frame 'yadfa-clim::emacs-frame :width 1024 :height 768
- :emacs-frame-lambda (lambda (frame)
- (let ((*query-io* (clim:frame-query-io frame)))
- ,@body
- (read-char *query-io*))))))))
+ (t (clim:run-frame-top-level (clim:make-application-frame 'yadfa-clim::emacs-frame
+ :width 1024 :height 768
+ :emacs-frame-lambda (lambda (frame)
+ (let ((*query-io* (clim:frame-query-io frame)))
+ ,@body
+ (read-char *query-io*))))))))
(defmacro updating-present-with-effective-frame
((stream
&key (unique-id nil unique-id-supplied-p) (id-test nil id-test-supplied-p)
@@ -327,11 +339,12 @@
,@(and record-type-supplied-p (and `(:record-type ,record-type))))
,@body)
yadfa-clim::*records*))
- (t (clim:run-frame-top-level (clim:make-application-frame 'yadfa-clim::emacs-frame :width 1024 :height 768
- :emacs-frame-lambda (lambda (frame)
- (let ((*query-io* (clim:frame-query-io frame)))
- ,@body
- (read-char *query-io*))))))))
+ (t (clim:run-frame-top-level (clim:make-application-frame 'yadfa-clim::emacs-frame
+ :width 1024 :height 768
+ :emacs-frame-lambda (lambda (frame)
+ (let ((*query-io* (clim:frame-query-io frame)))
+ ,@body
+ (read-char *query-io*))))))))
(declaim (ftype (function ((or symbol list)) list) trigger-event))
(defunassert trigger-event (event-ids)
(event-ids (or symbol list))
diff --git a/packages.lisp b/packages.lisp
index 810ab1c..f25e690 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -52,6 +52,7 @@
#:defonesie
#:make-pocket-zone
#:accept-with-effective-frame
+ #:with-effective-frame
#:present-with-effective-frame
#:updating-present-with-effective-frame
;;functions