Initial commit 2

LICENSE

@@ -1,6 +1,6 @@
 MIT License
 
-Copyright (c) 2025 duuqnd
+Copyright (c) 2025 John Lorentzson (Duuqnd)
 
 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
 

herecy-term.asd

@@ -0,0 +1,8 @@
+(asdf:defsystem #:herecy-term
+  :description "A terminal emulator built on ettram."
+  :author "John Lorentzson (Duuqnd)"
+  :license "MIT License"
+  :version "0.1.0"
+  :serial t
+  :depends-on (#:ettram #:trivial-gray-streams)
+  :components ((:file "herecy-term")))

herecy-term.lisp

@@ -0,0 +1,288 @@
+(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))