2878 lines
131 KiB
Common Lisp
2878 lines
131 KiB
Common Lisp
(in-package :de.anvi.croatoan.test)
|
|
|
|
(defun snake ()
|
|
(labels ((display-snake (scr body)
|
|
(mapc #'(lambda (pair) (add-char scr (char-code #\*) :y (car pair) :x (cadr pair))) body)))
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil)
|
|
(let* ((body '((0 7) (0 6) (0 5) (0 4) (0 3) (0 2) (0 1) (0 0)))
|
|
(xpos (cadar body))
|
|
(ypos (caar body))
|
|
(dir #c(1 0)))
|
|
|
|
(clear scr)
|
|
(display-snake scr body)
|
|
(refresh scr)
|
|
|
|
(loop
|
|
(let ((event (get-event scr)))
|
|
(if event
|
|
(case event
|
|
(:up (setf dir #c( 0 1)))
|
|
(:down (setf dir #c( 0 -1)))
|
|
(:right (setf dir #c( 1 0)))
|
|
(:left (setf dir #c(-1 0)))
|
|
(#\q (return)))
|
|
(progn
|
|
(sleep 0.1)
|
|
(add-char scr (char-code #\space) :y (caar (last body)) :x (cadar (last body)))
|
|
(setf body (cons (list (incf ypos (- (imagpart dir)))
|
|
(incf xpos (realpart dir)))
|
|
(butlast body)))
|
|
(display-snake scr body)
|
|
(refresh scr)))))))))
|
|
|
|
(defun snake2 ()
|
|
"Use bind and run-event-loop for event handling. Use lists instead of complex numbers for directions."
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil)
|
|
(let* ((body '((0 7) (0 6) (0 5) (0 4) (0 3) (0 2) (0 1) (0 0)))
|
|
(head (car body))
|
|
(tail (car (last body)))
|
|
;; initial direction = right
|
|
(dir '(0 1)))
|
|
(flet ((draw-snake (win body)
|
|
(mapc (lambda (pos) (add win #\* :position pos)) body)))
|
|
(bind scr #\q 'exit-event-loop)
|
|
(bind scr :right (lambda (w e) (setq dir '( 0 1))))
|
|
(bind scr :left (lambda (w e) (setq dir '( 0 -1))))
|
|
(bind scr :down (lambda (w e) (setq dir '( 1 0))))
|
|
(bind scr :up (lambda (w e) (setq dir '(-1 0))))
|
|
(bind scr nil (lambda (w e)
|
|
;; snake moves = erase last body pair by overwriting it with space
|
|
(add scr #\space :position tail)
|
|
(setq body (cons (mapcar #'+ head dir) (butlast body)))
|
|
(setq head (car body))
|
|
(setq tail (car (last body)))
|
|
(draw-snake scr body)
|
|
(refresh scr)))
|
|
(clear scr)
|
|
(setf (frame-rate scr) 20)
|
|
(run-event-loop scr)))))
|
|
|
|
;; https://github.com/skydrome/random/blob/master/shell/screensaver.sh
|
|
;; https://github.com/pipeseroni/pipes.sh/blob/master/pipes.sh
|
|
;; https://www.youtube.com/watch?v=T4n87IIa--U
|
|
(defun pipes ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil)
|
|
(let* ((pos (list (round (/ (height scr) 2)) (round (/ (width scr) 2))))
|
|
(dirs '((1 0) (-1 0) (0 -1) (0 1)))
|
|
(dir (nth (random 4) dirs))
|
|
(dir-prev dir)
|
|
ch
|
|
(i 0))
|
|
(clear scr)
|
|
(box scr)
|
|
(refresh scr)
|
|
(event-case (scr event)
|
|
(#\q (return-from event-case))
|
|
((nil)
|
|
(sleep 0.1)
|
|
(move scr (car pos) (cadr pos))
|
|
(setf ch (cond ((equal dir dir-prev) (if (= (car dir) 0) :horizontal-line :vertical-line))
|
|
((and (equal dir-prev '(1 0)) (equal dir '(0 -1))) :lower-right-corner)
|
|
((and (equal dir-prev '(1 0)) (equal dir '(0 1))) :lower-left-corner)
|
|
((and (equal dir-prev '(0 1)) (equal dir '(-1 0))) :lower-right-corner)
|
|
((and (equal dir-prev '(0 1)) (equal dir '(1 0))) :upper-right-corner)
|
|
((and (equal dir-prev '(-1 0)) (equal dir '(0 -1))) :upper-right-corner)
|
|
((and (equal dir-prev '(-1 0)) (equal dir '(0 1))) :upper-left-corner)
|
|
((and (equal dir-prev '(0 -1)) (equal dir '(-1 0))) :lower-left-corner)
|
|
((and (equal dir-prev '(0 -1)) (equal dir '(1 0))) :upper-left-corner)))
|
|
(add-char scr ch)
|
|
(let ((pos-trial (list (+ (car pos) (car dir)) (+ (cadr pos) (cadr dir)))))
|
|
(if (or (= (car pos-trial) 0)
|
|
(= (cadr pos-trial) 0)
|
|
(= (car pos-trial) (1- (height scr)))
|
|
(= (cadr pos-trial) (1- (width scr))))
|
|
(setf pos (list (round (/ (height scr) 2)) (round (/ (width scr) 2))))
|
|
(setf pos pos-trial)))
|
|
(if (> i (random 5))
|
|
(progn (setf i 0)
|
|
(setf dir-prev dir)
|
|
(setf dir (nth (random 3) (remove (list (- (car dir)) (- (cadr dir))) dirs :test #'equal))))
|
|
(progn (incf i)
|
|
(setf dir-prev dir)))
|
|
(refresh scr))))))
|
|
|
|
(defun matrix ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :cursor-visible nil)
|
|
(let* ((width (width scr))
|
|
(height (height scr))
|
|
(positions (loop repeat width collect (random height)))
|
|
(speeds (loop repeat width collect (random 4))))
|
|
(event-case (scr event)
|
|
(#\q (return-from event-case))
|
|
((nil)
|
|
(sleep 0.05)
|
|
(loop for column from 0 to (1- width) do
|
|
(loop repeat (nth column speeds) do
|
|
(setf (attributes scr) '(:bold))
|
|
(setf (color-pair scr) '(:white :black))
|
|
(add-char scr (+ 64 (random 58)) :y (mod (nth column positions) height) :x column)
|
|
(setf (color-pair scr) '(:green :black))
|
|
(add-char scr (+ 64 (random 58)) :y (mod (- (nth column positions) 1) height) :x column)
|
|
(add-char scr (+ 64 (random 58)) :y (mod (- (nth column positions) 2) height) :x column)
|
|
(setf (attributes scr) '())
|
|
(add-char scr (+ 64 (random 58)) :y (mod (- (nth column positions) 3) height) :x column)
|
|
(add-char scr (char-code #\space) :y (mod (- (nth column positions) (floor height 2)) height) :x column)
|
|
(refresh scr)
|
|
(setf (nth column positions) (mod (1+ (nth column positions)) height)))))))))
|
|
|
|
(defun matrix2 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :cursor-visible nil)
|
|
(let* ((width (width scr))
|
|
(height (height scr))
|
|
;; start at a random height in each column.
|
|
(positions (loop repeat width collect (random height)))
|
|
;; run each column at a random speed.
|
|
(speeds (loop repeat width collect (random 4))))
|
|
(flet ((randch () (+ 64 (random 58))))
|
|
;; hit the q key to exit the main loop.
|
|
(bind scr #\q 'exit-event-loop)
|
|
(bind scr nil
|
|
(lambda (win event)
|
|
;; generate a random ascii char
|
|
(loop for column from 0 to (1- width) do
|
|
(loop repeat (nth column speeds) do
|
|
;; position of the first point in the current column
|
|
(let ((pos (nth column positions)))
|
|
(setf (attributes win) '(:bold))
|
|
(setf (color-pair win) '(:white :black))
|
|
(add win (randch) :y (mod pos height) :x column)
|
|
(setf (color-pair win) '(:green :black))
|
|
(add win (randch) :y (mod (- pos 1) height) :x column)
|
|
(add win (randch) :y (mod (- pos 2) height) :x column)
|
|
(setf (attributes win) '())
|
|
(add win (randch) :y (mod (- pos 3) height) :x column)
|
|
;; overwrite the last char with a space
|
|
(add win #\space :y (mod (- pos (floor height 3)) height) :x column)
|
|
(refresh win)
|
|
;; increment the column positions
|
|
(setf (nth column positions) (mod (1+ pos) height)))))))))
|
|
;; after the handlers have been defined, run the main event loop at 20 fps.
|
|
(setf (frame-rate scr) 20)
|
|
(run-event-loop scr)))
|
|
|
|
(defun matrix3 ()
|
|
"Test character styles and color pair completion."
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :cursor-visible nil)
|
|
(let* ((width (width scr))
|
|
(height (height scr))
|
|
(positions (loop repeat width collect (random height)))
|
|
(speeds (loop repeat width collect (random 4)))
|
|
(s1 (list :attributes '(:bold) :fgcolor :white))
|
|
(s2 (list :attributes '(:bold) :fgcolor :green :bgcolor nil))
|
|
(s3 (list :attributes nil :fgcolor :green :bgcolor :black)))
|
|
(flet ((randch () (+ 64 (random 58))))
|
|
(bind scr #\q 'exit-event-loop)
|
|
(bind scr #\r
|
|
(lambda (win event)
|
|
(setf (getf s2 :fgcolor) :red
|
|
(getf s3 :fgcolor) :red)))
|
|
(bind scr nil
|
|
(lambda (win event)
|
|
(loop for column from 0 to (1- width) do
|
|
(loop repeat (nth column speeds) do
|
|
(let ((pos (nth column positions)))
|
|
(add win (randch) :y (mod pos height) :x column :style s1)
|
|
(add win (randch) :y (mod (- pos 1) height) :x column :style s2)
|
|
(add win (randch) :y (mod (- pos 2) height) :x column :style s2)
|
|
(add win (randch) :y (mod (- pos 3) height) :x column :style s3)
|
|
(add win #\space :y (mod (- pos (floor height 3)) height) :x column :style s3)
|
|
(refresh win)
|
|
(setf (nth column positions) (mod (1+ pos) height)))))))))
|
|
(setf (frame-rate scr) 20)
|
|
(run-event-loop scr)))
|
|
|
|
(defun matrix4 ()
|
|
"Test passing colors with fgcolor without passing them as pairs."
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :cursor-visible nil)
|
|
(let* ((width (width scr))
|
|
(height (height scr))
|
|
(positions (loop repeat width collect (random height)))
|
|
(speeds (loop repeat width collect (random 4))))
|
|
(flet ((randch () (+ 64 (random 58))))
|
|
(bind scr #\q 'exit-event-loop)
|
|
(bind scr nil
|
|
(lambda (win event)
|
|
(loop for column from 0 to (1- width) do
|
|
(loop repeat (nth column speeds) do
|
|
(let ((pos (nth column positions)))
|
|
(setf (attributes win) '(:bold))
|
|
(setf (fgcolor win) :green)
|
|
(add win (randch) :y (mod pos height) :fgcolor :white :x column)
|
|
(add win (randch) :y (mod (- pos 1) height) :x column)
|
|
(add win (randch) :y (mod (- pos 2) height) :x column)
|
|
(setf (attributes win) '())
|
|
(add win (randch) :y (mod (- pos 3) height) :x column)
|
|
(add win #\space :y (mod (- pos (floor height 3)) height) :x column)
|
|
(refresh win)
|
|
(setf (nth column positions) (mod (1+ pos) height)))))))))
|
|
(setf (frame-rate scr) 20)
|
|
(run-event-loop scr)))
|
|
|
|
;; initialize ncurses, deinitialize ncurses
|
|
;; tests initialize-instance
|
|
(defun t00 ()
|
|
(let ((scr (make-instance 'screen)))
|
|
(unwind-protect
|
|
nil
|
|
(close scr))))
|
|
|
|
;; clos screen, accessors, unwind-protect.
|
|
(defun t01 ()
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen :enable-colors t)))
|
|
|
|
(clear scr)
|
|
(move scr 0 0)
|
|
(add-string scr "hello there!")
|
|
|
|
;; the text will be red on yellow.
|
|
;; this affects only new characters, not the whole window.
|
|
(setf (color-pair scr) '(:red :yellow))
|
|
|
|
(move scr 5 5)
|
|
(add-string scr "dear john!")
|
|
(refresh scr)
|
|
|
|
;; wait for keypress, works only in blocking mode, which is the default.
|
|
(get-char scr)
|
|
|
|
;; set the background character for new characters
|
|
;; the optional argument nil prevents it from being applied to every window cell.
|
|
;; a newline sets the background till the end of the line.
|
|
(setf (background scr nil) (make-instance 'complex-char :simple-char #\- :color-pair '(:white :green)))
|
|
(format scr "~%Hello again!~%")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
;; finally, set the background for the whole window.
|
|
;; the change is applied only to empty cells and to
|
|
;; characters that have no already set attributes or colors.
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\. :color-pair '(:green :white)))
|
|
(refresh scr)
|
|
(get-char scr)
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\- :color-pair '(:red :white)))
|
|
(refresh scr)
|
|
|
|
;; wait for the next keypress, then end.
|
|
(get-char scr))
|
|
|
|
;; unwind protect makes sure that ncurses is ended at all cost.
|
|
(end-screen)))
|
|
|
|
;; the same as t01, but hides the window creation and ncurses ending by utilizing the with-screen macro.
|
|
(defun t02 ()
|
|
(with-screen (scr :color-pair (list :yellow :red))
|
|
(clear scr)
|
|
(move scr 0 0)
|
|
(add-string scr "hello there!")
|
|
(move scr 3 6)
|
|
(add-string scr "dear john!")
|
|
(setf (color-pair scr) '(:red :yellow))
|
|
(move scr 3 3 :relative t)
|
|
(add-string scr "call me maybe!")
|
|
;; setting the cursor position directly instead of using move
|
|
(setf (cursor-position scr) (list 9 12))
|
|
(add-string scr "welcome to tijuana")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\. :color-pair '(:green :white)))
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\, :color-pair '(:white :green)))
|
|
(refresh scr)
|
|
(get-char scr) ))
|
|
|
|
(defun t02a ()
|
|
"Separately set the window foreground and background color pairs."
|
|
(with-screen (scr :fgcolor :yellow :bgcolor :red)
|
|
(clear scr)
|
|
(move scr 0 0)
|
|
(add-string scr "hello there!")
|
|
|
|
(setf (color-pair scr) '(:red :yellow))
|
|
(move scr 3 6)
|
|
(add-string scr "dear john!")
|
|
|
|
(setf (fgcolor scr) :yellow
|
|
(bgcolor scr) :red)
|
|
(move scr 3 3 :relative t)
|
|
(add-string scr "call me maybe!")
|
|
|
|
;; setting the cursor position directly instead of using move
|
|
(setf (cursor-position scr) (list 9 12))
|
|
(add-string scr "welcome to tijuana")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
;; setting fg to green, will set the bg to the default black
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\. :fgcolor :green))
|
|
(refresh scr)
|
|
(get-char scr)
|
|
;; setting bg to green will set the fg to the default white
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\, :bgcolor :green))
|
|
|
|
;; text will still use the window color pair
|
|
(move scr 3 3 :relative t)
|
|
(add scr "hasta siempre")
|
|
|
|
(refresh scr)
|
|
(get-char scr) ))
|
|
|
|
(defun t02b ()
|
|
"Set and get a wide character background."
|
|
(with-screen (scr)
|
|
;;(de.anvi.croatoan::funcall-make-cchar_t-ptr #'%wbkgrnd (winptr scr) 0 0 0 1)
|
|
|
|
;; if we set char 0 as background, ncurses sets char 32 (space), which is obviously the default char.
|
|
;; also setting 0 leads to the color pair not being accepted.
|
|
;; TODO: check that only graphic chars are set.
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #x2592 :color-pair '(:yellow :red)))
|
|
(get-char scr)
|
|
|
|
(move scr 0 0)
|
|
;; the low-level function returns the code.
|
|
(let ((ch (de.anvi.croatoan::get-background-cchar_t scr)))
|
|
(format scr "ch: ~A~%" ch)
|
|
(format scr "~A ~A ~A" (char-code (simple-char ch)) (attributes ch) (color-pair ch)))
|
|
|
|
(move scr 2 0)
|
|
;; the high level interface returns what was set by the high-level setf.
|
|
;; TODO: when we set background to :board, should it return :board or the numeric code point?
|
|
(let ((ch (background scr)))
|
|
(if ch
|
|
(format scr "~A ~A ~A" (simple-char ch) (attributes ch) (color-pair ch))
|
|
(format scr "ch: ~A" ch)))
|
|
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
(defun t02c ()
|
|
(with-screen (scr :input-blocking t :input-echoing nil :enable-colors t :use-terminal-colors t)
|
|
;; simple chars added to a window without a rendered style.
|
|
(add-string scr "Hello there!")
|
|
(fresh-line scr) (refresh scr) (get-char scr)
|
|
|
|
;; color-pair applies to newly added text.
|
|
(setf (color-pair scr) '(:red :yellow))
|
|
(add-string scr "Dear John!")
|
|
(fresh-line scr) (refresh scr) (get-char scr)
|
|
|
|
;; removing the color pair puts back the outut into the default state.
|
|
(setf (color-pair scr) '())
|
|
(add-string scr "Open the pod bay door.")
|
|
(fresh-line scr) (refresh scr) (get-char scr)
|
|
|
|
;; the background style renders simple text, but it doesnt change the text with a set color pair
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\. :fgcolor :black :bgcolor :magenta))
|
|
(add-string scr "I can feel it.")
|
|
(fresh-line scr) (refresh scr) (get-char scr)
|
|
|
|
;; remove the background char, set back to the default state.
|
|
(setf (background scr) nil)
|
|
(add-string scr "My mind is going.")
|
|
(fresh-line scr) (refresh scr) (get-char scr)
|
|
|
|
;; the empty cells of the last foreground will be overwritten by the next background call.
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\_ :color-pair '(:black :yellow)))
|
|
(format scr "I'm sorry, Dave.")
|
|
(fresh-line scr) (refresh scr) (get-char scr)))
|
|
|
|
;; read and display chars until a q is pressed, blocking version.
|
|
(defun t03 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t)
|
|
(clear scr)
|
|
(add-string scr "Type chars. Type q to quit. ")
|
|
(refresh scr)
|
|
|
|
(loop for ch = (get-char scr)
|
|
while (not (equal (code-char ch) #\q))
|
|
do (add-char scr ch))
|
|
|
|
(add-string scr "You pressed q. Now press any char to quit.")
|
|
(get-char scr)))
|
|
|
|
;; read and display chars until a q is pressed, non-blocking version (leads to 100% CPU usage).
|
|
;; wait for keyboard using get-char makes no sense in non-blocking code because it doesnt wait.
|
|
(defun t03a ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil)
|
|
(clear scr)
|
|
(add-string scr "Type chars. Type q to quit. ")
|
|
(refresh scr)
|
|
|
|
(loop for ch = (get-char scr)
|
|
while (or (= ch -1) (not (equal (code-char ch) #\q)))
|
|
do (unless (= ch -1) (add-char scr ch)))))
|
|
|
|
;; test which integer is returned by ncurses on a non-blocking nil event.
|
|
;; when get-char is used, -1 is returned,
|
|
;; when get-wide-char is used, 0 is returned.
|
|
(defun t03a2 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil)
|
|
(clear scr)
|
|
(add-string scr "Type chars. Type q to quit. ")
|
|
(refresh scr)
|
|
(loop for ch = (get-char scr)
|
|
while (not (equal ch 113)) ; 113 = q
|
|
do (princ ch scr))))
|
|
|
|
;; read and display chars until a q is pressed, non-blocking version (leads to 100% CPU usage).
|
|
;; uses get-event for event handling.
|
|
(defun t03b ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil)
|
|
(clear scr)
|
|
(add-string scr "Type chars. Type q to quit. ")
|
|
(refresh scr)
|
|
|
|
;; TODO: should get-event only return single bytes, or should we merge it with get-wide-event?
|
|
(loop (let ((event (get-event scr)))
|
|
(when event
|
|
(case event
|
|
(#\q (return))
|
|
(otherwise (add-char scr (char-code event)))))))))
|
|
|
|
;; using the event-case macro to simplify the event loop.
|
|
;; do not use ((nil) nil) with input-blocking nil, it leads to 100% CPU usage.
|
|
;; if nothing happens in the nil case anyway, we can use blocking.
|
|
(defun t03b2 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t)
|
|
(clear scr)
|
|
(add-string scr "Type chars. Type q to quit. ")
|
|
(refresh scr)
|
|
(event-case (scr event)
|
|
;; ((nil) nil)
|
|
(#\q (return-from event-case))
|
|
(otherwise (add-char scr (char-code event))))))
|
|
|
|
;; slightly improved t03b2 pasted as an example to the cliki croatoan page
|
|
(defun t03b3 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-colors t)
|
|
(clear scr)
|
|
(move scr 2 0)
|
|
(format scr "Type chars. Type q to quit.~%~%")
|
|
(refresh scr)
|
|
(setf (color-pair scr) '(:yellow :red)
|
|
(attributes scr) '(:bold))
|
|
(event-case (scr event)
|
|
(#\q (return-from event-case))
|
|
(otherwise (princ event scr)
|
|
(refresh scr)))))
|
|
|
|
;; read and display chars until a q is pressed, blocking + gray stream version.
|
|
;; the stream reading function wont work in non-blocking mode and with non-char keys.
|
|
(defun t03c ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t)
|
|
(clear scr)
|
|
(princ "Type chars. Type q to quit." scr)
|
|
(refresh scr)
|
|
|
|
(loop for ch = (read-char scr)
|
|
while (not (equal ch #\q))
|
|
do (princ ch scr))
|
|
|
|
(princ "You pressed q. Now press any char to quit." scr)
|
|
(read-char scr)))
|
|
|
|
(defun t03d ()
|
|
"Read and display wide (multi-byte) characters until q is pressed."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-colors t :cursor-visible nil)
|
|
(clear scr)
|
|
(refresh scr)
|
|
(loop for ch = (get-wide-char scr)
|
|
while (not (equal (code-char ch) #\q))
|
|
do
|
|
(clear scr)
|
|
;; display the human-readable version of a wide char.
|
|
(add-wide-char scr ch :attributes (list :underline) :fgcolor :yellow :bgcolor :red :y 0 :x 0)
|
|
(add-wide-char scr (code-char ch) :attributes (list :bold) :color-pair (list :yellow :red) :y 0 :x 2)
|
|
;; extract the wide char again.
|
|
(let ((ch2 (extract-wide-char scr :y 0 :x 0)))
|
|
;; display the lisp-readable version of the extracted complex wide char
|
|
(move scr 1 0)
|
|
;; TODO: prin1, print and ~S should print unreadable #<..>
|
|
;; only princ and ~A should render complex chars
|
|
(prin1 (simple-char ch2) scr)
|
|
;; print the slots of the extracted complex wide char
|
|
(princ (attributes ch2) scr)
|
|
(princ (color-pair ch2) scr)
|
|
;; display the rendered complex wide char again
|
|
(add-wide-char scr ch2 :y 3 :x 0) ))))
|
|
|
|
;; gray stream version of t03d
|
|
;; we can not use ~C and write-char to write complex-chars, but it works for wide chars, which are normal lisp chars.
|
|
;; princ and ~A should work, because they rely on specialized print-object.
|
|
;; also see t08c
|
|
(defun t03d2 ()
|
|
"Use gray stream functions to read and display wide (multi-byte) characters until q is pressed."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-colors t :cursor-visible nil)
|
|
(clear scr)
|
|
(refresh scr)
|
|
(loop for ch = (read-char scr)
|
|
while (not (equal ch #\q))
|
|
do
|
|
(clear scr)
|
|
(move scr 0 0)
|
|
;; we only can write-char if it is a lisp character.
|
|
(write-char ch scr)
|
|
;; the extracted "char" is not a lisp character any more, but a complex-char
|
|
(let ((ch2 (extract-wide-char scr :y 0 :x 0))
|
|
(*standard-output* scr))
|
|
;; this soon will not work with sbcl and complex chars.
|
|
;; write-char only takes characters, no other objects.
|
|
;; even if we specialize stream-write-char to complex-chars
|
|
;;(move scr 1 0)
|
|
;;(write-char ch2 scr)
|
|
;; this will work because it uses print-objectm, since print-object can be
|
|
;; specialized on complex-chars.
|
|
(move scr 1 0)
|
|
(princ ch scr)
|
|
(princ ch)
|
|
(move scr 2 0)
|
|
(princ ch2 scr)
|
|
(princ ch2)
|
|
;; aestethic ~A can be used, since it uses princ underneath
|
|
;; standard ~S can not because it cant be read back in
|
|
;; character ~C can not be used because it requires characters.
|
|
(move scr 3 0)
|
|
(format scr "~A ~A" ch ch2)
|
|
(move scr 4 0)
|
|
(format t "~A ~A" ch ch2)
|
|
(refresh scr) ))))
|
|
|
|
;; | cooked | cbreak | raw
|
|
;; ----------+--------+--------+-----
|
|
;; buffering | t | nil | nil
|
|
;; ----------+--------+--------+-----
|
|
;; control | t | t | nil
|
|
;;
|
|
(defun t03e ()
|
|
"Test switching between input modes and control char processing."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :input-buffering nil :process-control-chars nil)
|
|
(with-accessors ((input-buffering input-buffering-p) (process-control-chars process-control-chars-p)) scr
|
|
(clear scr)
|
|
(format scr "buffering ~A process-control-chars ~A (raw)~%" input-buffering process-control-chars)
|
|
(format scr "ch1: ~A~%" (get-char scr))
|
|
(setf (process-control-chars-p scr) t)
|
|
(format scr "buffering ~A process-control-chars ~A (cbreak)~%" input-buffering process-control-chars)
|
|
(format scr "ch2: ~A~%" (get-char scr))
|
|
(setf (input-buffering-p scr) t)
|
|
(format scr "buffering ~A process-control-chars ~A (cooked)~%" input-buffering process-control-chars)
|
|
(format scr "ch3: ~A~%" (get-char scr))
|
|
;; ignore the typed enter key
|
|
(get-char scr)
|
|
;; wait for one keypress before exiting.
|
|
(get-char scr))))
|
|
|
|
;; take a function given as symbol name and display its docstring. press q to exit.
|
|
;; Example: (a:t04 'cdr)
|
|
(defun t04 (&optional (name 'car))
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen)))
|
|
(clear scr)
|
|
(refresh scr)
|
|
|
|
(setf (attributes scr) '(:bold :reverse))
|
|
(add-string scr "Docstring")
|
|
|
|
(setf (attributes scr) '())
|
|
(add-string scr " --> ")
|
|
|
|
(setf (attributes scr) '(:bold :underline))
|
|
(add-string scr (format nil "~A~%~%" name))
|
|
|
|
(setf (attributes scr) '())
|
|
(add-string scr (documentation name 'function))
|
|
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(end-screen)))
|
|
|
|
;; adding and removing attributes.
|
|
(defun t04a ()
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen :enable-colors t)))
|
|
(clear scr)
|
|
(refresh scr)
|
|
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(pushnew :bold (attributes scr))
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(pushnew :underline (attributes scr))
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(pushnew :reverse (attributes scr))
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(setf (attributes scr) (remove :reverse (attributes scr)))
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(setf (attributes scr) (remove :underline (attributes scr)))
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(setf (attributes scr) (remove :bold (attributes scr)))
|
|
(add-string scr (write-to-string (attributes scr)))
|
|
(add-char scr (char-code #\newline))
|
|
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(end-screen)))
|
|
|
|
;; a more concise way to write t04a
|
|
(defun t04b ()
|
|
(with-screen (scr :enable-colors t :cursor-visible nil)
|
|
(clear scr)
|
|
|
|
(print (attributes scr) scr)
|
|
|
|
(add-attributes scr '(:bold))
|
|
(print (attributes scr) scr)
|
|
|
|
(add-attributes scr '(:underline))
|
|
(print (attributes scr) scr)
|
|
|
|
(add-attributes scr '(:reverse))
|
|
(print (attributes scr) scr)
|
|
|
|
(remove-attributes scr '(:bold :underline :reverse))
|
|
(print (attributes scr) scr)
|
|
|
|
(add-attributes scr '(:bold :underline :reverse))
|
|
(print (attributes scr) scr)
|
|
|
|
(setf (attributes scr) nil)
|
|
(print (attributes scr) scr)
|
|
(print "test" scr)
|
|
|
|
(move scr 6 10)
|
|
(change-attributes scr 10 '())
|
|
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; Make sure we shut down ncurses and dont mess up the terminal when an error is signaled.
|
|
(defun t05 ()
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen)))
|
|
(add-string scr "press any char to signal an error and go to the debugger in a messed up screen!")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
(error "zu huelf!"))
|
|
;; this will be executed after we somehow return from the debugger.
|
|
(end-screen)))
|
|
|
|
;; End ncurses cleanly _before_ getting into the debugger when an error is signalled.
|
|
;; do get into the debugger, but only after we are back to the repl.
|
|
(defun t06 ()
|
|
(let ((*debugger-hook* #'(lambda (c h) (declare (ignore c)) (declare (ignore h)) (end-screen))))
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen)))
|
|
(add-string scr "hello there! press a char to signal an error and go to the debugger without messung up the screen!")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
(error "zu huelf!"))
|
|
(end-screen))))
|
|
|
|
;; The debugger hook is added now to with-screen.
|
|
;; When an error is signalled in a ncurses app, we cleanly exit ncurses first, we dont get
|
|
;; into the debugger and we merely print the signalled condition to the REPL.
|
|
(defun t06a ()
|
|
(with-screen (scr)
|
|
(add-string scr "hello there! press a char to signal an error. the app will be ended without going to the debugger.")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
(error "zu huelf!")))
|
|
|
|
;; display a new window on the stadard screen.
|
|
;; problem: deleting different windows is not standardized. (problem solved, example obsolete)
|
|
(defun t07 ()
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen :enable-colors t)))
|
|
(clear scr)
|
|
(add-string scr "Standard screen")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
(let ((win (make-instance 'window :height 15 :width 50 :location '(5 5))))
|
|
(setf (background win) (make-instance 'complex-char :color-pair '(:red :blue)))
|
|
(add-string win "Window 1")
|
|
(refresh win)
|
|
(get-char win)))
|
|
;(delete-window win) ; this is missing, we have to properly delete windows manually.
|
|
|
|
;; this will be executed after we somhow return from the debugger.
|
|
(end-screen)))
|
|
|
|
;; close now closes both windows and the main screen.
|
|
;; but the creation of a window/screen now has to be outside the unwind-protect form.
|
|
(defun t07a ()
|
|
(let ((scr (make-instance 'screen :enable-colors t :cursor-visible nil)))
|
|
;; since windows are streams now, we can use close on tem too.
|
|
;; in order to be able to close scr, as compared to end-screen without arguments in t07,
|
|
;; we have to move unwind-protect inside the let scope.
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
(add-string scr "Standard screen")
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
(let ((win (make-instance 'window :height 15 :width 50 :location '(5 5) :draw-border t)))
|
|
(setf (background win) (make-instance 'complex-char :simple-char #\: :color-pair '(nil :blue)))
|
|
(add-string win "Window 1" :y 2 :x 4 :fgcolor :red :bgcolor :yellow)
|
|
(refresh win)
|
|
(get-char win)
|
|
(close win))
|
|
|
|
(clear scr)
|
|
(refresh scr)
|
|
(get-char scr))
|
|
;; close is defined by the gray stream interface.
|
|
(close scr))))
|
|
|
|
;; test the gray streams interface.
|
|
(defun t08 ()
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen)))
|
|
(clear scr)
|
|
|
|
(write-char #\a) ; writes a to the repl. wont be visible until we quit ncurses.
|
|
|
|
(write-char #\b scr) ; writes b to scr.
|
|
(terpri scr)
|
|
|
|
(princ "hello") ; writes to the repl. wont be visible until we quit ncurses.
|
|
|
|
(princ "hello" scr)
|
|
(terpri scr) ; 3 calls, 3 new lines will be added.
|
|
(terpri scr)
|
|
(terpri scr)
|
|
|
|
(princ "there" scr)
|
|
|
|
(terpri scr)
|
|
(write-string "dear john" scr :start 0 :end 4)
|
|
(terpri scr)
|
|
(write-string "dear john" scr :start 5)
|
|
|
|
(fresh-line scr) ; we call it 3 times, but only one newline will be added.
|
|
(fresh-line scr)
|
|
(fresh-line scr)
|
|
|
|
(format scr "--~%~r~%--" 1234) ; each % will add a newline.
|
|
|
|
(write-char #\newline scr) ; this is the char that actually gets displayed each time terpri is called.
|
|
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(end-screen)))
|
|
|
|
;; when we define windows as streams, we can rebind the *standard-output* to print to a ncurses window.
|
|
;; this only works with standard lisp output functions, format, write-char, terpri, print, etc.
|
|
;; we still have to explicitely ncurses functions clear, close, refresh, etc. though.
|
|
(defun t08a ()
|
|
(let ((scr (make-instance 'screen)))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
|
|
;; writes explicitely to scr
|
|
(write-char #\a scr)
|
|
(terpri scr)
|
|
(princ "hello" scr)
|
|
(terpri scr)
|
|
(format scr "~r" 1234)
|
|
(terpri scr)
|
|
|
|
;; writes to *standard-output*, which here is scr.
|
|
(let ((*standard-output* scr))
|
|
(write-char #\b)
|
|
(terpri)
|
|
(princ "there")
|
|
(terpri)
|
|
(format t "~r" 5678)
|
|
(terpri))
|
|
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(close scr))))
|
|
|
|
(defun t08b ()
|
|
"Use colors on *standard-output* with standard lisp printing functions.
|
|
|
|
Test whether a window (stream) was closed."
|
|
(let* ((scr (make-instance 'screen :enable-colors t))
|
|
(*standard-output* scr))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
(format t "~r" 1984)
|
|
(refresh scr)
|
|
(get-char scr)
|
|
|
|
;; temporarily bind *standard-output* to a window.
|
|
(let* ((win (make-instance 'window :height 15 :width 50 :location '(5 5)))
|
|
(*standard-output* win))
|
|
(setf (background win) (make-instance 'complex-char :color-pair '(:white :black)))
|
|
(format t "~r" 1985)
|
|
(refresh win)
|
|
(get-char win)
|
|
(format t "~%before close: streamp: ~A open-stream-p: ~A" (streamp win) (open-stream-p win))
|
|
(refresh win)
|
|
(get-char win)
|
|
(format scr "~%after close: close: ~A streamp: ~A open-stream-p: ~A" (close win) (streamp win) (open-stream-p win))
|
|
(refresh scr)
|
|
(get-char scr))
|
|
|
|
;; *standard-output*is now again scr.
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
(terpri)
|
|
(format t "~r" 1984)
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(close scr))))
|
|
|
|
;; Write complex chars to standard output using standard lisp output functions + gray streams.
|
|
;; According to SBCL devs, write-char and ~C are not supposed to work, because according to the
|
|
;; standard, only lisp characters should be accepted s arguments by write-char, and any other
|
|
;; object like a complex-char should signal an error.
|
|
(defun t08c ()
|
|
(with-screen (scr)
|
|
(let ((*standard-output* scr)
|
|
(ch (make-instance 'complex-char :simple-char #\a :attributes '(:bold :underline) :color-pair '(:green :black))))
|
|
(write-char #\a)
|
|
(terpri)
|
|
;;(write-char ch)
|
|
(terpri)
|
|
(princ ch)
|
|
(terpri)
|
|
(print ch)
|
|
(terpri)
|
|
(format t "~%Format:~%~S~%~A" ch ch)
|
|
(terpri))
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; box, move
|
|
(defun t09 ()
|
|
(let* ((scr (make-instance 'screen :enable-colors t)))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
(box scr)
|
|
(move scr 1 1)
|
|
(princ 0 scr)
|
|
|
|
(refresh scr)
|
|
|
|
(let ((w1 (make-instance 'window :height 10 :width 30 :location '(3 5)))
|
|
(w2 (make-instance 'window :height 10 :width 30 :location '(6 10)))
|
|
(w3 (make-instance 'window :height 10 :width 30 :location '(9 15))))
|
|
|
|
(setf (background w1) (make-instance 'complex-char :color-pair '(:white :black)))
|
|
(setf (background w2) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
(setf (background w3) (make-instance 'complex-char :color-pair '(:white :black)))
|
|
|
|
(box w1)
|
|
(box w2)
|
|
(box w3)
|
|
|
|
(move w1 1 1)
|
|
(princ 1 w1)
|
|
(move w2 1 1)
|
|
(princ 2 w2)
|
|
(move w3 1 1)
|
|
(princ 3 w3)
|
|
|
|
(refresh w1)
|
|
(refresh w2)
|
|
(refresh w3)
|
|
|
|
(get-char w1)
|
|
|
|
;; todo: before we can refresh w2 to raise it, we have to "touch" it.
|
|
;; if we dont touch it, only the changed parts of it will be redrawn.
|
|
(touch w2)
|
|
(refresh w2)
|
|
|
|
(get-char w1)
|
|
|
|
;; move the whole window 3. note that this doesnt refresh the windows below,
|
|
;; they have to be refreshed separately.
|
|
(setf (location w3) '(9 20))
|
|
(refresh w3)
|
|
(get-char w3)
|
|
|
|
(close w1)
|
|
(close w2)
|
|
(close w3))
|
|
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
|
|
(refresh scr)
|
|
(get-char scr))
|
|
|
|
(close scr))))
|
|
|
|
;; the same as t09, but we can now raise the overlapping windows by hitting 1, 2 or 3.
|
|
(defun t09a ()
|
|
(let* ((scr (make-instance 'screen :enable-colors t :input-blocking t :input-echoing nil ;;:use-terminal-colors t
|
|
:cursor-visible nil)))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
|
|
(box scr)
|
|
(refresh scr)
|
|
|
|
;; the default value for width or height is "to the end of the screen".
|
|
(let ((w1 (make-instance 'window :height 10 :width 30 :location '(3 5)))
|
|
(w2 (make-instance 'window :width 30 :location '(6 10)))
|
|
(w3 (make-instance 'window :height 10 :location '(9 15))))
|
|
|
|
(box w1)
|
|
(box w2)
|
|
(box w3)
|
|
|
|
;; after we define a default pair, :terminal -1 refers to these colors.
|
|
(setf (use-terminal-colors-p scr) t)
|
|
;;(setf (default-color-pair scr) (list :yellow :red))
|
|
|
|
(setf (background w1) (make-instance 'complex-char :color-pair '(:default-fg :yellow)))
|
|
;; window w2 uses the :default fg and bg color of the terminal, because use-terminal-colors is t.
|
|
(setf (background w3) (make-instance 'complex-char :color-pair '(:yellow :terminal)))
|
|
|
|
;; print currently active color pairs to w3
|
|
(format w3 "~A" de.anvi.croatoan::*color-pair-alist*)
|
|
|
|
;; TODO: clear, refresh, etc, should take one or more windows as arguments.
|
|
;; so we can do (refresh w1 w2 w3) instead of:
|
|
(refresh w1)
|
|
(refresh w2)
|
|
(refresh w3)
|
|
|
|
(loop (let ((event (get-event scr)))
|
|
(when event
|
|
(case event
|
|
(#\1 (touch w1) (refresh w1))
|
|
(#\2 (touch w2) (refresh w2))
|
|
(#\3 (touch w3) (refresh w3))
|
|
(#\q (return))
|
|
(otherwise nil)))))
|
|
|
|
(close w1)
|
|
(close w2)
|
|
(close w3)))
|
|
|
|
(close scr))))
|
|
|
|
(defun t09b ()
|
|
"Use with-screen, event-case and mapc to simplify t09a."
|
|
(with-screen (scr :input-blocking t :input-echoing nil :enable-colors t :cursor-visible nil)
|
|
(box scr)
|
|
(refresh scr)
|
|
|
|
(let ((w1 (make-instance 'window :height 10 :width 30 :location '(3 5) :draw-border t))
|
|
(w2 (make-instance 'window :width 30 :location '(6 10) :draw-border t))
|
|
(w3 (make-instance 'window :height 10 :location '(9 15) :draw-border t)))
|
|
|
|
(setf (background w1) (make-instance 'complex-char :simple-char #\space :color-pair '(:white :black))
|
|
(background w3) (make-instance 'complex-char :simple-char #\space :color-pair '(:white :black)))
|
|
|
|
(mapc #'refresh (list w1 w2 w3))
|
|
|
|
(event-case (scr event)
|
|
(#\1 (touch w1) (refresh w1))
|
|
(#\2 (touch w2) (refresh w2))
|
|
(#\3 (touch w3) (refresh w3))
|
|
(#\q (return-from event-case))
|
|
(otherwise nil))
|
|
|
|
(mapc #'close (list w1 w2 w3))
|
|
|
|
;; return nil explicitely, so it doesnt return the window list.
|
|
nil)))
|
|
|
|
;; https://www.gnu.org/software/guile-ncurses/manual/html_node/Panels-Basics.html#Panels-Basics
|
|
;; https://www.gnu.org/software/guile-ncurses/manual/html_node/The-curses-panel-library.html
|
|
(defun t09c ()
|
|
"Use a window stack to manage overlapping windows."
|
|
(with-screen (scr :input-blocking t :input-echoing nil :enable-colors t :enable-function-keys t :cursor-visible nil :stacked t)
|
|
(box scr)
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\space :color-pair '(:black :white)))
|
|
;; we have to stack scr because the event loop runs on scr, and this refreshes scr implicitely every time
|
|
;; and overlaps the other windows
|
|
;;(setf (stackedp scr) t)
|
|
|
|
(let ((winlst nil)
|
|
(n 0))
|
|
;; create 8 windows (with 8 different background colors),
|
|
;; add them to the local winlist and to the global stack
|
|
(loop for i from 0 to 7 do
|
|
(push (make-instance 'window :height 10 :width 30 :location (list (+ 3 (* i 1)) (+ 3 (* i 3))) :draw-border t :stacked t)
|
|
winlst))
|
|
;; number them and set the background colors
|
|
(loop for i from 0 to 7 do
|
|
(setf (attributes (nth i winlst)) (list :reverse))
|
|
(format (nth i winlst) "~A" i)
|
|
(setf (background (nth i winlst))
|
|
(make-instance 'complex-char :simple-char #\space :color-pair (list :black (nth i *ansi-color-list*)))))
|
|
;;(setf (stackedp (nth i winlst)) t)
|
|
(refresh-stack)
|
|
|
|
(event-case (scr event)
|
|
;; type 0-7 to pick a window
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
|
;; show the picked window number in the upper right screen corner
|
|
(add-char scr event :y 1 :x 78 :color-pair (list :white :black))
|
|
(setf n (- (char-code event) 48)))
|
|
;; to raise a window to the top of the stack
|
|
(#\t
|
|
(raise-to-top (nth n winlst))
|
|
(refresh-stack))
|
|
(#\r
|
|
(raise (nth n winlst))
|
|
(refresh-stack))
|
|
(#\l
|
|
(lower (nth n winlst))
|
|
(refresh-stack))
|
|
(#\b
|
|
(lower-to-bottom (nth n winlst))
|
|
(refresh-stack))
|
|
;; type v to toggle window visibility
|
|
(#\v
|
|
;; toggle visibility for window n
|
|
(setf (visiblep (nth n winlst)) (not (visiblep (nth n winlst))))
|
|
(refresh-stack))
|
|
(#\q (return-from event-case))
|
|
(otherwise nil))
|
|
|
|
;; before closing them, remove all windows from the stack, so they can be GCd.
|
|
(empty-stack)
|
|
(mapc #'close winlst)
|
|
;; return nil explicitely, so it doesnt return the window list.
|
|
nil)))
|
|
|
|
;; port of kletva/test05.
|
|
;; print the screen size.
|
|
;; print the keys and key codes of any key pressed.
|
|
;; TODO: when we reach the end of the screen, the ~% doesnt print newlines any more and the screen doesnt scroll.
|
|
;; see scroll.lisp. a lot of window options, including scrolling, arent closified yet.
|
|
;; enable-function-keys t: fkeys have codes 255+
|
|
;; enable-function-keys nil: fkeys are multi-char escape codes.
|
|
(defun t10 ()
|
|
(let ((scr (make-instance 'screen :input-echoing nil :enable-function-keys t)))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
|
|
(format scr "~A lines high, ~A columns wide.~%~%" (height scr) (width scr))
|
|
(refresh scr)
|
|
|
|
(loop
|
|
;; act only on events, do nothing on non-events.
|
|
(when (key-pressed-p scr)
|
|
(let ((ch (get-char scr)))
|
|
;; quit on q, print everything else including function keys.
|
|
(cond ((equal (code-char ch) #\q) (return))
|
|
(t (format scr "Code: ~A, Char: ~A~%" ch (code-char ch))))))))
|
|
(close scr))))
|
|
|
|
;; cleaner key printing.
|
|
;; prints key names instead of numeric char codes.
|
|
(defun t10a ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-function-keys t
|
|
:input-buffering nil :process-control-chars nil :enable-newline-translation t)
|
|
(setf (scrolling-enabled-p scr) t)
|
|
(format scr "~A lines high, ~A columns wide.~%~%" (height scr) (width scr))
|
|
(loop (let ((event (get-event scr)))
|
|
(when event
|
|
(case event
|
|
(#\q (return))
|
|
|
|
;; non-printable ascii chars. (#\space and #\newline are standard, all others non-standard)
|
|
(#\escape (format scr "escape char ESC ^[ \e~%"))
|
|
(#\tab (format scr "horizontal tab char HT \t~%"))
|
|
(#\space (format scr "space char~%"))
|
|
|
|
;; NL can be either LF \n,CR \r,or CRLF \r\n, depending on the system. it is LF on ubuntu.
|
|
;; NL is the standard, system independent, portable way.
|
|
(#\linefeed (format scr "enter/linefeed LF ^J \n char~%"))
|
|
(#\return (format scr "enter/return CR ^M \r char~%"))
|
|
(#\newline (format scr "enter/newline char~%")) ; = #\linefeed, code 10.
|
|
|
|
;; use %nonl to prevent ^M (CR) from automatically being translated to ^J (LF)
|
|
(#\n (setf (newline-translation-enabled-p scr)
|
|
(not (newline-translation-enabled-p scr)))
|
|
(if (newline-translation-enabled-p scr)
|
|
(format scr "%nl newline translation enabled: RET => NL (= LF)~%")
|
|
(format scr "%nonl newline translation disabled: RET => CR~%")))
|
|
|
|
(#\rubout (format scr "rubout char ^?~%")) ;; DEL, ^?, delete char 127
|
|
(#\backspace (format scr "backspace char ^H~%")) ;; BS, \b, ^H, code 8, not the same as the :backspace key
|
|
|
|
(:backspace (format scr "backspace key <--~%"))
|
|
(otherwise (format scr "Event: ~A~%" event))))))))
|
|
|
|
;; demonstrate scrolling and scrolling regions.
|
|
(defun t11 ()
|
|
(let ((scr (make-instance 'screen)))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
(refresh scr)
|
|
|
|
;; (move scr 5 5)
|
|
(setf (cursor-position scr) '(5 5))
|
|
|
|
;; see inopts.
|
|
(setf
|
|
|
|
;; this is sufficient to make the whole window scroll.
|
|
;;(scrolling-enabled-p scr t)
|
|
;;(%scrollok (winptr scr) t)
|
|
(scrolling-enabled-p scr) t
|
|
|
|
;; to make only a few lines (5 to 10) scroll, we have to set a line-based region.
|
|
;;(set-scrolling-region scr 5 10)
|
|
;;(%wsetscrreg (winptr scr) 5 10)
|
|
(scrolling-region scr) '(5 10))
|
|
|
|
(loop for i from 0 to 30 do
|
|
(format scr "~A~%" i)
|
|
(refresh scr)
|
|
(sleep 0.2)))
|
|
|
|
(close scr))))
|
|
|
|
;; Display available ACS (alternative character set) pseudo-graphical characters.
|
|
(defun t12 ()
|
|
(let ((scr (make-instance 'screen)))
|
|
(unwind-protect
|
|
(progn
|
|
|
|
(add-string scr "ACS_ULCORNER ") (add-char scr (acs :upper-left-corner )) (add-string scr " upper left corner") (new-line scr)
|
|
(add-string scr "ACS_LLCORNER ") (add-char scr (acs :lower-left-corner )) (add-string scr " lower left corner ") (new-line scr)
|
|
(add-string scr "ACS_URCORNER ") (add-char scr (acs :upper-right-corner )) (add-string scr " upper right corner ") (new-line scr)
|
|
(add-string scr "ACS_LRCORNER ") (add-char scr (acs :lower-right-corner )) (add-string scr " lower right corner ") (new-line scr)
|
|
(add-string scr "ACS_LTEE ") (add-char scr (acs :tee-pointing-right )) (add-string scr " tee pointing right ") (new-line scr)
|
|
(add-string scr "ACS_RTEE ") (add-char scr (acs :tee-pointing-left )) (add-string scr " tee pointing left ") (new-line scr)
|
|
(add-string scr "ACS_BTEE ") (add-char scr (acs :tee-pointing-up )) (add-string scr " tee pointing up ") (new-line scr)
|
|
(add-string scr "ACS_TTEE ") (add-char scr (acs :tee-pointing-down )) (add-string scr " tee pointing down ") (new-line scr)
|
|
(add-string scr "ACS_HLINE ") (add-char scr (acs :horizontal-line )) (add-string scr " horizontal line ") (new-line scr)
|
|
(add-string scr "ACS_VLINE ") (add-char scr (acs :vertical-line )) (add-string scr " vertical line ") (new-line scr)
|
|
(add-string scr "ACS_PLUS ") (add-char scr (acs :crossover-plus )) (add-string scr " large plus or crossover ") (new-line scr)
|
|
(add-string scr "ACS_S1 ") (add-char scr (acs :scan-line-1 )) (add-string scr " scan line 1 ") (new-line scr)
|
|
(add-string scr "ACS_S3 ") (add-char scr (acs :scan-line-3 )) (add-string scr " scan line 3 ") (new-line scr)
|
|
(add-string scr "ACS_S7 ") (add-char scr (acs :scan-line-7 )) (add-string scr " scan line 7 ") (new-line scr)
|
|
(add-string scr "ACS_S9 ") (add-char scr (acs :scan-line-9 )) (add-string scr " scan line 9 ") (new-line scr)
|
|
(add-string scr "ACS_DIAMOND ") (add-char scr (acs :diamond-symbol )) (add-string scr " diamond ") (new-line scr)
|
|
(add-string scr "ACS_BOARD ") (add-char scr (acs :board )) (add-string scr " board of squares ") (new-line scr)
|
|
(add-string scr "ACS_CKBOARD ") (add-char scr (acs :checker-board )) (add-string scr " checker board (stipple) ") (new-line scr)
|
|
(add-string scr "ACS_DEGREE ") (add-char scr (acs :degree-symbol )) (add-string scr " degree symbol ") (new-line scr)
|
|
(add-string scr "ACS_PLMINUS ") (add-char scr (acs :plus-minus )) (add-string scr " plus/minus ") (new-line scr)
|
|
(add-string scr "ACS_BULLET ") (add-char scr (acs :bullet-symbol )) (add-string scr " bullet ") (new-line scr)
|
|
(add-string scr "ACS_LARROW ") (add-char scr (acs :arrow-pointing-left )) (add-string scr " arrow pointing left ") (new-line scr)
|
|
(add-string scr "ACS_RARROW ") (add-char scr (acs :arrow-pointing-right )) (add-string scr " arrow pointing right ") (new-line scr)
|
|
(add-string scr "ACS_DARROW ") (add-char scr (acs :arrow-pointing-down )) (add-string scr " arrow pointing down ") (new-line scr)
|
|
(add-string scr "ACS_UARROW ") (add-char scr (acs :arrow-pointing-up )) (add-string scr " arrow pointing up ") (new-line scr)
|
|
(add-string scr "ACS_LANTERN ") (add-char scr (acs :lantern-symbol )) (add-string scr " lantern symbol ") (new-line scr)
|
|
(add-string scr "ACS_BLOCK ") (add-char scr (acs :solid-square-block )) (add-string scr " solid square block ") (new-line scr)
|
|
(add-string scr "ACS_LEQUAL ") (add-char scr (acs :less-than-or-equal )) (add-string scr " less/equal ") (new-line scr)
|
|
(add-string scr "ACS_GEQUAL ") (add-char scr (acs :greater-than-or-equal)) (add-string scr " greater/equal ") (new-line scr)
|
|
(add-string scr "ACS_PI ") (add-char scr (acs :pi )) (add-string scr " Pi ") (new-line scr)
|
|
(add-string scr "ACS_NEQUAL ") (add-char scr (acs :not-equal )) (add-string scr " not equal ") (new-line scr)
|
|
(add-string scr "ACS_STERLING ") (add-char scr (acs :uk-pound-sterling )) (add-string scr " UK pound sign") (new-line scr)
|
|
|
|
(get-char scr))
|
|
(close scr))))
|
|
|
|
;; after adding gray streams and adding acs to add-char.
|
|
;; http://melvilletheatre.com/articles/ncurses-extended-characters/index.html
|
|
(defun t12a ()
|
|
(with-screen (scr)
|
|
(add-char scr :upper-left-corner ) (format scr " ACS_ULCORNER / upper left corner ~%")
|
|
(add-char scr :lower-left-corner ) (format scr " ACS_LLCORNER / lower left corner ~%")
|
|
(add-char scr :upper-right-corner ) (format scr " ACS_URCORNER / upper right corner ~%")
|
|
(add-char scr :lower-right-corner ) (format scr " ACS_LRCORNER / lower right corner ~%")
|
|
(add-char scr :tee-pointing-right ) (format scr " ACS_LTEE / tee pointing right ~%")
|
|
(add-char scr :tee-pointing-left ) (format scr " ACS_RTEE / tee pointing left ~%")
|
|
(add-char scr :tee-pointing-up ) (format scr " ACS_BTEE / tee pointing up ~%")
|
|
(add-char scr :tee-pointing-down ) (format scr " ACS_TTEE / tee pointing down ~%")
|
|
(add-char scr :horizontal-line ) (format scr " ACS_HLINE / horizontal line ~%")
|
|
(add-char scr :vertical-line ) (format scr " ACS_VLINE / vertical line ~%")
|
|
(add-char scr :crossover-plus ) (format scr " ACS_PLUS / large plus or crossover~%")
|
|
(add-char scr :scan-line-1 ) (format scr " ACS_S1 / scan line 1 ~%")
|
|
(add-char scr :scan-line-3 ) (format scr " ACS_S3 / scan line 3 ~%")
|
|
(add-char scr :scan-line-7 ) (format scr " ACS_S7 / scan line 7 ~%")
|
|
(add-char scr :scan-line-9 ) (format scr " ACS_S9 / scan line 9 ~%")
|
|
(add-char scr :diamond-symbol ) (format scr " ACS_DIAMOND / diamond ~%")
|
|
(add-char scr :board ) (format scr " ACS_BOARD / board of squares ~%")
|
|
(add-char scr :checker-board ) (format scr " ACS_CKBOARD / checker board (stipple)~%")
|
|
(add-char scr :degree-symbol ) (format scr " ACS_DEGREE / degree symbol ~%")
|
|
(add-char scr :plus-minus ) (format scr " ACS_PLMINUS / plus/minus ~%")
|
|
(add-char scr :bullet-symbol ) (format scr " ACS_BULLET / bullet ~%")
|
|
(add-char scr :arrow-pointing-left ) (format scr " ACS_LARROW / arrow pointing left ~%")
|
|
(add-char scr :arrow-pointing-right ) (format scr " ACS_RARROW / arrow pointing right ~%")
|
|
(add-char scr :arrow-pointing-down ) (format scr " ACS_DARROW / arrow pointing down ~%")
|
|
(add-char scr :arrow-pointing-up ) (format scr " ACS_UARROW / arrow pointing up ~%")
|
|
(add-char scr :lantern-symbol ) (format scr " ACS_LANTERN / lantern symbol ~%")
|
|
(add-char scr :solid-square-block ) (format scr " ACS_BLOCK / solid square block ~%")
|
|
(add-char scr :less-than-or-equal ) (format scr " ACS_LEQUAL / less/equal ~%")
|
|
(add-char scr :greater-than-or-equal) (format scr " ACS_GEQUAL / greater/equal ~%")
|
|
(add-char scr :pi ) (format scr " ACS_PI / Pi ~%")
|
|
(add-char scr :not-equal ) (format scr " ACS_NEQUAL / not equal ~%")
|
|
(add-char scr :uk-pound-sterling ) (format scr " ACS_STERLING / UK pound sign ~%")
|
|
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; Smaller ACS example to explain how the ACS system works.
|
|
(defun t12b ()
|
|
(with-screen (scr)
|
|
;; acs takes a keyword :ulcorner, translates it to a char #\l,
|
|
;; ncurses translates it at run-time to a terminal-dependent
|
|
;; integer value that doesnt correspond to a char code.
|
|
(format scr "~A ~A ~A " #\l (char-code #\l) (acs :upper-left-corner))
|
|
;; We cant output it in a string, but have to use add-char.
|
|
(add-char scr 4194412)
|
|
(terpri scr)
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; Show the longer symbol names next to the ACS chars in a more readable table view.
|
|
(defun t12c ()
|
|
(with-screen (scr)
|
|
(loop for i from 0 for symbol in
|
|
'(:upper-left-corner
|
|
:lower-left-corner
|
|
:upper-right-corner
|
|
:lower-right-corner
|
|
:tee-pointing-right
|
|
:tee-pointing-left
|
|
:tee-pointing-up
|
|
:tee-pointing-down
|
|
:horizontal-line
|
|
:vertical-line)
|
|
do (progn (move scr (+ 2 (* i 2)) 2)
|
|
(add-char scr symbol)
|
|
(format scr " ~S~%~%" symbol)))
|
|
|
|
(loop for i from 0 for symbol in
|
|
'(:crossover-plus
|
|
:scan-line-1
|
|
:scan-line-3
|
|
:scan-line-7
|
|
:scan-line-9
|
|
:diamond-symbol
|
|
:board
|
|
:checker-board
|
|
:degree-symbol
|
|
:plus-minus
|
|
:bullet-symbol)
|
|
do (progn (move scr (+ 2 (* i 2)) 30)
|
|
(add-char scr symbol)
|
|
(format scr " ~S~%~%" symbol)))
|
|
|
|
(loop for i from 0 for symbol in
|
|
'(:arrow-pointing-left
|
|
:arrow-pointing-right
|
|
:arrow-pointing-down
|
|
:arrow-pointing-up
|
|
:lantern-symbol
|
|
:solid-square-block
|
|
:less-than-or-equal
|
|
:greater-than-or-equal
|
|
:pi
|
|
:not-equal
|
|
:uk-pound-sterling)
|
|
do (progn (move scr (+ 2 (* i 2)) 55)
|
|
(add-char scr symbol)
|
|
(format scr " ~S~%~%" symbol)))
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
(defun t12c2 ()
|
|
"ACS chars not available on all terminals: thick and double line drawing characters.
|
|
|
|
Tested with xterm, gnome-terminal, st. Doesn't work in the linux console, aterm, eterm."
|
|
(with-screen (scr)
|
|
(loop for i from 0 for symbol in
|
|
'(:thick-upper-left-corner
|
|
:thick-lower-left-corner
|
|
:thick-upper-right-corner
|
|
:thick-lower-right-corner
|
|
:thick-tee-pointing-right
|
|
:thick-tee-pointing-left
|
|
:thick-tee-pointing-up
|
|
:thick-tee-pointing-down
|
|
:thick-horizontal-line
|
|
:thick-vertical-line
|
|
:thick-crossover-plus)
|
|
do (progn (move scr (+ 1 (* i 2)) 2)
|
|
(add-char scr symbol)
|
|
(format scr " ~S~%~%" symbol)))
|
|
|
|
(loop for i from 0 for symbol in
|
|
'(:double-upper-left-corner
|
|
:double-lower-left-corner
|
|
:double-upper-right-corner
|
|
:double-lower-right-corner
|
|
:double-tee-pointing-right
|
|
:double-tee-pointing-left
|
|
:double-tee-pointing-up
|
|
:double-tee-pointing-down
|
|
:double-horizontal-line
|
|
:double-vertical-line
|
|
:double-crossover-plus)
|
|
do (progn (move scr (+ 1 (* i 2)) 40)
|
|
(add-char scr symbol)
|
|
(format scr " ~S~%~%" symbol)))
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
(defun t12d ()
|
|
"Print all graphic alternative chars supported by the non-wide acs_map[128] array.
|
|
|
|
Only the chars 33 to 126 are graphic, and not all are accessible through the
|
|
keywords provided by ncurses, and the supported chars are terminal dependent."
|
|
(with-screen (scr)
|
|
(let* ((ptr (foreign-symbol-pointer "acs_map"))
|
|
(code (mem-aref ptr :unsigned-int (char-code #\l))))
|
|
(format scr "~A ~A ~A ~A " #\l (char-code #\l) (acs :upper-left-corner) code)
|
|
;; l 108 4194412 4194412 ***
|
|
;; 4194412 is nothing more than 108 with the A_ALTCHARSET bit turned on.
|
|
(add-char scr code)
|
|
(add-char scr (acs :upper-left-corner))
|
|
(add-char scr #\l :attributes (list :altcharset))
|
|
(terpri scr)
|
|
;; so we do not really need to access acs_map, like acs is doing.
|
|
;; we just need to translate chars like #\l to :upper-left-corner
|
|
(loop for i from 33 to 126 do
|
|
(add-char scr (code-char i))
|
|
(add-char scr #\space))
|
|
(terpri scr)
|
|
(loop for i from 33 to 126 do
|
|
(add-char scr (mem-aref ptr :unsigned-int i))
|
|
(add-char scr #\space))
|
|
(refresh scr)
|
|
(get-char scr))))
|
|
|
|
;; Demonstrate flash and beep alerts.
|
|
;; It depends on the terminal emulator whether they will work for you.
|
|
;; They both worked in xterm for me.
|
|
(defun t13 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil)
|
|
(loop
|
|
(let ((event (get-event scr)))
|
|
(if event
|
|
(case event
|
|
(#\b (alert :beep))
|
|
(#\f (alert :flash))
|
|
(#\q (return)))
|
|
(sleep 0.1))))))
|
|
|
|
;; minimal setting to get the mouse working.
|
|
;; reads and prints a single mouse event.
|
|
(defun t14 ()
|
|
(let ((scr (make-instance 'screen :input-echoing nil :input-blocking t :enable-function-keys t)))
|
|
(unwind-protect
|
|
(progn
|
|
(%mousemask #b00000111111111111111111111111111 (null-pointer)) ; activate all mouse events.
|
|
(get-char scr) ; here you have to click to generate a mouse event.
|
|
(with-foreign-object (me '(:struct mevent)) ; create a pointer to the struct mevent.
|
|
(%getmouse me) ; save the mouse event struct to the pointed position.
|
|
(princ (mem-ref me '(:struct mevent)) scr) ; dereference the pointer, return a plist of the struct.
|
|
(get-char scr)))
|
|
(close scr))))
|
|
|
|
;; (cffi:convert-to-foreign '(id 1 x 1 y 2 z 3 bstate 2) '(:struct mevent))
|
|
;; (setf ev (convert-from-foreign (mem-ref bstate '(:struct mevent)) '(:struct mevent)))
|
|
|
|
;; mouse events are now detected in the event loop.
|
|
;; print the y x coordinates and the detected event.
|
|
(defun t14a ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-function-keys t :cursor-visible nil)
|
|
(set-mouse-event '(:button-1-clicked :button-2-clicked :button-3-clicked))
|
|
(event-case (scr event y x)
|
|
((:button-1-clicked :button-2-clicked :button-3-clicked) (format scr "~3A ~3A ~A~%" y x event))
|
|
(#\q (return-from event-case)))))
|
|
|
|
;; left click prints a 1, right click prints a 3.
|
|
(defun t14b ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-function-keys t :cursor-visible nil)
|
|
(set-mouse-event '(:button-1-clicked :button-3-clicked))
|
|
(event-case (scr event mouse-y mouse-x)
|
|
(:button-1-clicked (move scr mouse-y mouse-x) (princ "1" scr))
|
|
(:button-3-clicked (move scr mouse-y mouse-x) (princ "3" scr))
|
|
(#\q (return-from event-case)))))
|
|
|
|
(defun t14c ()
|
|
"Print all mouse events."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-function-keys t :cursor-visible nil)
|
|
(%mousemask #b00000111111111111111111111111111 (null-pointer))
|
|
(event-case (scr event y x)
|
|
(#\q (return-from event-case))
|
|
(t (format scr "~3A ~3A ~A~%" y x event)) )))
|
|
|
|
;; resize event: the standard screen size is resized automatically.
|
|
(defun t15 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil :enable-colors t)
|
|
(add-string scr "Current standard screen geometry (Y x X):" :y 0 :x 0)
|
|
(loop
|
|
(let ((event (get-event scr)))
|
|
(if event
|
|
(case event
|
|
(:resize (move scr 1 0)
|
|
(format scr "~A Y lines x ~A X columns." (height scr) (width scr))
|
|
;; the environment variables get updated on a resize event too.
|
|
(format scr "~%~A Y lines x ~A X cols." %LINES %COLS)
|
|
(refresh scr))
|
|
(#\q (return)))
|
|
(progn
|
|
(sleep 0.1)))))))
|
|
|
|
;; resize event: arrange window _locations_ relative to the screen size.
|
|
(defun t15a ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil :enable-colors t)
|
|
(add-string scr "Current standard screen geometry (Y x X):" :y 0 :x 0)
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\. :color-pair '(:green :white)))
|
|
(let ((time 0)
|
|
;; place a window in the center of the screen.
|
|
(win (make-instance 'window :height 5 :width 10 :location (list (round (/ (height scr) 2))
|
|
(round (/ (width scr) 2))))))
|
|
(loop
|
|
(let ((event (get-event scr)))
|
|
(if event
|
|
(case event
|
|
(:resize ;; if the scren is resized, relocate the window to the new center.
|
|
(move-window win (round (/ (height scr) 2)) (round (/ (width scr) 2)))
|
|
;; better differentiation of types with methods.
|
|
(move win 0 0)
|
|
(format win "Y:~A X:~A" (height scr) (width scr))
|
|
;; repaint all windows completely by touching them before refreshing.
|
|
;; overlapping windows have to be refreshed in reverse stacking order.
|
|
(mapc #'(lambda (w) (touch w) (refresh w))
|
|
(list scr win)))
|
|
(#\q (return)))
|
|
(progn
|
|
(sleep 0.01)
|
|
(move win 1 0)
|
|
(incf time 0.01)
|
|
(format win "~A" time)
|
|
(mapc #'(lambda (w) (touch w) (refresh w))
|
|
(list scr win)) ))))
|
|
(close win))))
|
|
|
|
;; resize event: arrange window _sizes_ relative to the screen size.
|
|
(defun t15b ()
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-function-keys t :cursor-visible nil :enable-colors t)
|
|
(add-string scr "Current standard screen geometry (Y x X):" :y 0 :x 0)
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
(let ((time 0)
|
|
;; make the window slightly smaller than the standard screen.
|
|
(win (make-instance 'window :height (- (height scr) 4) :width (- (width scr) 6) :location '(2 3))))
|
|
(loop
|
|
(let ((event (get-event scr)))
|
|
(if event
|
|
(case event
|
|
(:resize ;; resize the window on every termina resize.
|
|
(resize win (- (height scr) 4) (- (width scr) 6))
|
|
(move win 0 0)
|
|
(format win "Y:~A X:~A" (height scr) (width scr))
|
|
;; when updating several overlapping windows, using mark-for-refresh and
|
|
;; batch-refresh instead of several calls to refresh prevents flickering.
|
|
(mapc #'(lambda (w) (touch w) (mark-for-refresh w)) (list scr win))
|
|
(refresh-marked))
|
|
(#\q (return)))
|
|
(progn
|
|
(sleep 0.01)
|
|
(move win 1 0)
|
|
(incf time 0.01)
|
|
(format win "~A" time)
|
|
(mapc #'(lambda (w) (touch w) (mark-for-refresh w)) (list scr win))
|
|
(refresh-marked) ))))
|
|
(close win))))
|
|
|
|
;; test get-string: read a string, then output it.
|
|
;; the only function key we can use during input is backspace.
|
|
(defun t16 ()
|
|
(unwind-protect
|
|
(let ((scr (make-instance 'screen)))
|
|
(clear scr)
|
|
(move scr 0 0)
|
|
(add-string scr "Type your name: ")
|
|
(refresh scr)
|
|
(let ((str (get-string scr 10)))
|
|
(add-string scr "Your name is: ")
|
|
(add-string scr str))
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(end-screen)))
|
|
|
|
;; read a single line of Lisp input (30 chars max) from the last line,
|
|
;; evaluate it and print the result to the output window above.
|
|
(defun t16a ()
|
|
(with-screen (scr :input-echoing t :input-blocking t :enable-function-keys t :cursor-visible nil :enable-colors nil)
|
|
(let ((out (make-instance 'window :height (1- (height scr)) :width (width scr) :location '(0 0)))
|
|
(in (make-instance 'window :height 1 :width (width scr) :location (list (1- (height scr)) 0))))
|
|
|
|
(print (eval (read-from-string (get-string in 30))) out)
|
|
(refresh out)
|
|
|
|
;; blocking is t, so wait till the next keypress before exiting.
|
|
(get-char in)
|
|
|
|
;; close windows and window streams.
|
|
(close in)
|
|
(close out))))
|
|
|
|
;; add a loop to the input, making it a simple repl.
|
|
(defun t16b ()
|
|
(with-screen (scr :input-echoing t :input-blocking t :enable-function-keys t :cursor-visible t :enable-colors nil)
|
|
(let ((out (make-instance 'window :height (1- (height scr)) :width (width scr) :location '(0 0)))
|
|
(in (make-instance 'window :height 1 :width (width scr) :location (list (1- (height scr)) 0))))
|
|
(loop
|
|
(let ((str (get-string in 30)))
|
|
;; if the input line is empty (length = 0), do nothing.
|
|
(when (> (length str) 0)
|
|
;; a single blocking q exits the loop.
|
|
(when (string= str "q") (return))
|
|
;; after the input is read, clear the input line.
|
|
(clear in)
|
|
(print (eval (read-from-string str)) out)
|
|
(refresh out))))
|
|
(close in)
|
|
(close out))))
|
|
|
|
;; ncurses' get-string only allows the backspace key.
|
|
;; extend the functionality of the input line of the simple repl.
|
|
(defun t16c ()
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t)
|
|
(let* ((wout (make-instance 'window :height (1- (height scr)) :width (width scr) :location '(0 0) :enable-scrolling t))
|
|
;; input blocking is a property of every single window, not just of the global screen.
|
|
(win (make-instance 'window :height 1 :width (width scr) :location (list (1- (height scr)) 0)
|
|
:enable-function-keys t :input-blocking t))
|
|
(*standard-output* wout)
|
|
(n 0)) ; no of chars in the input line.
|
|
(event-case (win event)
|
|
(:left
|
|
(when (> (cadr (cursor-position win)) 0)
|
|
(move win 0 -1 :relative t)))
|
|
(:right
|
|
(when (< (cadr (cursor-position win)) n)
|
|
(move win 0 1 :relative t)))
|
|
(#\newline ; RET key, C-j, C-m
|
|
(when (> n 0) ; only print when the line is not empty.
|
|
(let* ((strin (extract-wide-string win :n n :y 0 :x 0))
|
|
(strout (eval (read-from-string strin))))
|
|
(print (length strin))
|
|
(princ strin)
|
|
(terpri)
|
|
(add-string wout (format nil "=> ~A~%~%" strout)))
|
|
(setf n 0)
|
|
(clear win) ; empty the input line after evaluation.
|
|
(refresh wout)))
|
|
(:dc ; DEL key
|
|
(when (> n (cadr (cursor-position win)))
|
|
(decf n)
|
|
(delete-char win)))
|
|
(:ic ; INS / Einfg key
|
|
(format t "(insert-mode-p win) => ~A~%" (insert-mode-p win))
|
|
(setf (insert-mode-p win) (not (insert-mode-p win)))
|
|
(format t "(insert-mode-p win) => ~A~%" (insert-mode-p win))
|
|
(refresh wout))
|
|
(:backspace ; BS key
|
|
(when (> (cadr (cursor-position win)) 0)
|
|
(decf n)
|
|
(move win 0 -1 :relative t)
|
|
(delete-char win)))
|
|
(#\q (return-from event-case))
|
|
((nil) ; when no key is hit at all
|
|
;; when there is no event, get-event will return nil.
|
|
;; this is the place for no-event code.
|
|
;; instead of doing nothing, set blocking to t.
|
|
nil)
|
|
;; non-function keys, i.e. normal character keys
|
|
(otherwise
|
|
(when (and (characterp event)
|
|
(< (cadr (cursor-position win)) (1- (width win))))
|
|
(incf n)
|
|
;; insert-mode-p does not insert if we do not use gray stream functions
|
|
;;(add-wide-char win event))))
|
|
(write-char event win)))) ; calls stream-write-char
|
|
;; (princ event win) ; calls print-object
|
|
(close win)
|
|
(close wout))))
|
|
|
|
;; buffer: (3 2 1)
|
|
;; screen: 123
|
|
;; in the buffer, elements are added to the left and counted from the left.
|
|
;; on the screen, the list is displayed in reverse.
|
|
(defun t16d ()
|
|
"Use an input buffer instead of extracting the string from the window. Create windows using the with-windows macro."
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t)
|
|
(with-windows ((wout :height (1- (height scr)) :width (width scr) :location '(0 0) :enable-scrolling t)
|
|
(win :height 1 :width (width scr) :location (list (1- (height scr)) 0) :enable-function-keys t :input-blocking t))
|
|
(let ((*standard-output* wout)
|
|
(inbuf nil) ; input buffer character list
|
|
(inptr 0)) ; position of the next character in the buffer
|
|
(event-case (win event)
|
|
(#\q (return-from event-case))
|
|
(:left
|
|
(when (> inptr 0) (decf inptr))
|
|
(move win 0 inptr))
|
|
(:right
|
|
(when (< inptr (length inbuf)) (incf inptr))
|
|
(move win 0 inptr))
|
|
(#\newline
|
|
(when (> (length inbuf) 0)
|
|
(format t "~A~%" (coerce (reverse inbuf) 'string)) (refresh wout)
|
|
(setf inbuf nil inptr 0)
|
|
(clear win)
|
|
(move win 0 inptr)
|
|
(refresh win)))
|
|
(:dc
|
|
(when (> (length inbuf) inptr)
|
|
(setf inbuf (remove-nth (- (length inbuf) (1+ inptr)) inbuf))
|
|
(clear win)
|
|
(add-string win (coerce (reverse inbuf) 'string))
|
|
(move win 0 inptr)
|
|
(refresh win)))
|
|
(:backspace
|
|
(when (> inptr 0)
|
|
(decf inptr)
|
|
(setf inbuf (remove-nth (- (length inbuf) 1 inptr) inbuf))
|
|
(clear win)
|
|
(add-string win (coerce (reverse inbuf) 'string))
|
|
(move win 0 inptr)
|
|
(refresh win)))
|
|
(:ic
|
|
(format t "(insert-mode-p win) => ~A~%" (insert-mode-p win))
|
|
(setf (insert-mode-p win) (not (insert-mode-p win)))
|
|
(format t "(insert-mode-p win) => ~A~%" (insert-mode-p win))
|
|
(refresh wout))
|
|
(otherwise
|
|
(if (= inptr (length inbuf))
|
|
(setf inbuf (cons event inbuf))
|
|
(if (insert-mode-p win)
|
|
(setf inbuf (insert-nth (- (length inbuf) inptr) event inbuf))
|
|
(setf inbuf (replace-nth (- (length inbuf) (1+ inptr)) event inbuf))))
|
|
(incf inptr)
|
|
(clear win)
|
|
(add-string win (coerce (reverse inbuf) 'string))
|
|
(move win 0 inptr)
|
|
(refresh win)))))))
|
|
|
|
(defun t16e ()
|
|
"Edit a single input field, not part of a form."
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t :enable-function-keys t :input-blocking t)
|
|
(let ((*standard-output* scr)
|
|
(s1 (list :attributes '(:underline)))
|
|
(s2 (list :simple-char #\.))
|
|
(field (make-instance 'field :location (list 3 20) :width 10 :window scr)))
|
|
|
|
(setf (style field) (list :foreground s1 :background s2))
|
|
|
|
(bind field #\newline 'de.anvi.croatoan::debug-print-field-buffer)
|
|
|
|
;; pressing ^A (for "accept") exits the edit mode (for now)
|
|
;; the field variables are not reset when edit is exited, we can access them after the edit.
|
|
(if (edit field)
|
|
;; accept returns t
|
|
(progn
|
|
(clear scr)
|
|
;; display the contents of the input buffer of the field
|
|
(format t "buffer: ~A~%" (buffer field))
|
|
(format t "string: ~A" (value field)))
|
|
;; when cancel returns nil
|
|
(progn
|
|
(clear scr)
|
|
(format t "field edit canceled.")))
|
|
|
|
(refresh scr)
|
|
|
|
;; wait for keypress, then exit
|
|
(get-char scr) )))
|
|
|
|
(defun t16f ()
|
|
"Group several input fields and buttons to a form."
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t :enable-function-keys t :input-blocking t)
|
|
(let* ((s1 (list :fgcolor nil :bgcolor nil :attributes nil))
|
|
(s2 (list :simple-char #\_))
|
|
(s3 (list :fgcolor :yellow :bgcolor :red :attributes '(:underline :bold :italic)))
|
|
(s4 (list :fgcolor :blue :bgcolor :white :attributes nil))
|
|
|
|
;; a style is a plist interpreted by the element drawing functions.
|
|
(s5 (list :foreground s1 :background s2 :selected-foreground s3 :selected-background s4))
|
|
|
|
(field1 (make-instance 'field :location (list 3 20) :width 10 :style s5 :max-buffer-length 5))
|
|
(field2 (make-instance 'field :location (list 5 20) :width 10 :style s5))
|
|
(field3 (make-instance 'field :location (list 7 20) :width 10 :style s5 :max-buffer-length 15))
|
|
|
|
(s6 (list :foreground s1 :selected-foreground s4))
|
|
|
|
(button1 (make-instance 'button :location (list 10 10) :name "Hello" :style s6))
|
|
(button2 (make-instance 'button :location (list 10 20) :name "Accept" :style s6))
|
|
(button3 (make-instance 'button :location (list 10 30) :name "Cancel" :style s6))
|
|
|
|
;; a window is associated with the parent form, and can be accessed by the elements.
|
|
(form (make-instance 'form :elements (list field1 field2 field3 button1 button2 button3) :window scr)))
|
|
|
|
;; for debugging, return prints the content of the buffer and then deletes the buffer
|
|
(bind form :f4 'de.anvi.croatoan::debug-print-field-buffer)
|
|
(bind (find-keymap 'field-map) :f3 'de.anvi.croatoan::debug-print-field-buffer)
|
|
|
|
;; Functions to be called when the button is activated by #\newline or #\space.
|
|
(setf (callback button1) (lambda (b e) (save-excursion scr (move scr 0 0) (format scr "Hello there"))))
|
|
(setf (callback button2) 'accept)
|
|
(setf (callback button3) 'cancel)
|
|
|
|
;; pressing ^A or C-a (for "accept") exits the edit mode
|
|
;; TAB, up and down cycles the fields and buttons
|
|
(if (prog1 (edit form) (clear scr))
|
|
;; display the contents of the input buffer of all fields of the form
|
|
;; use field-buffer-to-string to get the contents of the field buffer as a string instead of a list of chars.
|
|
(loop for el in (elements form)
|
|
do (when (typep el 'field)
|
|
(format scr "~A ~A ~%" (buffer el) (value el))))
|
|
;; user did not accept the form (default) or called cancel-form.
|
|
(format scr "nil"))
|
|
|
|
(refresh scr)
|
|
;; wait for keypress, then exit
|
|
(get-char scr) )))
|
|
|
|
(defun t16g ()
|
|
"Use the element default style of the form."
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t :enable-function-keys t :input-blocking t)
|
|
(let* (;; character styles that can be referenced in element styles
|
|
(ch1 (list :fgcolor :blue :bgcolor :black))
|
|
(ch2 (list :simple-char #\_))
|
|
(ch3 (list :fgcolor :yellow :bgcolor :red :attributes '(:bold :italic)))
|
|
(ch4 (list :simple-char #\_ :fgcolor :white :bgcolor :blue))
|
|
(ch5 (list :fgcolor :yellow :simple-char #\.))
|
|
|
|
;; element styles reference previousy defined character styles.
|
|
(s1 (list :foreground ch1 :background ch2 :selected-foreground ch3 :selected-background ch4))
|
|
(s2 (list :foreground ch4 :selected-foreground ch3))
|
|
(s3 (list :foreground ch1 :background ch5))
|
|
|
|
;; the form style consists of default styles of form elements.
|
|
(sf1 (list 'field s1 'button s2 'label s3 'checkbox s1))
|
|
|
|
(field1 (make-instance 'field :name :f1 :title "Forename" :location (list 3 20) :width 15 :max-buffer-length 5))
|
|
(field2 (make-instance 'field :name :f2 :title "Surname" :location (list 5 20) :width 15))
|
|
(field3 (make-instance 'field :name :f3 :location (list 7 20) :width 15 :max-buffer-length 20))
|
|
|
|
(cb1 (make-instance 'checkbox :name :c1 :title "Employed" :location (list 9 20)))
|
|
|
|
(m1 (make-instance 'checklist :name :m1 :title "checklist" :items (list 'a 'b 'c 'd 'e 'f) :layout (list 2 3)
|
|
:max-item-length 6 :menu-location (list 11 20) :window scr))
|
|
|
|
(label1 (make-instance 'label :name :l1 :reference :f1 :width 18 :location (list 3 1)))
|
|
(label2 (make-instance 'label :name :l2 :reference :f2 :width 18 :location (list 5 1)))
|
|
(label3 (make-instance 'label :name :l3 :title "Age" :location (list 7 1)))
|
|
(label4 (make-instance 'label :name :l4 :reference :c1 :width 18 :location (list 9 1)))
|
|
(label5 (make-instance 'label :name :l5 :reference :m1 :width 18 :location (list 11 1)))
|
|
|
|
(button1 (make-instance 'button :name :b1 :title "Hello" :location (list 14 10)))
|
|
(button2 (make-instance 'button :name :b2 :title "Accept" :location (list 14 20)))
|
|
(button3 (make-instance 'button :name :b3 :title "Cancel" :location (list 14 30)))
|
|
|
|
(form (make-instance 'form
|
|
:elements (list field1 field2 field3 cb1 label1 label2 label3 label4 label5
|
|
m1 button1 button2 button3)
|
|
:style sf1 :window scr)))
|
|
|
|
;; for debugging, return prints the content of the buffer and then deletes the buffer
|
|
(bind form :f4 'crt::debug-print-field-buffer)
|
|
|
|
;; Functions to be called when the button is activated by #\newline or #\space.
|
|
(setf (callback button1) (lambda (b e) (save-excursion scr (move scr 0 0) (format scr "Hello there"))))
|
|
(setf (callback button2) 'accept)
|
|
(setf (callback button3) 'cancel)
|
|
|
|
;; The set value shouldnt be longer than the max-buffer-length
|
|
(setf (value field2) "hello"
|
|
(value field3) "dear john")
|
|
|
|
;; Access fields by their name instead of looping through the elements list.
|
|
(if (edit form)
|
|
;; edit returned t, which means the user accepted the form
|
|
(progn
|
|
(clear scr)
|
|
(mapc #'(lambda (name)
|
|
(let ((element (find-element form name)))
|
|
(format scr "~5A ~10A ~20A~%" name (title element) (value element))))
|
|
(list :f1 :f2 :f3))
|
|
;; display the state of the checkbox
|
|
(format scr "~5A ~10A ~20A~%" (name cb1) (title cb1) (checkedp cb1))
|
|
(format scr "~5A ~10A ~20A~%" (name m1) (title m1) (value m1)))
|
|
|
|
;; edit returned nil, which means the user canceled the form
|
|
(progn
|
|
(clear scr)
|
|
(format scr "nil")))
|
|
|
|
(refresh scr)
|
|
;; wait for keypress, then exit
|
|
(get-char scr) )))
|
|
|
|
(defun t16h ()
|
|
"Create a form window."
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t :enable-function-keys t :input-blocking t)
|
|
(let* ((ch1 (list :fgcolor :black :bgcolor :white))
|
|
(ch2 (list :simple-char #\_ :fgcolor :black :bgcolor :white))
|
|
(ch3 (list :fgcolor :yellow :bgcolor :red :attributes '(:underline :bold :italic)))
|
|
(ch4 (list :simple-char #\_ :fgcolor :white :bgcolor :blue))
|
|
|
|
(style1 (list :foreground ch1 :background ch2 :selected-foreground ch3 :selected-background ch4))
|
|
(style2 (list :foreground ch4 :selected-foreground ch3))
|
|
(style3 (list 'field style1 'button style2))
|
|
|
|
(field1 (make-instance 'field :name :f1 :title "Forename" :location (list 3 3) :width 20 :max-buffer-length 5))
|
|
(field2 (make-instance 'field :name :f2 :title "Surname" :location (list 5 3) :width 20))
|
|
(field3 (make-instance 'field :name :f3 :title "Age" :location (list 7 3) :width 20 :max-buffer-length 20))
|
|
|
|
(button1 (make-instance 'button :name :b1 :title "Say Hello" :location (list 10 7)))
|
|
(button2 (make-instance 'button :name :b1 :title "Cancel" :location (list 10 20)))
|
|
(button3 (make-instance 'button :name :b2 :title "Accept" :location (list 10 30)))
|
|
|
|
(form (make-instance 'form-window :elements (list field1 field2 field3 button1 button2 button3)
|
|
:style style3 :enable-function-keys t :input-blocking t :title "form window"
|
|
:draw-border t :height 15 :width 50 :location (list 5 15))))
|
|
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #\space))
|
|
(setf (background form) (make-instance 'complex-char :simple-char #\space :color-pair '(:black :white)))
|
|
(refresh scr)
|
|
|
|
;; Functions to be called when the button is activated by #\newline or #\space.
|
|
(setf (callback button1) (lambda (b e) (save-excursion scr (move scr 0 0) (format scr "Hello there") (refresh scr))))
|
|
(setf (callback button2) 'cancel)
|
|
(setf (callback button3) 'accept)
|
|
|
|
;; The set value shouldnt be longer than the max-buffer-length (not checked yet)
|
|
(setf (value field1) "hello"
|
|
(value field2) "there"
|
|
(value field3) "dear john")
|
|
|
|
(event-case (scr event)
|
|
(#\q (return-from event-case))
|
|
;; display the form window input box by pressing a.
|
|
(#\a
|
|
(if (edit form)
|
|
;; edit returns t if the form is accepted
|
|
(progn
|
|
(clear scr)
|
|
;; Access fields by their name instead of looping through the elements list.
|
|
(mapc #'(lambda (name)
|
|
(let ((field (find-element form name)))
|
|
(format scr "~5A ~10A ~20A~%" name (title field) (value field))))
|
|
(list :f1 :f2 :f3))
|
|
(refresh scr))
|
|
|
|
;; and nil if it is cancelled.
|
|
(progn
|
|
(clear scr)
|
|
(princ nil scr)
|
|
(refresh scr)))))
|
|
|
|
;; close the ncurses windows before exiting.
|
|
(close form))))
|
|
|
|
(defun t16i ()
|
|
"A simple input form window."
|
|
(let ((value nil))
|
|
(with-screen (scr :input-echoing nil :cursor-visible t :enable-colors t :enable-function-keys t :input-blocking t)
|
|
(let* ((ch1 (list :fgcolor :black :bgcolor :white))
|
|
(ch2 (list :simple-char #\_ :fgcolor :black :bgcolor :white))
|
|
(ch3 (list :fgcolor :yellow :bgcolor :red :attributes '(:underline :bold :italic)))
|
|
(ch4 (list :simple-char #\_ :fgcolor :white :bgcolor :blue))
|
|
(ch5 (list :simple-char #\. :fgcolor :black :bgcolor :white))
|
|
|
|
(style1 (list :foreground ch1 :background ch2 :selected-foreground ch3 :selected-background ch4))
|
|
(style2 (list :foreground ch1 :selected-foreground ch4))
|
|
(style3 (list :foreground ch1 :background ch5))
|
|
|
|
;; form element default styles
|
|
(style4 (list 'field style1 'button style2 'label style3))
|
|
|
|
(label1 (make-instance 'label :name :l1 :reference :f1 :width 20 :location (list 2 1)))
|
|
(field1 (make-instance 'field :name :f1 :title "Forename" :location (list 2 22) :width 20 :max-buffer-length 25))
|
|
|
|
(label2 (make-instance 'label :name :l2 :reference :f2 :width 20 :location (list 4 1)))
|
|
(field2 (make-instance 'field :name :f2 :title "Surname" :location (list 4 22) :width 20 :max-buffer-length 25))
|
|
|
|
(button1 (make-instance 'button :name :b3 :title "Reset" :location (list 6 15)))
|
|
(button2 (make-instance 'button :name :b2 :title "Cancel" :location (list 6 25)))
|
|
(button3 (make-instance 'button :name :b2 :title "Accept" :location (list 6 34)))
|
|
|
|
(form (make-instance 'form-window :elements (list field1 field2 label1 label2 button1 button2 button3)
|
|
:style style4 :enable-function-keys t :input-blocking t :title "form window"
|
|
:draw-border t :height 10 :width 50 :location (list 5 15))))
|
|
|
|
(setf (background form) (make-instance 'complex-char :simple-char #\space :color-pair '(:black :white)))
|
|
(refresh scr)
|
|
|
|
(setf (callback button1) 'reset-form)
|
|
(setf (callback button2) 'cancel)
|
|
(setf (callback button3) 'accept)
|
|
|
|
(if (edit form)
|
|
(setq value (pairlis (list (title field1) (title field2))
|
|
(list (value field1) (value field2))))
|
|
(setq value nil))
|
|
(close form)))
|
|
|
|
;; return the input values
|
|
value))
|
|
|
|
;; creating sub-windows and how they share memory with the parent window.
|
|
;; leaving out the size of a window maxes it out to the right (win1) and to the bottom (win1, win3)
|
|
(defun t17 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((win1 (make-instance 'window :location '(2 2) :draw-border t))
|
|
(win2 (make-instance 'sub-window :parent win1 :height 5 :width 20 :location '(4 4) :draw-border t))
|
|
(win3 (make-instance 'sub-window :parent win1 :width 20 :location '(4 4) :draw-border t :relative t)))
|
|
(princ "win1" win1)
|
|
(princ "win2" win2)
|
|
(princ "win3 relative" win3)
|
|
(mapc #'(lambda (w) (refresh w)) (list win1 win2 win3))
|
|
(get-char win3)
|
|
(mapc #'(lambda (w) (close w)) (list win2 win3))
|
|
(refresh win1)
|
|
;; observe that the content from win 2 and 3 is still in win1 after they have been closed.
|
|
(get-char win1)
|
|
(close win1) )))
|
|
|
|
;; by default, the sub-window displays the part of the parent window it overlaps with.
|
|
;; we can change which part of the parent is displayed by changing the sub-windows source-location
|
|
;; we can change where it is displayed by changing the sub-windows location.
|
|
(defun t17a ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let ((win (make-instance 'sub-window :parent scr :height 5 :width 20 :location '(2 2) :draw-border t :relative t)))
|
|
;; initial content written to subwin and thus to scr.
|
|
(move win 1 1) (princ "subwin" win)
|
|
|
|
;; create two content areas in the parent window.
|
|
(move scr 2 25) (princ "area1" scr)
|
|
(move scr 3 29) (princ "area1" scr)
|
|
(move scr 4 33) (princ "area1" scr)
|
|
(move scr 5 37) (princ "area1" scr)
|
|
(move scr 6 41) (princ "area1" scr)
|
|
|
|
(move scr 2 50) (princ "area2" scr)
|
|
(move scr 3 54) (princ "area2" scr)
|
|
(move scr 4 58) (princ "area2" scr)
|
|
(move scr 5 62) (princ "area2" scr)
|
|
(move scr 6 66) (princ "area2" scr)
|
|
|
|
(mapc #'(lambda (w) (touch w) (refresh w)) (list scr win))
|
|
(get-char scr)
|
|
|
|
;; map area1 to subwin location
|
|
;; the mapping only _displays_ the content from the source area.
|
|
;; the mapping it doesnt _write_ it onto the displayed area of scr.
|
|
(setf (source-location win) '(2 25)) ; (%mvderwin (winptr win) 2 25)
|
|
(mapc #'(lambda (w) (touch w) (refresh w)) (list scr win))
|
|
(get-char scr)
|
|
|
|
;; map area2 to subwin location
|
|
(setf (source-location win) '(2 50))
|
|
(mapc #'(lambda (w) (touch w) (refresh w)) (list scr win))
|
|
(get-char scr)
|
|
|
|
;;; now move subwin location
|
|
;; it still maps area2, but now to the new location.
|
|
;; the original content written to the subwin (and thus to scr because they share memory)
|
|
;; is now visible in scr, since the subwin overlay has moved.
|
|
(setf (location win) '(10 2))
|
|
(mapc #'(lambda (w) (touch w) (refresh w)) (list scr win))
|
|
(get-char scr)
|
|
|
|
;; map area1 again, but now to the new location.
|
|
(setf (source-location win) '(2 25))
|
|
(mapc #'(lambda (w) (touch w) (refresh w)) (list scr win))
|
|
(get-char scr)
|
|
|
|
;; writing to a sub-window writes to the _mapped_ location of the parent window
|
|
;; _not_ to the parent location below the subwindow.
|
|
(clear win)
|
|
(move win 0 0) (princ "writing to sub-win" win)
|
|
(move win 1 0) (princ "writes to parent win" win)
|
|
(mapc #'(lambda (w) (touch w) (refresh w)) (list scr win))
|
|
(get-char scr)
|
|
|
|
;; delete the subwindow win
|
|
;; the mapped content isnt displayed any more.
|
|
;; now the content before the mapping should be displayed again.
|
|
(mapc #'(lambda (w) (close w)) (list win))
|
|
(refresh scr)
|
|
(get-char scr) )))
|
|
|
|
;; Display misc system information
|
|
;; https://github.com/rudolfochrist/dotfiles/blob/master/.rc.lisp
|
|
(defun t18 ()
|
|
(with-screen (scr)
|
|
(format scr "Lisp implementation type: ~A~%" (lisp-implementation-type))
|
|
(format scr "Lisp implementation version: ~A~%" (lisp-implementation-version))
|
|
(format scr "Machine type (Arch) ~A~%" (machine-type))
|
|
(format scr "Machine version (CPU) ~A~%" (machine-version))
|
|
(format scr "Software type (OS) ~A~%" (software-type))
|
|
(format scr "Software version (OS) ~A~%" (software-version))
|
|
(format scr "Machine instance (hostname) ~A~%" (machine-instance))
|
|
(format scr "User HOME ~A~%" (user-homedir-pathname))
|
|
(format scr "Ncurses version: ~A~%" (de.anvi.ncurses:%curses-version))
|
|
(format scr "Terminal: ~A~%" (%termname))
|
|
(format scr "Colors supported: ~A~%" (%has-colors))
|
|
(format scr "Color change supported: ~A~%" (%can-change-color))
|
|
(format scr "No of supported colors: ~A~%" %colors)
|
|
(format scr "No of supported color pairs ~A~%" %color-pairs)
|
|
(format scr "Can insert/delete chars: ~A~%" (%has-ic))
|
|
(format scr "Can insert/delete lines: ~A~%" (%has-il))
|
|
#+sbcl
|
|
(progn
|
|
(format scr "Terminal: ~A~%" (sb-ext:posix-getenv "TERM"))
|
|
(format scr "Locale: ~A~%" (sb-ext:posix-getenv "LANG"))
|
|
(format scr "Hostname: ~A~%" (sb-ext:posix-getenv "HOSTNAME"))
|
|
(format scr "Username: ~A~%" (sb-ext:posix-getenv "USER"))
|
|
(format scr "Operating system: ~A~%" (sb-ext:posix-getenv "OSTYPE"))
|
|
(format scr "CPU Type: ~A~%" (sb-ext:posix-getenv "MACHTYPE")))
|
|
(format scr "uname -a:~%~A" (uiop:run-program "uname -a" :output :string))
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; http://stackoverflow.com/questions/38684906/how-to-get-package-documentation-in-quicklisp
|
|
(defun t18a ()
|
|
"Display misc quicklisp information."
|
|
#+quicklisp
|
|
(with-screen (scr)
|
|
(let* ((dist (ql-dist:dist "quicklisp")) ; current dist
|
|
;; output to an empty broadcast stream is discraded like redirecting to /dev/null
|
|
(*standard-output* (make-broadcast-stream))
|
|
;; Quicklisp prints its "Fetching xyz" messages to *trace-output*
|
|
(*trace-output* *standard-output*)
|
|
(*error-output* *standard-output*)
|
|
(installed-systems (mapcar #'ql-dist:name (ql-dist:installed-systems dist))))
|
|
(format scr "Quicklisp dist name ~A~%" (ql-dist:name dist))
|
|
(format scr "Quicklisp dist version ~A~%" (ql-dist:version dist))
|
|
(format scr "Quicklisp available version ~A~%" (caar (ql-dist:available-versions dist)))
|
|
(format scr "~%Quicklisp installed releases ~{~A, ~}~%" (mapcar #'ql-dist:name (ql-dist:installed-releases dist)))
|
|
(format scr "~%Quicklisp installed systems ~{~A, ~}~%~%" installed-systems)
|
|
(loop
|
|
for i in installed-systems
|
|
for sys = (asdf:find-system i nil)
|
|
do
|
|
(when sys
|
|
(format scr "~27@A | ~A~%"
|
|
i
|
|
(remove #\newline (asdf:system-description sys))))))
|
|
(refresh scr)
|
|
(get-char scr))
|
|
#-quicklisp
|
|
(princ "Quicklisp not installed."))
|
|
|
|
;; print a simple menu, let the user choose an item by arrow keys, return the chosen item.
|
|
;; https://www.gnu.org/software/guile-ncurses/manual/html_node/A-simple-key-usage-example.html
|
|
(defun t19 ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(flet ((draw-menu (win choices i)
|
|
(clear win)
|
|
(loop for j from 0 to (1- (length choices)) do
|
|
(move win j 0)
|
|
(format win "~A~A" (nth j choices) (if (= i j) "*" ""))
|
|
(when (= i j)
|
|
(move win j 0)
|
|
(change-attributes win 9 '(:reverse)))
|
|
(refresh win))))
|
|
(let* ((choices '("Choice 0" "Choice 1" "Choice 2" "Choice 3" "Choice 4" "Choice 5" "Choice 6"))
|
|
(n (length choices))
|
|
(i 0)) ; current choice
|
|
(draw-menu scr choices i)
|
|
(event-case (scr event)
|
|
(:up (setf i (mod (1- i) n)) (draw-menu scr choices i))
|
|
(:down (setf i (mod (1+ i) n)) (draw-menu scr choices i))
|
|
(#\newline (return-from event-case (nth i choices)))
|
|
(#\q (return-from event-case)))))))
|
|
|
|
;; an even simpler 2-item menu is a yes-no-dialog.
|
|
(defun t19a ()
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(flet ((draw-menu (win choices i)
|
|
(move win 2 0) (clear win :target :end-of-line)
|
|
(loop for j from 0 to (1- (length choices)) do
|
|
(move win 2 (* 10 j))
|
|
(format win "~A~A" (car (nth j choices)) (if (= i j) "*" ""))
|
|
(refresh win))))
|
|
(let* ((choices '(("Yes" . t) ("No" . nil)))
|
|
(n (length choices))
|
|
(i 0)) ; current choice
|
|
(move scr 0 0) (format scr "User, do you want?") (refresh scr)
|
|
(draw-menu scr choices i)
|
|
(event-case (scr event)
|
|
((:up :down :left :right #\tab) (setf i (mod (1+ i) n)) (draw-menu scr choices i))
|
|
(#\newline (return-from event-case (cdr (nth i choices)))))))))
|
|
|
|
(defun t19b ()
|
|
"Use the menu class, draw-menu and select functions."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((choices '("Choice 0" "Choice 11" "Choice 222" "Choice 3333" "Choice 44444" "Choice 555555" "Choice 6666666"))
|
|
(menu (make-instance 'menu-window :items choices :location (list 0 20) :title "t19b"
|
|
:cyclic-selection t :draw-border t :enable-function-keys t)))
|
|
(let ((result (select menu)))
|
|
(format scr "You chose ~A" result)
|
|
(touch scr)
|
|
(refresh scr)
|
|
(get-char scr))
|
|
(close menu))))
|
|
|
|
(defun t19b2 ()
|
|
"Use the select function with independent windows and menus"
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((items1 '("Choice 0" "Choice 11" :choice22 "Choice 3333" "Choice 44444" "Choice 555555"
|
|
"Choice 6666666" "Choice 7" "Choice 88" "Choice 999"))
|
|
(menu1 (make-instance 'menu :items items1 :name "sub-menu 1" :max-item-length 50 :menu-location (list 5 10)))
|
|
(items2 (list "Item 0" menu1 "Item 1" "Item 2" "Item 3" "Item 4" "Item 5" "Item 6" "Item 7" "Item 8" "Item 9"))
|
|
(menu2 (make-instance 'menu :items items2 :name "sub-menu 2" :max-item-length 50 :menu-location (list 5 10)))
|
|
(items3 (list "Item 00" menu2 "Item 01" "Item 02" "Item 03" "Item 04" "Item 5" "Item 6" "Item 7" "Item 8" "Item 9"))
|
|
(menu3 (make-instance 'menu :items items3 :name "t19b2b" :max-item-length 50 :menu-location (list 5 10))))
|
|
;; associate the same window with all three menus.
|
|
(setf (window menu1) scr
|
|
(window menu2) scr
|
|
(window menu3) scr)
|
|
;; select an item and return it.
|
|
(select menu3))))
|
|
|
|
(defun t19c ()
|
|
"Improved t19b, the menu can be called repeatedly with the key a."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((choices '("Choice 0" "Choice 11" "Choice 222" "Choice 3333" "Choice 44444" "Choice 555555"
|
|
"Choice 6666666" "Choice 7" "Choice 88" "Choice 999"))
|
|
(menu (make-instance 'menu-window :items choices :location (list 0 25) :scrolled-layout (list 6 1)
|
|
:title "t19c" :draw-border t :enable-function-keys t)))
|
|
(event-case (scr event)
|
|
;; "a" draws the menu and enters a new menu-only event loop
|
|
(#\a (let ((result (select menu)))
|
|
(format scr "You chose ~A~%" result)
|
|
;; we have to touch scr in order to make the menu disappear.
|
|
(touch scr)
|
|
(refresh scr)))
|
|
(#\q (return-from event-case)))
|
|
(close menu))))
|
|
|
|
(defun t19c2 ()
|
|
"Test the menu-item class for submenus."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((fun1 (make-instance 'menu-item :name "fun1" :value (lambda () (clear scr))))
|
|
(choices (list "Choice 0" 'choice11 fun1 "Choice 222" "Choice 3333" "Choice 44444" "Choice 555555"
|
|
"Choice 6666666" "Choice 7" "Choice 88" "Choice 999"))
|
|
;; First, create a menu
|
|
;; TODO: how to determine the location of the sub-menu depending on the parent menu?
|
|
(sub-menu2 (make-instance 'menu-window
|
|
:items choices ;; here we only have strings
|
|
:location (list 2 57) :scrolled-layout (list 6 1)
|
|
;; for hex triplets to work, we need to start sbcl with:TERM=xterm-256color lisp.sh
|
|
;;:color-pair (list :black #x666666)
|
|
:bgcolor :red
|
|
:name "submenu2" :title t :draw-border t :enable-function-keys t :visible nil))
|
|
;; then add that sub-menu menu as an item to the next menu, and so on.
|
|
(sub-menu1 (make-instance 'menu-window
|
|
:items (cons sub-menu2 choices) ;; first item is a submenu
|
|
:location (list 1 41) :scrolled-layout (list 6 1)
|
|
;;:color-pair (list :black #x999999)
|
|
:fgcolor :green
|
|
:name "submenu1" :title nil :draw-border t :enable-function-keys t :visible nil))
|
|
;; finally, create the main menu containing sub-menu1 as an item
|
|
(menu (make-instance 'menu-window
|
|
:items (cons sub-menu1 choices) ;; first item is a submenu
|
|
:location (list 0 25) :scrolled-layout (list 6 1)
|
|
;;:color-pair (list :black #xcccccc)
|
|
:fgcolor :blue :bgcolor :yellow
|
|
:name "menu" :title nil :draw-border nil :enable-function-keys t :visible nil)))
|
|
;; add the menus and submenus to a window stack
|
|
;; scr has to be stacked too so we can make the menus disappear.
|
|
(setf (stackedp scr) t
|
|
(stackedp menu) t
|
|
(stackedp sub-menu1) t
|
|
(stackedp sub-menu2) t)
|
|
|
|
(setf (background scr) (make-instance 'complex-char :simple-char :board :color-pair (list :black :white)))
|
|
|
|
(refresh-stack)
|
|
(event-case (scr event)
|
|
;; "a" draws the menu and enters a new menu-only event loop by calling select
|
|
(#\a (let ((result (select menu)))
|
|
(format scr "You chose ~A~%" result)
|
|
(format scr "~A~%" (color-pair menu))
|
|
(format scr "Stack ~A~%" (length de.anvi.croatoan::*window-stack*))
|
|
(refresh-stack) ))
|
|
;; TODO: doesnt repaint the border, because the border already has attributes.
|
|
;; setting a background doesnt change existing attributes, only existing backgrounds.
|
|
(#\b (setf (color-pair menu) (list :red :black)))
|
|
;; "q" exits the function and all menus and submenus.
|
|
(#\q (return-from event-case)))
|
|
(close menu)
|
|
(close sub-menu1)
|
|
(close sub-menu2))))
|
|
|
|
(defun t19c3 ()
|
|
"Menu with checkbox items."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((choices '("Choice 0" "Choice 11" "Choice 222" "Choice 3333" "Choice 44444" "Choice 555555"
|
|
"Choice 6666666" "Choice 7" "Choice 88" "Choice 999"))
|
|
(menu (make-instance 'menu-window :items choices :location (list 0 25) :scrolled-layout (list 6 1)
|
|
:title "t19c" :draw-border t :enable-function-keys t
|
|
:menu-type :checklist
|
|
:max-item-length 20
|
|
:color-pair (list :yellow :red) )))
|
|
(event-case (scr event)
|
|
;; "a" draws the menu and enters a new menu-only event loop
|
|
(#\a (let ((result (select menu)))
|
|
(format scr "You chose ~A~%" (mapcar #'value result))
|
|
;; we have to touch scr in order to make the menu disappear.
|
|
(touch scr)
|
|
(refresh scr)))
|
|
(#\q (return-from event-case)))
|
|
(close menu))))
|
|
|
|
(defun t19d ()
|
|
"Use the arrow keys to pick a value from an 2D array menu, given as a layout parameter."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((items (loop for i below 200 collect (format nil "Item ~A" i)))
|
|
(menu (make-instance 'menu-window
|
|
:items items :location (list 0 0) :layout (list 20 10) :scrolled-layout (list 10 4)
|
|
:cyclic-selection nil :max-item-length 9 :title "t19d" :draw-border t :enable-function-keys t)))
|
|
(event-case (scr event)
|
|
;; "a" draws the menu and enters a new menu-only event loop
|
|
(#\a (let ((result (select menu)))
|
|
(format scr "You chose ~A~%" result)
|
|
;; we have to touch scr in order to make the menu disappear.
|
|
(touch scr)
|
|
(refresh scr)))
|
|
(#\q (return-from event-case)))
|
|
(close menu))))
|
|
|
|
(defun t19e ()
|
|
"A one-line menu without a title and border resembling a menu bar."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((items '("Item 0" "Item 1" "Item 2" "Item 3" "Item 4" "Item 5" "Item 6" "Item 7" "Item 8" "Item 9"))
|
|
(menu (make-instance 'menu-window :input-blocking t :items items :location (list 0 0)
|
|
:layout (list 1 (length items))
|
|
:scrolled-layout (list 1 6)
|
|
;;:color-pair (list :black :yellow)
|
|
:max-item-length 10 :width (width scr) :draw-border t :enable-function-keys t)))
|
|
;; start the output below the menu
|
|
(move scr 4 0)
|
|
;; exit the infinite loop by exiting the menu with q.
|
|
(loop named menu-case
|
|
do
|
|
(let ((result (select menu)))
|
|
(unless result (return-from menu-case))
|
|
(format scr "You chose ~A~%" result)
|
|
(refresh scr)))
|
|
(close menu))))
|
|
|
|
(defun t19e2 ()
|
|
"A menu bar and submenus."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((items1 (list "Choice 0" "Choice11" "Choice 222" "Choice 3333" "Choice 44444" "Choice 555555"
|
|
"Choice 6666666" "Choice 7" "Choice 88" "Choice 999"))
|
|
(sub-menu1 (make-instance 'menu-window :items items1 :location (list 2 30) :scrolled-layout (list 6 1)
|
|
:title nil :name "submenu1" :draw-border t :enable-function-keys t :visible nil :menu-type :selection))
|
|
(sub-menu2 (make-instance 'menu-window :items items1 :location (list 2 45) :scrolled-layout (list 6 1)
|
|
:title nil :name "submenu2" :draw-border t :enable-function-keys t :visible nil :menu-type :checklist))
|
|
(fun1 (make-instance 'menu-item :name "fun1" :value (lambda () (clear scr))))
|
|
(items2 (list "Item 0" fun1 sub-menu1 sub-menu2))
|
|
(menu (make-instance 'menu-window :input-blocking t :items items2 :location (list 0 0) :layout (list 1 (length items2))
|
|
:max-item-length 15 :width (width scr) :draw-border t :enable-function-keys t)))
|
|
(setf (stackedp scr) t
|
|
(stackedp menu) t
|
|
(stackedp sub-menu1) t
|
|
(stackedp sub-menu2) t)
|
|
(move scr 4 0) ;; start the output at line 4, below the menu bar.
|
|
(refresh-stack)
|
|
(loop named menu-case
|
|
do (let ((result (select menu)))
|
|
(unless result (return-from menu-case))
|
|
(format scr "You chose ~A~%" result)
|
|
(refresh-stack)))
|
|
(close menu)
|
|
(close sub-menu1)
|
|
(close sub-menu2) )))
|
|
|
|
(defun t19f ()
|
|
"A more fancy version of t19a, a yes-no dialog using the class dialog-window."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((items (list "Yes" "No" "OK" 'cancel))
|
|
(menu (make-instance 'dialog-window
|
|
:input-blocking t
|
|
:items items
|
|
;; when center is t for a dialog window, we do not need to pass the location explicitely.
|
|
;;:location (list 5 15)
|
|
:center t
|
|
:layout (list 1 4)
|
|
:max-item-length 12
|
|
:current-item-mark "> "
|
|
:color-pair (list :yellow :red)
|
|
:width 60
|
|
:draw-border t
|
|
:enable-function-keys t
|
|
:name "t19f"
|
|
:title t
|
|
;; if the title is given as a string, it overrides the default title = name
|
|
;; :title "this is a selection dialog"
|
|
:message-height 2
|
|
:message-text "Press <- or -> to choose. Enter to confirm choice.~%Press q to exit.")))
|
|
|
|
(setf (background scr) (make-instance 'complex-char :simple-char :board :color-pair (list :black :white)))
|
|
|
|
(refresh scr)
|
|
(loop named menu-case
|
|
do (let ((result (select menu)))
|
|
(unless result (return-from menu-case))
|
|
(format scr "You chose ~A~%" result)
|
|
(refresh scr)))
|
|
(close menu))))
|
|
|
|
(defun t19g ()
|
|
"A checkbox dialog."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t :use-terminal-colors t)
|
|
(let* ((items (list "Yes" "No" "OK" 'cancel "Maybe"))
|
|
(menu (make-instance 'dialog-window
|
|
:input-blocking t
|
|
:items items
|
|
;; when a menu or dialog type is a checklist, items can be checked and unchecked with x/space.
|
|
:menu-type :checklist
|
|
;; a dialog window can be automatically centered in the terminal window.
|
|
:center t
|
|
:layout (list 5 1)
|
|
;; TODO: the size of the dialog window should depend on scrolled layout when it is defined.
|
|
;;:scrolled-layout (list 3 1)
|
|
:max-item-length 56
|
|
:color-pair (list :yellow :red)
|
|
;; we do not need an item mark in a checklist
|
|
:current-item-mark ""
|
|
:width 60 :draw-border t :enable-function-keys t
|
|
:title "this is a checkbox dialog"
|
|
:message-height 2
|
|
:message-text "Press <- or -> to choose. Enter to confirm choice.~%Press q to exit.")))
|
|
;; #x2592 = :board
|
|
(setf (background scr) (make-instance 'complex-char :simple-char #x2592 :color-pair (list :white :black)))
|
|
|
|
(refresh scr)
|
|
(loop named menu-case
|
|
do (let ((result (select menu)))
|
|
;; TODO: returning an empty list exits the loop.
|
|
(unless result (return-from menu-case))
|
|
(format scr "You chose ~A~%" (mapcar #'value result))
|
|
(refresh scr)))
|
|
(close menu))))
|
|
|
|
;; Passing the color attribute directly to a character.
|
|
(defun t20 ()
|
|
"Display a randomly created carpet of the seven default ANSI colors, except for black."
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t :cursor-visible nil)
|
|
(let ((colors '(:red :green :yellow :blue :magenta :cyan :white)))
|
|
(event-case (scr event)
|
|
(#\q (return-from event-case))
|
|
((nil)
|
|
(sleep 0.01)
|
|
(echo scr #\space
|
|
:y (random (height scr))
|
|
:x (random (width scr))
|
|
:color-pair (list nil (nth (random 7) colors))))))))
|
|
|
|
(defun t20a ()
|
|
"Display a randomly created carpet of the 16 default xterm colors, except for black.
|
|
|
|
This only works with TERM=xterm-256color in xterm and gnome-terminal."
|
|
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t :cursor-visible nil)
|
|
(let ((colors '( :maroon :green :olive :navy :purple :teal :silver
|
|
:gray :red :lime :yellow :blue :magenta :cyan :white)))
|
|
(bind scr #\q 'exit-event-loop)
|
|
(bind scr nil
|
|
(lambda (win e)
|
|
(echo win #\space
|
|
:y (random (height win))
|
|
:x (random (width win))
|
|
:bgcolor (nth (random 15) colors))))
|
|
(setf (frame-rate scr) 1000)
|
|
(run-event-loop scr))))
|
|
|
|
;; it is just a coincidence that "echo-char" works here.
|
|
;; echo-char is a chtype-function, and chtype allows only 1 byte for color pairs, which means 256 color pairs.
|
|
;; it works only because the foreground color is always black in the example.
|
|
;; echo-wide-char has to be used.
|
|
(defun t20b ()
|
|
"Display the 256 supported colors. This only works with TERM=xterm-256color in xterm and gnome-terminal."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-colors t :cursor-visible nil)
|
|
;; 0-15: 8 ANSI colors and 8 bold ANSI colors
|
|
;; only those first 16 colors are named.
|
|
;; note that the naming of the first 8 ANSI colors is not the same as the first 8 xterm colors.
|
|
(loop for i from 0 to 7 do
|
|
(loop for j from 0 to 1 do
|
|
(loop for k from 0 to 2 do
|
|
(echo scr #\space
|
|
:y j
|
|
:x (+ (* i 3) k)
|
|
:color-pair (list :black
|
|
(list :number (+ i (* j 8))))) )))
|
|
;; 16-231: 6x6x6 color cube
|
|
(loop for n from 0 to 1 do
|
|
(loop
|
|
for m from 0 to 2
|
|
for a1 = (+ 16 (* m 36))
|
|
for a2 = (+ 16 (* m 36) 5)
|
|
for a3 = (* m 19)
|
|
do (loop for i from a1 to a2 do
|
|
(loop for j from 0 to 5 do
|
|
(loop for k from 0 to 2 do
|
|
(echo scr #\space
|
|
:y (+ 3 j (* n 7))
|
|
:x (+ (* (- i a1) 3) k a3)
|
|
:color-pair (list :black
|
|
(list :number (+ (* n 108) i (* j 6)))) ))))))
|
|
;; 232-255: 24 shades of gray, without black and white
|
|
(loop for i from 232 to 255 do
|
|
(loop for k from 0 to 2 do
|
|
(echo scr #\space
|
|
:y 17
|
|
:x (+ (* (- i 232) 3) k)
|
|
:color-pair (list :black
|
|
(list :number i)))))
|
|
(get-char scr)))
|
|
|
|
(defun t20c ()
|
|
"Display the 256 supported colors. This only works with TERM=xterm-256color in xterm and gnome-terminal."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :enable-colors t :cursor-visible nil)
|
|
;; 0-15: 8 ANSI colors and 8 bold ANSI colors
|
|
(loop for i from 0 to 7 do
|
|
(loop for j from 0 to 1 do
|
|
(loop for k from 0 to 2 do
|
|
(add scr #\space
|
|
:y j
|
|
:x (+ (* i 3) k)
|
|
:bgcolor (list :number (+ i (* j 8))))) ))
|
|
;; 16-231: 6x6x6 color cube
|
|
(loop for n from 0 to 1 do
|
|
(loop
|
|
for m from 0 to 2
|
|
for a1 = (+ 16 (* m 36))
|
|
for a2 = (+ 16 (* m 36) 5)
|
|
for a3 = (* m 19)
|
|
do (loop for i from a1 to a2 do
|
|
(loop for j from 0 to 5 do
|
|
(loop for k from 0 to 2 do
|
|
(add scr #\space
|
|
:y (+ 3 j (* n 7))
|
|
:x (+ (* (- i a1) 3) k a3)
|
|
:bgcolor (list :number (+ (* n 108) i (* j 6)))) )))))
|
|
;; 232-255: 24 shades of gray, without black and white
|
|
(loop for i from 232 to 255 do
|
|
(loop for k from 0 to 2 do
|
|
(add scr #\space
|
|
:y 17
|
|
:x (+ (* (- i 232) 3) k)
|
|
:bgcolor (list :number i))))
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; Tests for insert-char, insert-string, extract-char.
|
|
(defun t21 ()
|
|
(with-screen (scr :cursor-visible nil)
|
|
(move scr 0 0) (add-char scr #\a)
|
|
;; overwrite b over a
|
|
(move scr 0 0)
|
|
(add-char scr
|
|
(make-instance 'complex-char :simple-char #\b :attributes (list :bold :underline) :color-pair '(:blue :yellow)))
|
|
(echo scr
|
|
(make-instance 'complex-char :simple-char #\e :attributes (list :underline) :color-pair '(:blue :yellow)))
|
|
;; insert pi before b
|
|
(move scr 0 0) (insert-char scr :pi :color-pair '(:yellow :red))
|
|
;; insert d before pi
|
|
(move scr 0 0) (insert-string scr "d ")
|
|
;; change the attributes of the d
|
|
(move scr 0 0) (change-attributes scr 1 '(:underline) :color-pair '(:green :black))
|
|
;; extract the complex d from the window, then print its properties.
|
|
(let ((e (extract-char scr)))
|
|
(move scr 1 0)
|
|
;; format uses print-object specialized on complex-chars
|
|
(format scr "~S~%~S ~S ~S" e (simple-char e) (attributes e) (color-pair e))
|
|
;; print back the extracted char
|
|
(move scr 3 0)
|
|
(add-char scr (simple-char e) :attributes (attributes e) :color-pair (color-pair e))
|
|
;; directly print the complex char
|
|
(add-char scr e :y 5 :x 10 :n -1)
|
|
;; print strings with attributes and colors
|
|
;; attributes dont work (yet) when a long string gets wrapped around the last column.
|
|
(add-string scr "string with attributes" :y 11 :x 10 :attributes '(:underline) :color-pair '(:black :green))
|
|
;; test adding both chars and strings with a single wrapper routine.
|
|
(add scr #\a :y 13 :x 0 :attributes '(:underline) :color-pair '(:yellow :red) :n -1)
|
|
(add scr "string with attributes" :y 15 :x 0 :n 11 :attributes '(:underline :bold) :color-pair '(:yellow :green)))
|
|
;; test print-object specialisation on complex-string
|
|
(let ((str (make-instance 'complex-string :string "complex-string" :color-pair '(:blue :white) :attributes '(:underline))))
|
|
(format scr "~%~S~%" str)
|
|
(add-string scr str :y 18 :x 73 :n -1)
|
|
(add scr str :y 19 :x 70 :n -1))
|
|
;; extract the first line as a complex-string, then reprint it at line 22
|
|
(let ((str (extract-complex-string scr :y 0 :x 0 :n 4)))
|
|
(move scr 22 1)
|
|
(add scr str :n -1))
|
|
;; extract the first line as a simple string, then reprint it at line 23
|
|
(let ((str (extract-string scr :y 0 :x 0 :n 5)))
|
|
(move scr 23 1)
|
|
(add scr str))
|
|
(refresh scr)
|
|
(get-char scr)))
|
|
|
|
;; temporarily end the main screen, write something to the repl, and then return to the screen.
|
|
;; the predicate closed-p can be used to check whether the screen has been temporarily closed.
|
|
(defun t22 ()
|
|
(let ((scr (make-instance 'screen :input-blocking t :input-echoing nil)))
|
|
(unwind-protect
|
|
(progn
|
|
(clear scr)
|
|
;; should yield NIL, since we didnt endwin yet
|
|
(format scr "1. screen before ending: ~A~%" (closed-p scr))
|
|
(get-char scr)
|
|
|
|
(close scr)
|
|
|
|
;; this shouldnt be visible, but it is visible after the later refresh
|
|
;; obviously ncurses doesnt destroy the screen window after it is closed
|
|
(format scr "2. screen after ending, we dont see it till after the refresh: ~A~%" (closed-p scr))
|
|
|
|
;; should yield T, because we closed the screen
|
|
(format t "3. in the repl, after ending the screen: ~A~%" (closed-p scr))
|
|
(force-output *standard-output*)
|
|
(sleep 5)
|
|
|
|
(refresh scr)
|
|
;; should yield NIL, since we refreshed
|
|
(format scr "4. screen after refreshing: ~A~%" (closed-p scr))
|
|
|
|
(get-char scr))
|
|
(close scr))))
|
|
|
|
(defun t23 ()
|
|
"Use save-excursion to return the cursor to its initial location."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible t :enable-colors t)
|
|
(move scr 0 0)
|
|
(princ "1. hello" scr)
|
|
(save-excursion scr
|
|
(move scr 5 5)
|
|
(princ "2. there" scr))
|
|
(princ "3. dear john" scr)
|
|
(get-char scr)))
|
|
|
|
(defun t24 ()
|
|
"Test usage of insert-line and delete-line."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible t :enable-colors t)
|
|
(loop for i from 0 to (- (height scr) 1)
|
|
do
|
|
(move scr i 0)
|
|
(format scr "~A" i))
|
|
(refresh scr)
|
|
(event-case (scr event)
|
|
((:up :down) (move-direction scr event) (refresh scr))
|
|
(#\d (delete-line scr) (refresh scr))
|
|
(#\i (insert-line scr) (refresh scr))
|
|
(#\q (return-from event-case)))
|
|
(get-char scr)))
|
|
|
|
(defun t25 ()
|
|
"Test initialisation and refreshing of pads and sub-pads."
|
|
(with-screen (scr :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(let* ((p (make-instance 'pad :height 100 :width 100))
|
|
(sp (make-instance 'sub-pad :parent p :height 5 :width 10 :location (list 10 10))))
|
|
|
|
;; populate the pad with numbers.
|
|
(loop for j from 0 to 99
|
|
do (loop for i from 0 to 99
|
|
do
|
|
(move p j i)
|
|
(format p "~D" (mod (* i j) 10))))
|
|
|
|
;; populate the sub-pad with letters.
|
|
(loop for j from 0 to 4
|
|
do (loop for i from 0 to 9
|
|
do
|
|
(move sp j i)
|
|
(add-char sp #\X) ))
|
|
|
|
;; we have to modify the sub-window attributes first because apparently once
|
|
;; chars have attributes, they can not be changed by subsequent background changes.
|
|
(setf (background sp) (make-instance 'complex-char :color-pair '(:white :red))
|
|
(background p) (make-instance 'complex-char :color-pair '(:green :white)))
|
|
|
|
(let ((pad-min-y 0)
|
|
(pad-min-x 0)
|
|
(screen-min-y 0)
|
|
(screen-min-x 0)
|
|
(screen-max-y 5)
|
|
(screen-max-x 10))
|
|
|
|
;; the background screen has to be touched and refreshed on every move,
|
|
;; otherwise we will see parts of the previously displayed pad still there.
|
|
(touch scr)
|
|
(refresh scr)
|
|
(refresh p pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)
|
|
|
|
(event-case (scr event)
|
|
(:up (decf pad-min-y) (decf screen-min-y) (decf screen-max-y) (touch scr) (refresh scr)
|
|
(refresh p pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x))
|
|
(:down (incf pad-min-y) (incf screen-min-y) (incf screen-max-y) (touch scr) (refresh scr)
|
|
(refresh p pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x))
|
|
(:left (decf pad-min-x) (decf screen-min-x) (decf screen-max-x) (touch scr) (refresh scr)
|
|
(refresh p pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x))
|
|
(:right (incf pad-min-x) (incf screen-min-x) (incf screen-max-x) (touch scr) (refresh scr)
|
|
(refresh p pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x))
|
|
(#\q (return-from event-case))
|
|
(otherwise nil)))
|
|
|
|
(close p)
|
|
(close sp))))
|
|
|
|
(defun t26 ()
|
|
"Test accessors of window and cursor locations."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible t :enable-colors t :stacked t)
|
|
(let ((win (make-instance 'window :height 5 :width 20 :location (list 0 0) :stacked t)))
|
|
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:white :red))
|
|
(background win) (make-instance 'complex-char :color-pair '(:black :yellow)))
|
|
|
|
(refresh-stack)
|
|
(get-char scr)
|
|
|
|
(setf (location win) (list 2 4))
|
|
(refresh-stack)
|
|
(get-char scr)
|
|
|
|
(setf (location-y win) 4)
|
|
(refresh-stack)
|
|
(get-char scr)
|
|
|
|
(setf (location-x win) 8)
|
|
(refresh-stack)
|
|
(get-char scr)
|
|
|
|
(setf (cursor-position win) (list 0 0))
|
|
(princ "a" win)
|
|
(refresh-stack)
|
|
(get-char scr)
|
|
|
|
(setf (cursor-position-y win) 2)
|
|
(princ "b" win)
|
|
(refresh-stack)
|
|
(get-char scr)
|
|
|
|
(setf (cursor-position-x win) 4)
|
|
(princ "c" win)
|
|
(refresh-stack)
|
|
(get-char scr))))
|
|
|
|
(defun t27 ()
|
|
"Use run-event-loop and bind instead of event-case to handle keyboard events."
|
|
(with-screen (scr :input-echoing nil :input-blocking t)
|
|
|
|
;; q ends the loop.
|
|
(bind scr #\q 'exit-event-loop)
|
|
|
|
;; The event handler function has to take two arguments, the window and the event.
|
|
|
|
;; a and s add a string to the window.
|
|
(bind scr #\a (lambda (win event) (format win "Hello there.~%")))
|
|
(bind scr #\s (lambda (win event) (format win "Dear John.~%")))
|
|
|
|
;; d clears the window.
|
|
(bind scr #\d (lambda (win event) (clear win)))
|
|
|
|
;; u unbinds a
|
|
(bind scr #\u (lambda (win event) (unbind scr #\a)))
|
|
|
|
(clear scr)
|
|
(add-string scr "Type a, s or d. Type q to quit.")
|
|
(refresh scr)
|
|
|
|
(run-event-loop scr)))
|
|
|
|
(defun t28-hello (win event)
|
|
(format win "Hello there ~A.~%" event))
|
|
|
|
(defun t28-clear (win event)
|
|
(declare (ignore event))
|
|
(clear win))
|
|
|
|
(defparameter *t28-map*
|
|
(make-instance 'keymap :bindings-plist
|
|
(list
|
|
#\q 'exit-event-loop
|
|
#\a 't28-hello
|
|
#\d 't28-clear))
|
|
"Define a keymap separately and then set it as a window's event handlers before running the event loop.")
|
|
|
|
(defun t28 ()
|
|
"Use run-event-loop and a pre-defined event handler alist. Use a default handler."
|
|
(with-screen (scr :input-echoing nil :input-blocking t)
|
|
;; add the separately defined keymap to the window object.
|
|
(setf (keymap scr) *t28-map*)
|
|
|
|
;; add another event handler
|
|
(bind scr #\s (lambda (win event) (format win "Dear John ~A~%" event)))
|
|
|
|
;; t is the default handler for all events without defined handlers.
|
|
;; The default event handler should not be used to handle the nil event when input-blocking is nil
|
|
(bind *t28-map* t (lambda (win event) (format win "Default event handler ~A~%" event)))
|
|
|
|
(clear scr)
|
|
(add-string scr "Type a, s or d. Type q to quit.")
|
|
(refresh scr)
|
|
|
|
(run-event-loop scr)))
|
|
|
|
(defun t28a ()
|
|
"Test the use of the run-event-loop with non-blocking events."
|
|
(with-screen (scr :input-echoing nil :input-blocking nil)
|
|
|
|
(setf (keymap scr) *t28-map*)
|
|
|
|
(bind scr #\s (lambda (win event) (format win "Dear John ~A~%" event)))
|
|
|
|
;; The handler function for the nil event will be called between keyboard events.
|
|
(bind scr nil (lambda (win event) (format win "sleep ~A " event)))
|
|
|
|
(clear scr)
|
|
(add-string scr "Type a, s or d. Type q to quit.")
|
|
(refresh scr)
|
|
|
|
;; Set the rate at which the nil event will be handled in fps (frames per second).
|
|
;; For the same effect as frame-rate of 1, you can set :input-blocking to 1000 ms.
|
|
(setf (frame-rate scr) 1)
|
|
|
|
(run-event-loop scr)))
|
|
|
|
(defun draw-t29-shapes (window shapes &optional squarify)
|
|
"Draw a list of shapes to window."
|
|
(clear window)
|
|
(unless (listp shapes) (setf shapes (list shapes)))
|
|
(dolist (s shapes)
|
|
(draw-shape window s squarify)))
|
|
|
|
;; Assumes an 80x24 terminal
|
|
(defun t29 ()
|
|
"Draw an ASCII-art tree to illustrate the use of shapes."
|
|
(with-screen (scr :input-blocking t :enable-colors t :input-echoing nil :cursor-visible nil :input-buffering nil)
|
|
(let* ((leaf-char (make-instance 'complex-char :simple-char #\O :color-pair '(:green :black)))
|
|
(trunk-char (make-instance 'complex-char :simple-char #\H :color-pair '(:white :black)))
|
|
(ground-char (make-instance 'complex-char :simple-char #\i :color-pair '(:green :black)))
|
|
(sun-char (make-instance 'complex-char :simple-char #\o :color-pair '(:yellow :black)))
|
|
|
|
(tree-trunk (rectangle 19 27 5 4 :filled t :char trunk-char))
|
|
(upper-crown (triangle 4 29 12 22 12 35 :filled t :char leaf-char))
|
|
(lower-crown (triangle 8 29 18 20 18 37 :filled t :char leaf-char))
|
|
(tree-crown (merge-shapes upper-crown lower-crown))
|
|
(ground (line 23 0 23 80 :char ground-char))
|
|
(sun (circle 5 6 2 :char sun-char :filled t)))
|
|
|
|
(draw-t29-shapes scr (list tree-trunk tree-crown ground sun) t)
|
|
;; wait for a keypress
|
|
(get-char scr)
|
|
|
|
;; redraw with squarify nil
|
|
(draw-t29-shapes scr (list tree-trunk tree-crown ground sun) nil)
|
|
(get-char scr) )))
|
|
|
|
(defun t30 ()
|
|
"Test color pair completion for style parameters."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(with-windows ((w1 :height 5 :width 5 :location '(0 0))
|
|
(w2 :height 5 :width 5 :location '(0 5))
|
|
(w3 :height 5 :width 5 :location '(0 10)))
|
|
(setf (background w1) (make-instance 'complex-char :color-pair '(:black :cyan))
|
|
(background w2) (make-instance 'complex-char :color-pair '(:black :magenta))
|
|
(background w3) (make-instance 'complex-char :color-pair '(:black :white)))
|
|
;; the character style contains only one color
|
|
;; the fg/bg of the target window is used to complete the color pair.
|
|
(let ((s1 (list :attributes '(:bold) :fgcolor :red))
|
|
(s2 (list :attributes '(:bold) :bgcolor :yellow)))
|
|
(add w1 #\a :y 2 :x 2 :style s1)
|
|
(add w2 #\b :y 2 :x 2 :style s1)
|
|
(add w3 #\c :y 2 :x 2 :style s2))
|
|
(refresh w1)
|
|
(refresh w2)
|
|
(refresh w3)
|
|
(get-char w1))))
|
|
|
|
;; the ncurses window background property and the color-pair apparently set the same internal variable
|
|
;; setting one to nil sets the other to nil.
|
|
;; croatoan does not do that. here, the window color if it is set overrides the background property.
|
|
;; if a color parameter is directly passed, it overrides both the window color-pair and background.
|
|
(defun t31 ()
|
|
"Test color pair completion for fgcolor and bgcolor parameters."
|
|
(with-screen (scr :input-echoing nil :input-blocking t :cursor-visible nil :enable-colors t)
|
|
(add-string scr "default colors" :y 0 :x 0) (refresh scr) (get-char scr)
|
|
|
|
(setf (color-pair scr) '(:yellow :blue))
|
|
(add-string scr "color-pair yellow on blue" :y 1 :x 0) (refresh scr) (get-char scr)
|
|
|
|
;; text is not printed red on white because the color-pair overrides the background color.
|
|
(setf (background scr nil) (make-instance 'complex-char :simple-char #\- :color-pair '(:red :white)))
|
|
(add-string scr " background red on white" :y 2 :x 0) (refresh scr) (get-char scr)
|
|
|
|
(setf (color-pair scr) '(:blue :yellow))
|
|
(add-string scr "color-pair blue on yellow" :y 3 :x 0) (refresh scr) (get-char scr)
|
|
|
|
;; text is not printed red on white because the color-pair overrides the background color.
|
|
(setf (background scr nil) (make-instance 'complex-char :simple-char #\space :color-pair '(:white :red)))
|
|
(add-string scr " background white on red" :y 4 :x 0) (refresh scr) (get-char scr)
|
|
|
|
;; now when we set the color-pair to nil, the text is printed in background colors.
|
|
(setf (color-pair scr) nil)
|
|
(add-string scr "color-pair nil" :y 5 :x 0) (refresh scr) (get-char scr)
|
|
|
|
;; when we then also set the background to nil, the text is displayed in default white on black.
|
|
(setf (background scr nil) nil)
|
|
(add-string scr " background nil" :y 6 :x 0) (refresh scr) (get-char scr)
|
|
|
|
(add-string scr "fgcolor red bgcolor cyan" :y 7 :x 0 :fgcolor :red :bgcolor :cyan) (refresh scr) (get-char scr)
|
|
(add-string scr "fgcolor red (bgcolor default)" :y 8 :x 0 :fgcolor :red) (refresh scr) (get-char scr)
|
|
(add-string scr "(fgcolor default) bgcolor cyan" :y 9 :x 0 :bgcolor :cyan) (refresh scr) (get-char scr)
|
|
|
|
(setf (color-pair scr) '(:yellow :blue))
|
|
;; the color parameters override the color-pair window property
|
|
(add-string scr "color pair yellow on blue, then fgcolor red" :y 10 :x 0 :fgcolor :red) (refresh scr) (get-char scr)
|
|
(add-string scr "color pair yellow on blue, then bgcolor cyan" :y 11 :x 0 :bgcolor :cyan) (refresh scr) (get-char scr)
|
|
|
|
;; the background is ignored because color-pair is set
|
|
(setf (background scr nil) (make-instance 'complex-char :simple-char #\. :color-pair '(:white :red)))
|
|
(add-string scr "fgcolor red" :y 12 :x 0 :fgcolor :red) (refresh scr) (get-char scr)
|
|
(add-string scr "bgcolor cyan" :y 13 :x 0 :bgcolor :cyan) (refresh scr) (get-char scr)
|
|
|
|
;; when the pair is set to nil, the background is used again.
|
|
(setf (color-pair scr) nil)
|
|
(add-string scr "fgcolor magenta" :y 14 :x 0 :fgcolor :magenta) (refresh scr) (get-char scr)
|
|
(add-string scr "bgcolor cyan" :y 15 :x 0 :bgcolor :cyan) (refresh scr) (get-char scr) ))
|
|
|