Changeset main,52

Timestamp:

11/15/2007 07:43:22 PM (19 years ago)

Author:

David Owen <dsowen@…>

branch-nick:

tui

revision id:

dsowen@fugue88.ws-20071115194322-ilcysmh1p3jqzjao

Message:

Improved ACS translation.
New box and line drawing functions.
Setting active color.

Location:

main

Files:

• cdk_wrapper.c (modified) (2 diffs)
• output.lisp (modified) (7 diffs)

main/cdk_wrapper.c

@@ +1 @@
+#define _XOPEN_SOURCE_EXTENDED
+
+#include <ncursesw/ncurses.h>
 #include <cdk/cdk.h>
 
@@ -26 +29 @@
 
 D(ENTRY, Entry)
+
+#undef D

main/output.lisp

@@ -2 +2 @@
   (:use #:cl #:cffi #:tui-cursor #:tui-window)
   (:export #:background #:add-string #:move-and-add-string
-           #:add-clipped-string))
+           #:add-clipped-string #:border #:hline #:vline #:color))
 
 (in-package #:tui-output)
@@ -8 +8 @@
 
 
-(defctype wchar :int32)                 ; On my 64-bit laptop.
+(defctype wchar_t :int32)               ; On my 64-bit laptop.
 (defctype chtype :uint64)
+(defctype attr_t chtype)
 
 (defcstruct cchar_t
-  (attr chtype)
-  (char wchar :count 5))
+  (attr attr_t)
+  (chars wchar_t :count 5))
 
 
@@ -31 +32 @@
     (destructuring-bind (ch color) pair
       (with-foreign-object (wch 'cchar_t)
-        (with-foreign-slots ((attr char) wch cchar_t)
+        (with-foreign-slots ((attr chars) wch cchar_t)
           (dotimes (i 5)
-            (setf (mem-aref char 'wchar i) 0))
+            (setf (mem-aref chars 'wchar_t i) 0))
           (setf attr (cdk::color-pair color)
-                (mem-aref char 'wchar) (char-code ch)))
+                (mem-aref chars 'wchar_t) (char-code ch)))
         (wbkgrnd (window-pointer window) wch)))))
 
@@ -48 +49 @@
   (let ((ptr (window-pointer window))
         (n (length s)))
-    (with-foreign-object (a 'wchar n)
+    (with-foreign-object (a 'wchar_t n)
       (dotimes (i n)
-        (setf (mem-aref a 'wchar i) (char-code (aref s i))))
+        (setf (mem-aref a 'wchar_t i) (char-code (aref s i))))
       (waddnwstr ptr a n))))
 
@@ -72 +73 @@
 
 
+(defcvar "_nc_wacs" :pointer)
 
-(defcvar ("_nc_wacs" nc-wacs) :pointer :read-only t)
+(defconstant +wacs-table+
+  '(:ul-corner #\l
+    :ll-corner #\m
+    :ur-corner #\k
+    :lr-corner #\j
+    :r-tee #\u
+    :l-tee #\t
+    :b-tee #\v
+    :t-tee #\w
+    :h-line #\q
+    :v-line #\x
+    :plus #\n))
 
-(defun wacs-char (ch)
-  (let ((code (char-code (ecase ch
-                           (:ul-corner #\l)
-                           (:ll-corner #\m)
-                           (:ur-corner #\k)
-                           (:lr-corner #\j)
-                           (:r-tee #\u)
-                           (:l-tee #\t)
-                           (:b-tee #\v)
-                           (:t-tee #\w)
-                           (:h-line #\q)
-                           (:v-line #\x)
-                           (:plus #\n)
-                           (:solid #\0)))))
-    (inc-pointer nc-wacs (* (foreign-type-size 'cchar_t) code))))
+
+(defun translate-wacs (wacs)
+  (etypecase wacs
+    (null (null-pointer))
+    (keyword
+     (mem-aref *-nc-wacs* 'cchar_t (char-code (getf +wacs-table+ wacs))))))
 
 (defcfun "wadd_wchnstr" :int
@@ -97 +101 @@
 
 (defun clear-complex-char (cc)
-  (with-foreign-slots ((attr char) cc cchar_t)
+  (with-foreign-slots ((attr chars) cc cchar_t)
     (setf attr 0)
     (dotimes (i 5 cc)
-      (setf (mem-aref char :uint32 i) 0))))
+      (setf (mem-aref chars :uint32 i) 0))))
 
 (defun extract-complex-char (cc)
   (let ((x (make-sequence '(vector integer) 5 :initial-element 0)))
-    (with-foreign-slots ((char) cc cchar_t)
+    (with-foreign-slots ((chars) cc cchar_t)
       (dotimes (i 5 x)
-        (setf (aref x i) (mem-aref char :uint32 i))))))
+        (setf (aref x i) (mem-aref chars :uint32 i))))))
 
 (defun copy-complex-char (dst src-vector)
-  (with-foreign-slots ((char) dst cchar_t)
+  (with-foreign-slots ((chars) dst cchar_t)
     (dotimes (i 5 dst)
-      (setf (mem-aref char :uint32 i) (aref src-vector i)))))
+      (setf (mem-aref chars :uint32 i) (aref src-vector i)))))
 
 (defun set-complex-char (cc ch)
-  (with-foreign-slots ((char) cc cchar_t)
+  (with-foreign-slots ((chars) cc cchar_t)
     (etypecase ch
       (character
-       (setf (mem-aref char :uint32) (char-code ch)))
+       (setf (mem-aref chars :uint32) (char-code ch)))
       (symbol
-       (copy-complex-char cc (extract-complex-char (wacs-char ch)))))))
+       (copy-complex-char cc (extract-complex-char (translate-wacs ch)))))))
 
 (defun add-complex-string (window s)
@@ -132 +136 @@
 
 
-(defcfun ("box" c-box) :int
+(defcfun "wborder_set" :int
   (window :pointer)
-  (vertical-ch chtype)
-  (horizontal-ch chtype))
+  (ls :pointer)
+  (rs :pointer)
+  (ts :pointer)
+  (bs :pointer)
+  (tl :pointer)
+  (tr :pointer)
+  (bl :pointer)
+  (br :pointer))
 
-(defcfun ("wborder" c-window-border) :int
+(defcfun "whline_set" :int
   (window :pointer)
-  (ls chtype)
-  (rs chtype)
-  (ts chtype)
-  (bs chtype)
-  (tl chtype)
-  (tr chtype)
-  (bl chtype)
-  (br chtype))
+  (wch :pointer)
+  (n :int))
+
+(defcfun "wvline_set" :int
+  (window :pointer)
+  (wch :pointer)
+  (n :int))
+
+(defun border (window &key left right top bottom top-left top-right bottom-left
+               bottom-right)
+  (let* ((args (list left right top bottom top-left top-right bottom-left
+                     bottom-right))
+         (trans (mapcar 'translate-wacs args)))
+    (apply 'wborder-set (window-pointer window) trans)))
+
+(defun hline (window wch n)
+  (whline-set (window-pointer window) (translate-wacs wch) n))
+
+(defun vline (window wch n)
+  (wvline-set (window-pointer window) (translate-wacs wch) n))
+
+
+
+(defcfun "wcolor_set" :int
+  (window :pointer)
+  (color-pair-number :short)
+  (opts :pointer))
+
+(defmethod (setf color) (color-pair-number (w window))
+  (wcolor-set (window-pointer w) color-pair-number (null-pointer)))