herecy-term/herecy-term.lisp

(defpackage #:herecy-term
  (:use #:cl #:ettram #:trivial-gray-streams)
  (:export #:terminal #:move-cursor-relative #:clear-line
           #:make-terminal))

(in-package #:herecy-term)

(defun row-col-to-point (row col)
  (make-point (* (1- col) 8) (* (1- row) 16)))

(defclass cursor-state ()
  ((%row :accessor row :initform 1)
   (%col :accessor col :initform 1)
   (%blinkingp :accessor blinkingp :initform t)
   (%blink-phase :accessor blink-phase :initform 0)
   (%blink-state :accessor blink-state :initform t)
   (%visiblep :accessor visiblep :initform t)))

(defmethod cursor-picture-position ((cursor cursor-state))
  (with-accessors ((row row) (col col)) cursor
    (row-col-to-point row col)))

(defmethod set-cursor ((cursor cursor-state) row col)
  (setf (col cursor) col
        (row cursor) row))

(defclass input-buffer ()
  ((%array :accessor internal-array :initform (make-array 80 :element-type 'character :adjustable t :fill-pointer 0))
   (%write-index :accessor write-index :initform 0)
   (%readout-index :accessor readout-index :initform 0)
   (%finishedp :accessor finishedp :initform nil)))

#+(or)
(defmethod push-to-buffer ((buffer input-buffer) element)
  (vector-push-extend element (internal-array buffer)))

(defmethod insert-into-buffer ((buffer input-buffer) element)
  (let ((ia (internal-array buffer))
        (index (write-index buffer)))
    (loop :initially (vector-push-extend #\Null ia)
          :for index :from (- (length ia) 1) :downto index
          :do (setf (aref ia (1+ index)) (aref ia index)))
    (setf (aref ia index) element)
    (incf (write-index buffer))))

(defmethod rubout-from-buffer ((buffer input-buffer))
  (unless (zerop (write-index buffer))
    (let ((ia (internal-array buffer)))
      (decf (write-index buffer))
      (loop :for index :from (write-index buffer) :below (1- (length ia))
            :do (setf (aref ia index) (aref ia (1+ index)))
            :finally (pop-from-buffer buffer)))))

(defmethod consume-from-buffer ((buffer input-buffer))
  (cond ((< (readout-index buffer) (length (internal-array buffer)))
         (prog1
             (aref (internal-array buffer) (readout-index buffer))
           (incf (readout-index buffer))
           (when (>= (readout-index buffer) (length (internal-array buffer)))
             (reset-buffer buffer))))
        (t
         (prog1
             :eof
           (reset-buffer buffer)))))

(defmethod pop-from-buffer ((buffer input-buffer))
  (unless (buffer-empty-p buffer)
    (vector-pop (internal-array buffer))))

(defmethod finish-buffer ((buffer input-buffer))
  (setf (finishedp buffer) t))

(defmethod reset-buffer ((buffer input-buffer))
  (setf (finishedp buffer) nil
        (fill-pointer (internal-array buffer)) 0
        (readout-index buffer) 0
        (write-index buffer) 0))

(defmethod buffer-empty-p ((buffer input-buffer))
  (zerop (fill-pointer (internal-array buffer))))

(defclass terminal (fundamental-character-stream)
  ((%cursor-state :accessor cursor-state :initform (make-instance 'cursor-state))
   (%width :accessor width :initarg :columns :initarg :width)
   (%height :accessor height :initarg :rows :initarg :height)
   (%screen-grid :accessor screen-grid :initarg :grid)
   (%picture :accessor picture :initarg :picture)
   (%input-buffer :accessor input-buffer :initarg :input-buffer)
   (%overflowedp :accessor overflowedp :initform nil)
   (%command-state :accessor command-state :initform :normal)))

(defun make-terminal (rows columns picture)
  (make-instance 'terminal :picture picture :width columns :height rows
                 :grid (make-array (list rows columns) :element-type 'character
                                   :initial-element #\Space)
                 :input-buffer (make-instance 'input-buffer)))

(defmethod draw-screen-grid ((terminal terminal))
  (let ((original-row (row (cursor-state terminal)))
        (original-col (col (cursor-state terminal))))
    (loop :for col :from 1 :to (width terminal)
          :with cursor := (cursor-state terminal)
          :do (loop :for row :from 1 :to (height terminal)
                    :do (progn
                          (set-cursor cursor row col)
                          (print-to-picture (string (char-under-cursor terminal))
                                            (cursor-picture-position cursor)
                                            (picture terminal)))))
    (set-cursor (cursor-state terminal) original-row original-col)))

(defmethod update-cursor ((terminal terminal))
  (with-accessors ((cursor cursor-state)
                   (picture picture))
      terminal
    (incf (blink-phase cursor))
    (when (>= (blink-phase cursor) *blink-duration*)
      (setf (blink-phase cursor) 0
            (blink-state cursor) (not (blink-state cursor)))
      (let ((*fg-text-color* *fg-text-color*)
            (*bg-text-color* *bg-text-color*))
        (unless (blink-state cursor)
          (rotatef *fg-text-color* *bg-text-color*))
        (print-to-picture (string (char-under-cursor terminal))
                          (cursor-picture-position cursor) picture)))))

(defmethod reset-cursor-blinking ((terminal terminal))
  (let ((cursor (cursor-state terminal)))
    (setf (blink-state cursor) nil
          (blink-phase cursor) *blink-duration*)
    (update-cursor terminal)))

(defmethod scroll-down ((terminal terminal))
  ;; Scroll the screen grid
  (let ((grid (screen-grid terminal)))
    (loop :for y :from 0 :below (height terminal)
          :unless (= y 0)
            :do (dotimes (x (width terminal))
                  (setf (aref grid (1- y) x)
                        (aref grid y x))))
    (dotimes (x (width terminal))
      (setf (aref grid (1- (height terminal)) x)
            #\Space)))
  ;; Move cursor up a step
  (move-cursor-relative terminal -1 0)
  ;; Redisplay
  (draw-screen-grid terminal))

(defmethod move-cursor-absolute ((terminal terminal) row col)
  (let ((cursor (cursor-state terminal)))
    (setf row (max 1 row)
          col (max 1 col))
    (when (> col (width terminal))
      (setf col 1
            row (1+ row)))
    (cond ((> row (height terminal))
           (setf row (height terminal))
           (scroll-down terminal)
           (setf (overflowedp terminal) t))
          (t (setf (overflowedp terminal) nil)))
    ;; Ensure cursor blink is reset
    (reset-cursor-blinking terminal)
    ;; Perform the move
    (set-cursor cursor row col)
    (setf (blink-state cursor) t
          (blink-phase cursor) *blink-duration*)
    (update-cursor terminal)))

(defmethod move-cursor-relative ((terminal terminal) row col)
  (let ((cursor (cursor-state terminal)))
    (move-cursor-absolute terminal
                          (+ (row cursor) row)
                          (+ (col cursor) col))))

(defmethod char-under-cursor ((terminal terminal))
  (aref (screen-grid terminal)
        (1- (row (cursor-state terminal)))
        (1- (col (cursor-state terminal)))))

(defmethod put-character-at ((terminal terminal) row col char)
  (ettram:print-to-picture (string char)
                           (row-col-to-point row col)
                           (picture terminal))
  (setf (aref (screen-grid terminal) (1- row) (1- col)) char))

(defmethod put-character ((terminal terminal) char)
  (with-accessors ((row row) (col col))
      (cursor-state terminal)
    (put-character-at terminal row col char)
    (move-cursor-relative terminal
                          0
                          (if (= (character-width char) 8)
                              1
                              2))))

(defmethod clear-line ((terminal terminal))
  (dotimes (col (width terminal))
    (put-character-at terminal (row (cursor-state terminal)) (1+ col) #\Space)))

(defmethod stream-terpri ((stream terminal))
  (move-cursor-relative stream 1 -1000))

(defmethod stream-write-char ((stream terminal) character)
  (case (command-state stream)
    (:normal
     (case character
       (#\Newline (unless (overflowedp stream)
                    (terpri stream)))
       (#\Return (unless (overflowedp stream)
                    (terpri stream)))
       (#\Escape (setf (command-state stream) :escape))
       (t (put-character stream character))))
    (:escape
     (cerror "I also like to live dangerously." "Escape codes not implemented.")
     (case character
       (#\[ (setf (command-state stream) :csi))))
    (:csi
     (cerror "I also like to live dangerously." "CSI codes not implemented."))))

(defmethod stream-write-string ((stream terminal) string &optional start end)
  (let ((str string))
    (unless (null start)
      (setf str (subseq string start end)))
    (loop :for char :across str :do (write-char char stream))))

(defmethod stream-read-line ((stream terminal))
  (let ((buffer (input-buffer stream)))
    (loop :until (finishedp buffer)
          :do (sleep 1/30))
    (prog1
        (subseq (internal-array buffer)
                0 (1- (length (internal-array buffer))))
      (reset-buffer buffer))))

(defmethod stream-read-char ((stream terminal))
  (loop :until (finishedp (input-buffer stream))
        :do (sleep 1/30))
  (let ((popped (consume-from-buffer (input-buffer stream))))
    (when (buffer-empty-p (input-buffer stream))
      (reset-buffer (input-buffer stream)))
    popped))

(defmethod stream-force-output ((stream terminal)))

(defparameter *blink-duration* 30)

(defmethod update ((obj terminal) delta)
  ;; Get keyboard input
  (let ((events (copy-events)))
    (dolist (event events)
      (typecase event
        (char-type-event
         (let ((char (codepoint event))
               (ib (input-buffer obj))
               (cursor (cursor-state obj)))
           (insert-into-buffer ib char)
           (put-character obj char)
           (when (< (write-index ib) (length (internal-array ib)))
             (let ((row (row cursor))
                   (col (col cursor)))
               (loop :for char :across (subseq (internal-array ib) (write-index ib))
                     :do (put-character obj char))
               (move-cursor-absolute obj row col)))))
        (key-press-event
         (when (press-p event)
           (case (key-symbol event)
             (:enter
              (setf (write-index (input-buffer obj))
                    (length (internal-array (input-buffer obj))))
              (write-char #\Newline obj)
              (insert-into-buffer (input-buffer obj) #\Newline)
              (finish-buffer (input-buffer obj)))
             (:backspace
              (unless (zerop (write-index (input-buffer obj)))
                (move-cursor-relative obj 0 -1)
                (put-character obj #\Space)
                (move-cursor-relative obj 0 -1)
                (rubout-from-buffer (input-buffer obj))))
             (:left
              (unless (zerop (write-index (input-buffer obj)))
                (move-cursor-relative obj 0 -1)
                (decf (write-index (input-buffer obj)))))
             (:right
              (unless (>= (write-index (input-buffer obj))
                          (length (internal-array (input-buffer obj))))
                (move-cursor-relative obj 0 1)
                (incf (write-index (input-buffer obj)))))))))))
  ;; Update cursor
  (update-cursor obj))