端末操作

今日は端末操作用のエスケープシーケンスを調べる機会があったので、その内の自分が良く使いそうな操作をcommon lispのパッケージとしてまとめておくことにする。

(defpackage ppterm
  (:use :common-lisp)
  (:export *colorset*
           color
           clear
           cursor))
(in-package :ppterm)

(defvar *colorset* '(:black :red :green :brown :blue :purple :cyan :light-gray))
(defvar *fg-color-codes* (loop FOR i FROM 30 TO 37 COLLECT i))
(defvar *bg-color-codes* (loop FOR i FROM 40 TO 47 COLLECT i))

(defconstant +ESC-CHAR+ (code-char #o33))

;; 文字の色(+その他)変更用のエスケープシーケンス
(deftype colorset () `(member ,@*colorset*))
(defun color (string &key color back bold underline inverse)
  (declare ((or null colorset) color back)
           (boolean bold underline inverse))
  (with-output-to-string (out)
    ;; エスケープシーケンス開始
    (format out "~C["   +ESC-CHAR+)

    ;; 文字の色などを設定
    (format out "~{~D~^;~}"
      (remove nil
        (list
         ;; 文字色
         (when color
           #.`(ecase color
                ,@(mapcar (lambda (color code) `(,color ,code))
                          *colorset* *fg-color-codes*)))
         ;; 背景色
         (when back
           #.`(ecase back
                ,@(mapcar (lambda (color code) `(,color ,code))
                          *colorset* *bg-color-codes*)))
         ;; 太字
         (when bold      1)
         ;; 下線
         (when underline 4)
         ;; 反転
         (when inverse   7))))
     
    ;; 文字列出力
    (format out "m~A" string)

    ;; エスケープシーケンス終了
    (format out "~C[0m" +ESC-CHAR+)))

;; カーソル位置設定用のエスケープシーケンス
(deftype cursor-position () '(integer 0 #.most-positive-fixnum))
(defun cursor (&key x y up down left right)
  (declare ((or null cursor-position) x y up down left right))
  (when (and x (null y))  (setf y 0))
  (when (and y (null x))  (setf x 0))
 
  (with-output-to-string (out)
    (when x 
      (format out "~C[~D;~DH" +ESC-CHAR+ y x)) ;; カーソル位置を(x,y)で指定
    (when up
      (format out "~C[~DA" +ESC-CHAR+ up))     ;; カーソルをup分上に移動
    (when down
      (format out "~C[~DB" +ESC-CHAR+ down))   ;; カーソルをdown分下に移動
    (when left
      (format out "~C[~DD" +ESC-CHAR+ left))   ;; カーソルをleft分右に移動
    (when right
      (format out "~C[~DC" +ESC-CHAR+ right))));; カーソルをright分左に移動

;; 画面クリア用のエスケープシーケンス
;; lineがtなら、一行のみを、nilなら画面全体をクリアする
(defun clear (&optional line)
  (declare (boolean line))
  (with-output-to-string (out)
    (format out "~C[~:[2J~;K~]" +ESC-CHAR+ line)))

使用例。

> (ppterm:color "赤い文字" :color :red)




> "赤い文字"

少し長い例。
三目並べ 。※いろいろ適当

;; 盤を表示。ここでpptermを使用。
(defun print-board (board)
  (princ (ppterm:clear))
  (loop FOR x FROM 0 TO 2 DO
    (loop FOR y FROM 0 TO 2 DO
      (princ (ppterm:cursor :x (* 2 (1+ x)) :y (1+ y)))
      (case (aref board x y)
        (:first  (princ (ppterm:color "■" :color :red  :bold t)))
        (:second (princ (ppterm:color "■" :color :blue :bold t)))
        (otherwise (princ (ppterm:color "□" :color :black)))))))

;; ゲームが終了したかどうかの判定
(defun finish? (board)
  (loop FOR player IN '(:first :second) DO
    (when (or (some 
               (lambda (i)
                 (or (loop FOR x FROM 0 TO 2 ALWAYS (eq (aref board x i) player))   ; 横一列
                     (loop FOR y FROM 0 TO 2 ALWAYS (eq (aref board i y) player)))) ; 縦一列
               '(0 1 2)) 
              (loop FOR x FROM 0 TO 2 
                    FOR y FROM 0 TO 2 
                ALWAYS (eq (aref board x y) player))  ; 斜め1
              (loop FOR x FROM 0 TO 2 
                    FOR y FROM 2 DOWNTO 0
                ALWAYS (eq (aref board x y) player))) ; 斜め2
      (return-from finish? player)))
  
  (when (loop FOR i FROM 0 BELOW (array-total-size board) ; 全部のマスが埋まっているかどうか
              ALWAYS (row-major-aref board i))
    (return-from finish? :draw)))

;; 
(defun game ()
  (let ((board (make-array '(3 3) :initial-element nil)))
    (loop UNTIL (finish? board) 
          FOR player = :first THEN (if (eq player :first) :second :first)
      DO
      (loop
       (print-board board)
       (format t "~&~:[後手~;先手~](x y): " (eq player :first))
       (force-output)
       (let ((x (read))
             (y (read)))
         (when (and (<= 0 x 2)
                    (<= 0 y 2)
                    (null (aref board x y)))
           (setf (aref board x y) player)
           (return)))))
    (print-board board)
    (format t "~&~A" (finish? board))
    (force-output))
  (values))

;; 実行
> (game)
; ...
; ...