clwars/plumbing.lisp

;;; TABLE PRINTING
;;; Taken from: https://gist.github.com/WetHat/a49e6f2140b401a190d45d31e052af8f
;;; Used for pretty printing output
(defvar +CELL-FORMATS+ '(:left   "~vA"
                         :center "~v:@<~A~>"
                         :right  "~v@A"))

(defun format-table (stream data &key (column-label (loop for i from 1 to (length (car data))
                                                          collect (format nil "COL~D" i)))
                                      (column-align (loop for i from 1 to (length (car data))
                                                          collect :left)))
    (let* ((col-count (length column-label))
           (strtable  (cons column-label ; table header
                          (loop for row in data ; table body with all cells as strings
                              collect (loop for cell in row
                                           collect (if (stringp cell)
                                                        cell
                                                    ;else
                                                        (format nil "~A" cell))))))
           (col-widths (loop with widths = (make-array col-count :initial-element 0)
                           for row in strtable
                           do (loop for cell in row
                                    for i from 0
                                  do (setf (aref widths i)
                                         (max (aref widths i) (length cell))))
                           finally (return widths))))
        ;------------------------------------------------------------------------------------
        ; splice in the header separator
        (setq strtable
              (nconc (list (car strtable) ; table header
                           (loop for align in column-align ; generate separator
                                 for width across col-widths
                               collect (case align
                                           (:left   (format nil ":~v@{~A~:*~}"
                                                        (1- width)  "-"))
                                           (:right  (format nil "~v@{~A~:*~}:"
                                                        (1- width)  "-"))
                                           (:center (format nil ":~v@{~A~:*~}:"
                                                        (- width 2) "-")))))
                           (cdr strtable))) ; table body
        ;------------------------------------------------------------------------------------
        ; Generate the formatted table
        (let ((row-fmt (format nil "| ~{~A~^ | ~} |~~%" ; compile the row format
                           (loop for align in column-align
                               collect (getf +CELL-FORMATS+ align))))
              (widths  (loop for w across col-widths collect w)))
            ; write each line to the given stream
            (dolist (row strtable)
              (apply #'format stream row-fmt (mapcan #'list widths row))))))


;; https://stackoverflow.com/questions/4882361/which-command-could-be-used-to-clear-screen-in-clisp
(defun cls()
  (format t "~A[H~@*~A[J" #\escape))

(defun prompt-read (prompt)
  (format *query-io* "~a" prompt)
  (force-output *query-io*)
  (read-line *query-io*))

(defun handle-opt (opt lookup-table)
  "When given a string and a list 'lookup table' call the
   function associated with the opt used"
  (let ((handler (cdr (assoc opt lookup-table))))
    (if handler (funcall handler) (format t "Invalid opt~%~%"))))

(defun return-slots (obj)
  "Given an object, return the names of it's slots"
  (map 'list #'closer-mop:slot-definition-name (closer-mop:class-slots (class-of obj))))

(defun simple-print-object (obj)
  "Given an object, print it's slots and slot values"
  (loop for slot in (return-slots obj)
	do (format T "Slot: ~A Value: ~A~%" 
		   slot
		   (slot-value obj slot))))

(defun make-name (name-prefixes name-values)
  "Expects a list of strings to use as prefixes for a name, and a list
   of possible names"
  (let ((name (nth (random (length name-values)) name-values))
	(prefix (nth (random (length name-prefixes)) name-prefixes)))
    (concatenate 'string prefix " " name)))