484 lines
21 KiB
Common Lisp
484 lines
21 KiB
Common Lisp
(in-package :de.anvi.croatoan)
|
|
|
|
;; form
|
|
;; curses extension for programming forms
|
|
;; https://invisible-island.net/ncurses/man/form.3x.html
|
|
|
|
(defun remove-nth (n list)
|
|
"Remove element at nth place from the list, decreasing the length of the list.
|
|
|
|
Example: (remove-nth 3 '(a b c d e)) => (A B C E)"
|
|
(declare
|
|
(type (integer 0) n)
|
|
(type list list))
|
|
(assert (>= n 0))
|
|
(assert (> (length list) n))
|
|
(if (or (zerop n) (null list))
|
|
(cdr list)
|
|
(cons (car list) (remove-nth (1- n) (cdr list)))))
|
|
|
|
(defun insert-nth (n element list)
|
|
"Insert element into list at nth place, increasing the length of the list.
|
|
|
|
Example: (insert-nth 3 'x '(a b c d e)) => (A B C X D E)"
|
|
(declare
|
|
(type (integer 0) n)
|
|
(type list list))
|
|
(assert (>= n 0))
|
|
(assert (>= (length list) n))
|
|
(if (or (zerop n) (null list))
|
|
(cons element list)
|
|
(cons (car list) (insert-nth (1- n) element (cdr list)))))
|
|
|
|
(defun replace-nth (n element list)
|
|
"Replaces element of list at nth place, not increasing the length of the list.
|
|
|
|
Example: (replace-nth 3 'x '(a b c d e)) => (A B C X E)"
|
|
(declare
|
|
(type (integer 0) n)
|
|
(type list list))
|
|
(assert (>= n 0))
|
|
(assert (>= (length list) n))
|
|
(if (or (zerop n) (null list))
|
|
(cons element (cdr list))
|
|
(cons (car list) (replace-nth (1- n) element (cdr list)))))
|
|
|
|
(defun find-element (form element-name &key (test #'eql) (key #'name))
|
|
"Return from the given form the element given by its name.
|
|
|
|
The name should be a keyword, symbol or integer, the default test is eql.
|
|
|
|
If the name is a string, equal should be used as the test.
|
|
|
|
Instead of the name, another key can be provided to identify the element."
|
|
(find element-name (elements form) :test test :key key))
|
|
|
|
;; this is the only place we set the background style for the field
|
|
;; TODO: how to access the default fg and bg of a form,
|
|
;; if the field is not part of a form? by having a form slot in the field.
|
|
|
|
(defmethod clear ((field field) &key)
|
|
"Clear the field by overwriting it with the background char.
|
|
|
|
The default background char is #\space."
|
|
(with-accessors ((pos location) (width width) (selected selectedp) (win window) (style style)) field
|
|
(let* ((bg-style (if selected (getf style :selected-background) (getf style :background)))
|
|
(bg-char (if (getf bg-style :simple-char) (getf bg-style :simple-char) #\space)))
|
|
(setf (cursor-position win) pos)
|
|
(add win bg-char :style bg-style :n width)
|
|
(setf (cursor-position win) pos))))
|
|
|
|
(defgeneric update-cursor-position (object)
|
|
(:documentation "Update the cursor position of the element of a form.")
|
|
(:method (object)
|
|
"The default method puts the cursor at the start position of the element."
|
|
(setf (cursor-position (window object)) (location object))
|
|
(refresh (window object))))
|
|
|
|
;; when the form element is an embedded selection menu or checklist
|
|
;; will not work for menu-windows, which arent yet embedded in forms.
|
|
;; we need a separate update-cursor-position for menu-window.
|
|
;; used in menu.lisp/(draw menu)
|
|
|
|
(defmethod update-cursor-position ((object menu))
|
|
"Update the cursor position of a menu after it is drawn.
|
|
|
|
Place the cursor, when it is visible, on the first char of the current item."
|
|
(setf (cursor-position (window object)) (current-item-location object))
|
|
(refresh (window object)))
|
|
|
|
(defmethod update-cursor-position ((object checklist))
|
|
"Update the cursor position of a checklist after it is drawn.
|
|
|
|
Place the cursor between the brackets [_] of the current item."
|
|
(with-accessors ((pos current-item-location) (win window)) object
|
|
(move win
|
|
(car pos)
|
|
(1+ (cadr pos))) ;; put the cursor after the [
|
|
(refresh win)))
|
|
|
|
(defmethod update-cursor-position ((checkbox checkbox))
|
|
"Update the cursor position of a checkbox."
|
|
(with-accessors ((pos location) (win window)) checkbox
|
|
(move win
|
|
(car pos)
|
|
(1+ (cadr pos))) ;; put the cursor after the [
|
|
(refresh win) ))
|
|
|
|
(defmethod update-cursor-position ((field field))
|
|
"Update the cursor position of a field."
|
|
(with-accessors ((pos location) (inptr input-pointer) (dptr display-pointer) (win window)) field
|
|
(move win
|
|
;; TODO: assumes a single-line field.
|
|
(car pos)
|
|
(+ (cadr pos) ; beginning of the field
|
|
(- inptr dptr) )) ; position in the field starting with dptr
|
|
(refresh win)))
|
|
|
|
(defmethod update-cursor-position ((form form))
|
|
"Move the cursor to the correct position in current element of the form."
|
|
(update-cursor-position (current-element form)))
|
|
|
|
(defgeneric draw (object)
|
|
(:documentation "Draw objects (form, field, menu) to their associated window."))
|
|
|
|
(defmethod draw ((label label))
|
|
(with-accessors ((pos location) (win window) (name name) (title title) (width width) (style style) (reference reference)
|
|
(parent-form parent-form)) label
|
|
;; pick the string to write in the following order
|
|
;; title of the label
|
|
;; title of the referenced element
|
|
;; name of the referenced element
|
|
;; name of the label
|
|
(let* ((text (or title
|
|
(title (find-element parent-form reference))
|
|
(name (find-element parent-form reference))
|
|
name))
|
|
(string (when text (format nil "~A" text)))
|
|
(fg-style (getf style :foreground))
|
|
(bg-style (getf style :background))
|
|
(bg-char (if (getf bg-style :simple-char) (getf bg-style :simple-char) #\space)))
|
|
(when string
|
|
;; first draw the background, but only if width > string
|
|
(when width
|
|
(apply #'move win pos)
|
|
(add win bg-char :style bg-style :n width))
|
|
;; then the label over the background
|
|
(apply #'move win pos)
|
|
(add-string win string :style fg-style)))))
|
|
|
|
(defmethod draw ((button button))
|
|
(with-accessors ((pos location) (name name) (title title) (win window) (selected selectedp) (style style)) button
|
|
(apply #'move win pos)
|
|
(let* ((fg-style (if selected (getf style :selected-foreground) (getf style :foreground))))
|
|
(add-string win (format nil "<~A>" (if title title name)) :style fg-style))))
|
|
|
|
(defmethod draw ((checkbox checkbox))
|
|
(with-accessors ((pos location) (name name) (win window) (selected selectedp) (style style)
|
|
(checkedp checkedp)) checkbox
|
|
(apply #'move win pos)
|
|
(let* ((fg-style (if selected (getf style :selected-foreground) (getf style :foreground))))
|
|
(add-string win (format nil "[~A]" (if checkedp "X" "_")) :style fg-style)
|
|
(update-cursor-position checkbox))))
|
|
|
|
(defmethod draw ((field field))
|
|
"Clear and redraw the field and its contents and background."
|
|
(with-accessors ((pos location) (width width) (inbuf buffer) (inptr input-pointer) (dptr display-pointer)
|
|
(selected selectedp) (win window) (title title) (style style)) field
|
|
(let* ((fg-style (if selected (getf style :selected-foreground) (getf style :foreground)))
|
|
(len (length inbuf))
|
|
(val (value field))
|
|
(str (if (< len width)
|
|
;; if the buffer is shorter than the field, just display it.
|
|
val
|
|
;; otherwise display a substring starting with dptr.
|
|
;; display only max width chars starting from dptr
|
|
(subseq val dptr (if (< width (- len dptr))
|
|
;; if the remaining substring is longer than width, display just width chars.
|
|
(+ dptr width)
|
|
;; if the remaining substring is shorter than width, just display it.
|
|
len) ))))
|
|
(clear field)
|
|
(apply #'move win pos)
|
|
(add-string win str :style fg-style)
|
|
(update-cursor-position field))))
|
|
|
|
(defmethod draw ((form form))
|
|
"Draw the form by drawing the elements, then moving the cursor to the current element."
|
|
(with-accessors ((elements elements) (window window)) form
|
|
(loop for element in elements do
|
|
(draw element))
|
|
;; after drawing the elements, reposition the cursor to the current element
|
|
(update-cursor-position form)))
|
|
|
|
(defmethod draw ((form form-window))
|
|
"Draw the form by drawing the elements, then moving the cursor to the current element."
|
|
;; update cursor position only refreshes the window associated with the form, which is the sub-window
|
|
;; in order to see the border, we have to touch and refresh the parent border window.
|
|
;; refreshing the parent window has to be done before refreshing the cursor position in the sub
|
|
;; or the cursor will be moved to 0,0 of the parent window.
|
|
(touch form)
|
|
(refresh form)
|
|
;; draw the form contents, the superclass of form-window is form (and decorated-window).
|
|
(call-next-method))
|
|
|
|
;; previous-element and next-element are the only two elements where the current-element-number is changed.
|
|
;; here also current-element and selected has to be set.
|
|
(defun select-previous-element (form event &rest args)
|
|
"Select the previous element in a form's element list."
|
|
;;(declare (special form))
|
|
(with-accessors ((elements elements) (current-element-number current-element-number) (current-element current-element) (win window)) form
|
|
(setf (selectedp current-element) nil)
|
|
|
|
;; use mod to cycle the element list.
|
|
(setf current-element-number (mod (- current-element-number 1) (length elements)))
|
|
(setf current-element (nth current-element-number elements))
|
|
|
|
;; ignore inactive elements like labels.
|
|
(if (activep current-element)
|
|
(progn
|
|
(setf (selectedp current-element) t)
|
|
;; after we switched the element number, we also have to redraw the form.
|
|
(draw form))
|
|
(select-previous-element form event))))
|
|
|
|
(defun select-next-element (form event &rest args)
|
|
"Select the next element in a form's element list."
|
|
;;(declare (special form))
|
|
(with-accessors ((elements elements) (current-element-number current-element-number) (current-element current-element) (win window)) form
|
|
(setf (selectedp current-element) nil)
|
|
|
|
;; use mod to cycle the element list.
|
|
(setf current-element-number (mod (+ current-element-number 1) (length elements)))
|
|
(setf current-element (nth current-element-number elements))
|
|
|
|
;; ignore inactive elements like labels.
|
|
(if (activep current-element)
|
|
(progn
|
|
(setf (selectedp current-element) t)
|
|
;; after we switched the element number, we also have to redraw the form.
|
|
(draw form))
|
|
(select-next-element form event))))
|
|
|
|
(defun move-previous-char (field event &rest args)
|
|
"Move the cursor to the previous char in the field."
|
|
(with-accessors ((inptr input-pointer) (dptr display-pointer) (win window)) field
|
|
(when (> inptr 0)
|
|
(decf inptr))
|
|
;; when the inptr moves left past the dptr, simultaneously decf the dptr.
|
|
(when (< inptr dptr)
|
|
(decf dptr))
|
|
(draw field)))
|
|
|
|
(defun move-next-char (field event &rest args)
|
|
"Move the cursor to the next char in the field."
|
|
(with-accessors ((width width) (inbuf buffer) (inptr input-pointer) (dptr display-pointer) (mlen max-buffer-length)
|
|
(win window)) field
|
|
(when (and (< inptr (length inbuf))
|
|
(not (= (1+ inptr) mlen width)))
|
|
(incf inptr))
|
|
;; when the inptr moves right past the width, simultaneously incf the dptr.
|
|
(when (and (>= inptr (+ dptr width))
|
|
(not (= inptr mlen width)))
|
|
(incf dptr))
|
|
(draw field)))
|
|
|
|
(defun delete-previous-char (field event &rest args)
|
|
"Delete the previous char in the field, moving the cursor to the left."
|
|
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) field
|
|
(when (> inptr 0)
|
|
(decf inptr)
|
|
(when (> dptr 0)
|
|
(decf dptr))
|
|
(setf inbuf (remove-nth (- (length inbuf) 1 inptr) inbuf)))
|
|
;; we dont have to redraw the complete form, just the changed field.
|
|
(draw field)))
|
|
|
|
(defun delete-next-char (field event &rest args)
|
|
"Delete the next char (char under the cursor) in the field, not moving the cursor."
|
|
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) field
|
|
;; we can only delete to the right if the inptr is not at the end of the inbuf.
|
|
(when (> (length inbuf) inptr)
|
|
(when (> dptr 0)
|
|
;; when a part of the string is hidden on the left side, shift it to the right.
|
|
(decf dptr))
|
|
(setf inbuf (remove-nth (- (length inbuf) (1+ inptr)) inbuf)))
|
|
(draw field)))
|
|
|
|
(defun field-add-char (field char &rest args)
|
|
"Add char to the current cursor position in the field.
|
|
|
|
The buffer can be longer than the displayed field width, horizontal scrolling is enabled."
|
|
(if (and (characterp char) (graphic-char-p char))
|
|
(progn
|
|
(with-accessors ((width width) (inbuf buffer) (mlen max-buffer-length) (inptr input-pointer)
|
|
(dptr display-pointer) (win window)) field
|
|
(let ((len (length inbuf)))
|
|
(if (insert-mode-p win)
|
|
|
|
;; insert mode
|
|
(progn
|
|
;; only add new chars until we've reached the max-buffer-length
|
|
(unless (>= len mlen)
|
|
;; if we're at the end of the inbuf
|
|
(if (= inptr len)
|
|
;; just add another char to the inbuf
|
|
(setf inbuf (cons char inbuf))
|
|
;; if we're in the middle of the buffer, either insert or replace
|
|
(setf inbuf (insert-nth (- len inptr) char inbuf)) )
|
|
;; we need special cases when mlen is exactly equal to width.
|
|
(if (= mlen width)
|
|
;; advance the cursor if it is not already at the end
|
|
;; if scrolling is disabled, do not move past the last char in the field.
|
|
(unless (>= inptr (- mlen 1))
|
|
(incf inptr))
|
|
(unless (> inptr (- mlen 1))
|
|
(incf inptr))))
|
|
;; after updating the fill-pointer, update the display-pointer
|
|
(if (< inptr dptr) (decf dptr))
|
|
(if (> inptr (+ dptr (1- width))) (incf dptr)))
|
|
;; default overwrite mode
|
|
(progn
|
|
;; only add new chars until we've reached the max-buffer-length then only overwrite.
|
|
(if (>= len mlen)
|
|
(if (< inptr mlen)
|
|
;; even when the inbuf is full, when inptr is not at the end, overwrite.
|
|
(setf inbuf (replace-nth (- len (1+ inptr)) char inbuf))
|
|
nil)
|
|
;; if we're at the end of the inbuf
|
|
(if (= inptr len)
|
|
;; just add another char to the inbuf
|
|
(setf inbuf (cons char inbuf))
|
|
;; if we're in the middle of the buffer, either insert or replace
|
|
(setf inbuf (replace-nth (- len (1+ inptr)) char inbuf))))
|
|
;; we need special cases when mlen is exactly equal to width.
|
|
(if (= mlen width)
|
|
;; advance the cursor if it is not already at the end
|
|
;; if scrolling is disabled, do not move past the last char in the field.
|
|
(unless (>= inptr (- mlen 1))
|
|
(incf inptr))
|
|
(unless (> inptr (- mlen 1))
|
|
(incf inptr)))
|
|
;; after updating the fill-pointer, update the display-pointer
|
|
(when (< inptr dptr) (decf dptr))
|
|
(if (<= mlen width)
|
|
;; if scrolling is disabled, do not move past the last char in the field.
|
|
(when (> inptr (+ dptr width))
|
|
(incf dptr))
|
|
(when (> inptr (+ dptr (1- width)))
|
|
(incf dptr))) ))))
|
|
(draw field))
|
|
;; if the char isnt graphic, do nothing.
|
|
;; TODO: this doesnt work with acs chars, which are keywords.
|
|
nil))
|
|
|
|
(defun debug-print-field-buffer (object event &rest args)
|
|
(declare (ignore event))
|
|
(typecase object
|
|
(field
|
|
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) object
|
|
(when (> (length inbuf) 0)
|
|
(clear win)
|
|
(format win "~A ~%" (value object))
|
|
(setf inbuf nil inptr 0 dptr 0))))
|
|
;; when we want to debug the whole form.
|
|
(form
|
|
(debug-print-field-buffer (current-element object) event)))
|
|
(draw object))
|
|
|
|
(defun cancel (object event &rest args)
|
|
"Associate this function with an event (key binding or button) to exit the event loop of a form or form element.
|
|
|
|
The first return value is nil, emphasizing that the user has canceled the form.
|
|
|
|
The second value is a list containing the object, the event that called the exit and the args passed.
|
|
|
|
This allows to specify why the form was canceled."
|
|
;; TODO: should this be done by the routine or explicitely by the user?
|
|
(when (eq (type-of object) 'form)
|
|
(reset-form object event))
|
|
(throw (if (eq (type-of object) 'form)
|
|
object
|
|
(if (parent-form object)
|
|
(parent-form object)
|
|
object))
|
|
(values nil (list object event args))))
|
|
|
|
(defun accept (object event &rest args)
|
|
"Associate this function with an event (key binding or button) to exit the event loop of a form or form element.
|
|
|
|
The first return value is t, emphasizing that the user has accepted the form.
|
|
|
|
The second value is a list containing the object, the event that called the exit and the args passed.
|
|
|
|
This allows to specify by which button or event the form was accepted."
|
|
;; if the object has a parent-form, do not throw the object, throw its parent form, otherwise throw the object.
|
|
(throw (if (eq (type-of object) 'form)
|
|
object
|
|
(if (parent-form object)
|
|
(parent-form object)
|
|
object))
|
|
(values t (list object event args))))
|
|
|
|
(defun reset-field (field event &rest args)
|
|
"Clear the field and reset its internal buffers and pointers."
|
|
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) field
|
|
(clear field)
|
|
(setf inbuf nil inptr 0 dptr 0)))
|
|
|
|
(defun reset-form (object event &rest args)
|
|
(declare (ignore event))
|
|
(let ((form (typecase object
|
|
(form object)
|
|
(t (parent-form object)))))
|
|
(loop for element in (elements form)
|
|
do (when (and (typep element 'field) (activep element))
|
|
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) element
|
|
(setf inbuf nil
|
|
inptr 0
|
|
dptr 0))))
|
|
(draw form)))
|
|
|
|
(define-keymap 'form-map
|
|
(list
|
|
;; C-a = ^A = #\soh = 1 = start of heading
|
|
;; exit the edit loop, return t
|
|
#\soh 'accept
|
|
;; C-x = cancel = CAN = #\can
|
|
;; exit the edit loop, return nil
|
|
#\can 'cancel
|
|
;; C-r = reset = DC2 = #\dc2
|
|
;; reset editable elements of the form (fields, checkboxes)
|
|
#\dc2 'reset-form
|
|
|
|
:btab 'select-previous-element
|
|
#\tab 'select-next-element))
|
|
|
|
(define-keymap 'field-map
|
|
(list
|
|
;; C-a = ^A = #\soh = 1 = start of heading
|
|
;; exit the edit loop, return t
|
|
#\soh 'accept
|
|
;; C-x = cancel = CAN = #\can
|
|
;; exit the edit loop, return nil
|
|
#\can 'cancel
|
|
;; C-r = reset = DC2 = #\dc2
|
|
;; reset the field
|
|
#\dc2 'reset-field
|
|
|
|
:left 'move-previous-char
|
|
:right 'move-next-char
|
|
:backspace 'delete-previous-char
|
|
:dc 'delete-next-char
|
|
:ic (lambda (field event &rest args)
|
|
(setf (insert-mode-p (window field)) (not (insert-mode-p (window field)))))
|
|
t 'field-add-char))
|
|
|
|
(defun call-button-function (button event &rest args)
|
|
(declare (ignore event))
|
|
(when (callback button)
|
|
(funcall (callback button) button event)))
|
|
|
|
(defun toggle-checkbox (checkbox event &rest args)
|
|
(declare (ignore event))
|
|
(setf (checkedp checkbox) (not (checkedp checkbox)))
|
|
(draw checkbox))
|
|
|
|
;; How to automatically bind a hotkey to every button?
|
|
;; that hotkey would have to be added to the form keymap, not to that of a button.
|
|
;; that would be like a global keymap, in contrast to an elements local keymap.
|
|
(define-keymap 'button-map
|
|
(list
|
|
#\space 'call-button-function
|
|
#\newline 'call-button-function))
|
|
|
|
(define-keymap 'checkbox-map
|
|
(list
|
|
#\space 'toggle-checkbox
|
|
#\x 'toggle-checkbox))
|
|
|
|
(defun edit (object &rest args)
|
|
(draw object)
|
|
;; since we have args passed to run-event-loop, all handler functions have to accept
|
|
;; a &rest args argument.
|
|
(apply #'run-event-loop object args))
|