use CLIM:FORMATTING-TABLE as it works with variable width fonts

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