Tmux etc

sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/test/ncurses.lisp

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