137 lines
4.2 KiB
Common Lisp
137 lines
4.2 KiB
Common Lisp
(in-package :de.anvi.croatoan.test)
|
|
|
|
;; here the ncurses primitive bindings should be tested.
|
|
|
|
(defun nctest ()
|
|
(%initscr)
|
|
(%mvaddstr 0 0 "hello there")
|
|
(%mvaddstr 7 7 "hello there")
|
|
(%mvaddstr 15 15 "hello there")
|
|
(%refresh)
|
|
(%getch)
|
|
(%endwin))
|
|
|
|
(defun nctest2 ()
|
|
(let ((scr (%initscr)))
|
|
(%mvaddstr 0 0 "hello there")
|
|
|
|
(%wattron scr #x00020000)
|
|
(%mvaddstr 7 7 "hello there")
|
|
(%wattroff scr #x00020000)
|
|
|
|
(%wattron scr #x80000000)
|
|
(%mvaddstr 15 15 "hello there")
|
|
(%wattroff scr #x80000000)
|
|
|
|
(%wrefresh scr)
|
|
(%wgetch scr)
|
|
(%endwin)))
|
|
|
|
(defun nctest3 ()
|
|
(%initscr)
|
|
(%start-color)
|
|
(%init-pair 1 1 3) ; red(1) on yellow(3)
|
|
|
|
;; extract and display the foreground and background color numbers from the pair number
|
|
(with-foreign-objects ((ptr-f :short)
|
|
(ptr-b :short))
|
|
(%pair-content 1 ptr-f ptr-b)
|
|
(%mvaddstr 0 0 (format nil "1 ~A, 3 ~A" (mem-aref ptr-f :short) (mem-aref ptr-b :short))))
|
|
|
|
;; extract and display the RGB contents of predefined color no. 3 (yellow).
|
|
(with-foreign-objects ((ptr-r :short)
|
|
(ptr-g :short)
|
|
(ptr-b :short))
|
|
(%color-content 3 ptr-r ptr-g ptr-b)
|
|
(%mvaddstr 1 0 (format nil "~3A ~3A ~3A"
|
|
(mem-aref ptr-r :short)
|
|
(mem-aref ptr-g :short)
|
|
(mem-aref ptr-b :short))))
|
|
(%refresh)
|
|
(%getch)
|
|
(%endwin))
|
|
|
|
(defun nctest4 ()
|
|
"Test low-level cchar_t reading and writing.
|
|
|
|
The output is:
|
|
|
|
a rendered cchar_t
|
|
97 code of character #\a
|
|
1 color pair 1
|
|
00020100 attribute underline #x00020000 OR-ed with bit-shifted color pair 1
|
|
|
|
We see that the attr_t slot contains _both_ the attribute _and_ the
|
|
bit-shifted color pair, as if it were a chtype in ABI5.
|
|
|
|
When ABI6 is used, the separate color-pair slot contains the same color
|
|
pair number.
|
|
|
|
The goal is obviously to make the cchar_t usable under both ABI5 and ABI6."
|
|
(let ((scr (%initscr)))
|
|
(%start-color)
|
|
(%init-pair 1 1 3) ; red(1) on yellow(3)
|
|
|
|
(with-foreign-objects ((ptr '(:struct cchar_t))
|
|
(wch 'wchar_t 5))
|
|
(dotimes (i 5) (setf (mem-aref wch 'wchar_t i) 0))
|
|
(setf (mem-aref wch 'wchar_t) (char-code #\a))
|
|
;;(%setcchar ptr wch attr_t color-pair-number (null-pointer))
|
|
(%setcchar ptr wch #x00020000 1 (null-pointer))
|
|
(%wadd-wch scr ptr))
|
|
|
|
;; access the struct slots directly using slot pointers
|
|
(with-foreign-object (ptr '(:struct cchar_t))
|
|
(%mvwin-wch scr 0 0 ptr)
|
|
(let* ((char (mem-aref (foreign-slot-pointer ptr '(:struct cchar_t) 'cchar-chars) 'wchar_t 0))
|
|
(col (foreign-slot-value ptr '(:struct cchar_t) 'cchar-colors))
|
|
(attr (foreign-slot-value ptr '(:struct cchar_t) 'cchar-attr)))
|
|
;; char code
|
|
(%mvaddstr 1 0 (format nil "~A" char))
|
|
;; color pair number
|
|
(%mvaddstr 2 0 (format nil "~A" col))
|
|
;; attr_t in hex.
|
|
(%mvaddstr 3 0 (format nil "~8,'0x" attr))))
|
|
|
|
;; deconstruct cchar_t using getcchar
|
|
(with-foreign-objects ((wcval '(:struct cchar_t))
|
|
(wch 'wchar_t 5)
|
|
(attrs 'attr_t)
|
|
(color-pair :short))
|
|
(dotimes (i 5) (setf (mem-aref wch 'wchar_t i) 0))
|
|
(%mvwin-wch scr 0 0 wcval)
|
|
(%getcchar wcval wch attrs color-pair (null-pointer))
|
|
|
|
(%mvaddstr 5 0 (format nil "~A" (mem-aref wch 'wchar_t 0)))
|
|
(%mvaddstr 6 0 (format nil "~A" (mem-aref color-pair :short)))
|
|
(%mvaddstr 7 0 (format nil "~8,'0x" (mem-aref attrs 'attr_t))))
|
|
|
|
(%refresh)
|
|
(%getch)
|
|
(%endwin)))
|
|
|
|
;; 190302
|
|
(defun nctest5 ()
|
|
(let ((scr (%initscr)))
|
|
(%addstr (format nil "~A~%" "no background "))
|
|
(%wgetch scr)
|
|
|
|
(%wbkgd scr (char-code #\-))
|
|
(%addstr (format nil "~A~%" "background minus "))
|
|
(%wgetch scr)
|
|
|
|
(%wbkgd scr (char-code #\*))
|
|
(%addstr (format nil "~A~%" "background star "))
|
|
(%wgetch scr)
|
|
|
|
(%wbkgd scr (char-code #\-))
|
|
(%addstr (format nil "~A~%" "background minus "))
|
|
(%wgetch scr)
|
|
|
|
(%wbkgd scr (char-code #\+))
|
|
(%addstr (format nil "~A~%" "background plus "))
|
|
(%wgetch scr)
|
|
|
|
(%wrefresh scr)
|
|
(%wgetch scr)
|
|
(%endwin)))
|