1
0
Fork 0
tinmop/src/point-tracker.lisp

128 lines
4.3 KiB
Common Lisp
Raw Normal View History

;; tinmop: a multiprotocol client
2023-10-19 17:46:22 +02:00
;; Copyright © cage
2020-05-08 15:45:43 +02:00
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :point-tracker)
(defclass point-tracker ()
((point-position
:initform 0
:initarg :point-position
:accessor point-position)
(point-fg
:initform :white
:initarg :point-fg
:accessor point-fg)
(point-bg
:initform :white
:initarg :point-bg
:accessor point-bg)
(prompt
:initform "> "
:initarg :prompt
:accessor prompt)))
(defmethod initialize-instance :after ((object point-tracker) &key &allow-other-keys)
(with-accessors ((point-position point-position)
(prompt prompt)) object
(setf point-position (length prompt))))
(defgeneric no-prompt-point-pos (object))
(defgeneric move-point-left (object &key offset))
(defgeneric move-point-right (object max &key offset))
(defgeneric move-point (object to max))
(defgeneric move-point-to-end (object text))
(defgeneric move-point-to-start (object))
(defgeneric insert-at-point (object thing text))
(defgeneric delete-at-point (object text &key direction))
(defmethod no-prompt-point-pos ((object point-tracker))
(- (point-position object)
(length (prompt object))))
(defmethod move-point-left ((object point-tracker) &key (offset 1))
(with-accessors ((point-position point-position)
(prompt prompt)) object
(setf point-position
(max (length prompt)
(- point-position offset)))
point-position))
(defmethod move-point-right ((object point-tracker) max &key (offset 1))
(with-accessors ((point-position point-position)
(prompt prompt)) object
(let ((prompt-length (length prompt)))
(setf point-position
(min (+ max prompt-length)
(+ offset point-position))))
point-position))
(defmethod move-point ((object point-tracker) to max)
(with-accessors ((point-position point-position)
(prompt prompt)) object
(let ((prompt-length (length prompt)))
(setf point-position
(clamp (+ to prompt-length)
prompt-length
(+ max prompt-length)))
point-position)))
(defmethod move-point-to-end ((object point-tracker) text)
(let ((length (length text)))
(move-point object length length)))
(defmethod move-point-to-start ((object point-tracker))
(move-point object 0 1))
(defmethod insert-at-point ((object point-tracker) thing text)
(with-accessors ((point-position point-position)) object
(let* ((actual-point-pos (no-prompt-point-pos object))
(res (strcat (subseq text 0 actual-point-pos)
(to-s thing)
(subseq text actual-point-pos))))
(move-point-right object (length res))
res)))
(defmethod insert-at-point ((object point-tracker) thing (text null))
(insert-at-point object nil (to-s thing)))
(defmethod insert-at-point ((object point-tracker) (thing null) text)
(prog1
(to-s text)
(move-point-right object (length text))))
(defmethod delete-at-point ((object point-tracker) text &key (direction :right))
(with-accessors ((point-position point-position)) object
(handler-bind ((conditions:out-of-bounds
(lambda (c)
(declare (ignore c))
(invoke-restart 'misc:return-whole))))
(if (eq direction
:left)
(if (> (no-prompt-point-pos object)
0)
(progn
(move-point-left object)
(to-s (safe-delete@ text (no-prompt-point-pos object))))
(to-s text))
(to-s (safe-delete@ text (no-prompt-point-pos object)))))))